GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Compare commits

base: GitHub:v3.11-test-release-9
Branches Tags
GitHub:master GitHub:majestic GitHub:try-to-build-python-module-for-win GitHub:gf-lsp-expose-all GitHub:build-python-win GitHub:tp_nix_flake GitHub:build-timestamp GitHub:wasm GitHub:majestic-macos GitHub:majestic-ci GitHub:lpgf GitHub:c-runtime GitHub:concrete-new GitHub:canonical GitHub:pgf2-complete GitHub:lpgf-memo GitHub:lpgf-string GitHub:compact-pgf GitHub:js-bindings GitHub:sense-disambiguation GitHub:remove-example-based
GitHub:release-3.12 GitHub:release3.12-rc-3 GitHub:release3.12-rc-2 GitHub:release3.12-rc-1 GitHub:3.11 GitHub:v3.11-test-release-9 GitHub:v3.11-test-release-8 GitHub:GF-3.10 GitHub:RELEASE-3.9 GitHub:RELEASE-3.8 GitHub:introduced-parser-test
..
compare: GitHub:compact-pgf
Branches Tags
GitHub:master GitHub:majestic GitHub:try-to-build-python-module-for-win GitHub:gf-lsp-expose-all GitHub:build-python-win GitHub:tp_nix_flake GitHub:build-timestamp GitHub:wasm GitHub:majestic-macos GitHub:majestic-ci GitHub:lpgf GitHub:c-runtime GitHub:concrete-new GitHub:canonical GitHub:pgf2-complete GitHub:lpgf-memo GitHub:lpgf-string GitHub:compact-pgf GitHub:js-bindings GitHub:sense-disambiguation GitHub:remove-example-based
GitHub:release-3.12 GitHub:release3.12-rc-3 GitHub:release3.12-rc-2 GitHub:release3.12-rc-1 GitHub:3.11 GitHub:v3.11-test-release-9 GitHub:v3.11-test-release-8 GitHub:GF-3.10 GitHub:RELEASE-3.9 GitHub:RELEASE-3.8 GitHub:introduced-parser-test

21 Commits
v3.11-test ... compact-pg

Author SHA1 Message Date
krangelov
320ead943c Merge branch 'c-runtime' into compact-pgf 2019-09-20 14:08:30 +02:00
krangelov
c119d5e34b silence encoding error 2019-09-20 14:07:07 +02:00
krangelov
529635e0e9 Merge branch 'c-runtime' into compact-pgf 2019-09-20 11:22:15 +02:00
krangelov
a33a84df3d funnel the generated byte code to the runtime 2019-09-20 11:18:17 +02:00
krangelov
9e3512db81 Merge branch 'c-runtime' into compact-pgf 2019-09-20 10:55:23 +02:00
krangelov
8a419f66a6 Merge branch 'master' into c-runtime 2019-09-20 10:52:40 +02:00
krangelov
a27bcb8092 Merge branch 'master' into c-runtime 2019-09-20 10:42:50 +02:00
krangelov
e989cc69a2 compute the parameter indices 2019-09-20 09:49:46 +02:00
krangelov
5c5af8df79 Merge branch 'c-runtime' into compact-pgf 2019-09-20 08:10:46 +02:00
krangelov
084b345663 added option to show the probabilities of results 2019-09-20 08:09:54 +02:00
krangelov
400aad1d07 Merge branch 'c-runtime' into compact-pgf 2019-09-20 07:19:47 +02:00
krangelov
a0cfe09e09 added option -number to limit the number of parse results 2019-09-20 07:18:58 +02:00
krangelov
12912299be added extra integer to store the offset of a parameter constructor 2019-09-19 22:53:07 +02:00
krangelov
b3c07d45b9 remove the old Haskell runtime 2019-09-19 22:40:40 +02:00
krangelov
acb70ccc1b cleanup 2019-09-19 22:30:08 +02:00
krangelov
4a71464ca7 Merge with master and drop the Haskell runtime completely 2019-09-19 22:01:57 +02:00
krangelov
e993ae59f8 drop the haskell runtime, part 2 2019-09-19 10:06:06 +02:00
krangelov
f12557acf8 remove the dependency to the Haskell runtime completely 2019-09-19 10:03:04 +02:00
Krasimir Angelov
6a5053daeb move the PGF optimizer in the compiler 2018-11-02 14:48:30 +01:00
Krasimir Angelov
5a2b200948 manually copy the "c-runtime" branch from the old repository. 2018-11-02 14:38:44 +01:00
Krasimir Angelov
bf5abe2948 the compiler and the Haskell runtime now support abstract senses 2018-11-02 14:01:54 +01:00
292 changed files with 61363 additions and 17747 deletions
Expand all files Collapse all files

96
.github/workflows/build-all-versions.yml vendored
View File

@@ -1,96 +0,0 @@
# Based on the template here: https://kodimensional.dev/github-actions
name: Build with stack and cabal
# Trigger the workflow on push or pull request, but only for the master branch
on:
pull_request:
push:
branches: [master]
jobs:
cabal:
name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
runs-on: ${{ matrix.os }}
strategy:
matrix:
os: [ubuntu-latest, macos-latest, windows-latest]
cabal: ["latest"]
ghc:
- "8.6.5"
- "8.8.3"
- "8.10.1"
exclude:
- os: macos-latest
ghc: 8.8.3
- os: macos-latest
ghc: 8.6.5
- os: windows-latest
ghc: 8.8.3
- os: windows-latest
ghc: 8.6.5
steps:
- uses: actions/checkout@v2
if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
- uses: haskell/actions/setup@v1
id: setup-haskell-cabal
name: Setup Haskell
with:
ghc-version: ${{ matrix.ghc }}
cabal-version: ${{ matrix.cabal }}
- name: Freeze
run: |
cabal freeze
- uses: actions/cache@v1
name: Cache ~/.cabal/store
with:
path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
key: ${{ runner.os }}-${{ matrix.ghc }}
# key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
- name: Build
run: |
cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
cabal build all
# - name: Test
# run: |
# cabal test all
stack:
name: stack / ghc ${{ matrix.ghc }}
runs-on: ubuntu-latest
strategy:
matrix:
stack: ["latest"]
ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"]
# ghc: ["8.8.3"]
steps:
- uses: actions/checkout@v2
if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
- uses: haskell/actions/setup@v1
name: Setup Haskell Stack
with:
ghc-version: ${{ matrix.ghc }}
stack-version: 'latest'
enable-stack: true
- uses: actions/cache@v1
name: Cache ~/.stack
with:
path: ~/.stack
key: ${{ runner.os }}-${{ matrix.ghc }}-stack
- name: Build
run: |
stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
# stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
- name: Test
run: |
stack test --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml

230
.github/workflows/build-binary-packages.yml vendored
View File

@@ -1,230 +0,0 @@
name: Build Binary Packages
on:
workflow_dispatch:
release:
types: ["created"]
jobs:
# ---
ubuntu:
name: Build Ubuntu package
strategy:
matrix:
os:
- ubuntu-18.04
- ubuntu-20.04
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v2
# Note: `haskell-platform` is listed as requirement in debian/control,
# which is why it's installed using apt instead of the Setup Haskell action.
# - name: Setup Haskell
# uses: actions/setup-haskell@v1
# id: setup-haskell-cabal
# with:
# ghc-version: ${{ matrix.ghc }}
# cabal-version: ${{ matrix.cabal }}
- name: Install build tools
run: |
sudo apt-get update
sudo apt-get install -y \
make \
dpkg-dev \
debhelper \
haskell-platform \
libghc-json-dev \
python-dev \
default-jdk \
libtool-bin
- name: Build package
run: |
make deb
- name: Copy package
run: |
cp ../gf_*.deb dist/
- name: Upload artifact
uses: actions/upload-artifact@v2
with:
name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
path: dist/gf_*.deb
if-no-files-found: error
- name: Rename package for specific ubuntu version
run: |
mv dist/gf_*.deb dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
- uses: actions/upload-release-asset@v1.0.2
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
upload_url: ${{ github.event.release.upload_url }}
asset_path: dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
asset_name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
asset_content_type: application/octet-stream
# ---
macos:
name: Build macOS package
strategy:
matrix:
ghc: ["8.6.5"]
cabal: ["2.4"]
os: ["macos-10.15"]
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v2
- name: Setup Haskell
uses: actions/setup-haskell@v1
id: setup-haskell-cabal
with:
ghc-version: ${{ matrix.ghc }}
cabal-version: ${{ matrix.cabal }}
- name: Install build tools
run: |
brew install \
automake
cabal v1-install alex happy
- name: Build package
run: |
sudo mkdir -p /Library/Java/Home
sudo ln -s /usr/local/opt/openjdk/include /Library/Java/Home/include
make pkg
- name: Upload artifact
uses: actions/upload-artifact@v2
with:
name: gf-${{ github.event.release.tag_name }}-macos
path: dist/gf-*.pkg
if-no-files-found: error
- name: Rename package
run: |
mv dist/gf-*.pkg dist/gf-${{ github.event.release.tag_name }}-macos.pkg
- uses: actions/upload-release-asset@v1.0.2
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
upload_url: ${{ github.event.release.upload_url }}
asset_path: dist/gf-${{ github.event.release.tag_name }}-macos.pkg
asset_name: gf-${{ github.event.release.tag_name }}-macos.pkg
asset_content_type: application/octet-stream
# ---
windows:
name: Build Windows package
strategy:
matrix:
ghc: ["8.6.5"]
cabal: ["2.4"]
os: ["windows-2019"]
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v2
- name: Setup MSYS2
uses: msys2/setup-msys2@v2
with:
install: >-
base-devel
gcc
python-devel
- name: Prepare dist folder
shell: msys2 {0}
run: |
mkdir /c/tmp-dist
mkdir /c/tmp-dist/c
mkdir /c/tmp-dist/java
mkdir /c/tmp-dist/python
- name: Build C runtime
shell: msys2 {0}
run: |
cd src/runtime/c
autoreconf -i
./configure
make
make install
cp /mingw64/bin/libpgf-0.dll /c/tmp-dist/c
cp /mingw64/bin/libgu-0.dll /c/tmp-dist/c
# JAVA_HOME_8_X64 = C:\hostedtoolcache\windows\Java_Adopt_jdk\8.0.292-10\x64
- name: Build Java bindings
shell: msys2 {0}
run: |
export JDKPATH=/c/hostedtoolcache/windows/Java_Adopt_jdk/8.0.292-10/x64
export PATH="${PATH}:${JDKPATH}/bin"
cd src/runtime/java
make \
JNI_INCLUDES="-I \"${JDKPATH}/include\" -I \"${JDKPATH}/include/win32\" -I \"/mingw64/include\" -D__int64=int64_t" \
WINDOWS_LDFLAGS="-L\"/mingw64/lib\" -no-undefined"
make install
cp .libs/msys-jpgf-0.dll /c/tmp-dist/java/jpgf.dll
cp jpgf.jar /c/tmp-dist/java
- name: Build Python bindings
shell: msys2 {0}
env:
EXTRA_INCLUDE_DIRS: /mingw64/include
EXTRA_LIB_DIRS: /mingw64/lib
run: |
cd src/runtime/python
python setup.py build
python setup.py install
cp /usr/lib/python3.9/site-packages/pgf* /c/tmp-dist/python
- name: Setup Haskell
uses: actions/setup-haskell@v1
id: setup-haskell-cabal
with:
ghc-version: ${{ matrix.ghc }}
cabal-version: ${{ matrix.cabal }}
- name: Install Haskell build tools
run: |
cabal install alex happy
- name: Build GF
run: |
cabal install --only-dependencies -fserver
cabal configure -fserver
cabal build
copy dist\build\gf\gf.exe C:\tmp-dist
- name: Upload artifact
uses: actions/upload-artifact@v2
with:
name: gf-${{ github.event.release.tag_name }}-windows
path: C:\tmp-dist\*
if-no-files-found: error
- name: Create archive
run: |
Compress-Archive C:\tmp-dist C:\gf-${{ github.event.release.tag_name }}-windows.zip
- uses: actions/upload-release-asset@v1.0.2
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
upload_url: ${{ github.event.release.upload_url }}
asset_path: C:\gf-${{ github.event.release.tag_name }}-windows.zip
asset_name: gf-${{ github.event.release.tag_name }}-windows.zip
asset_content_type: application/zip

98
.github/workflows/build-python-package.yml vendored
View File

@@ -1,98 +0,0 @@
name: Build & Publish Python Package
# Trigger the workflow on push or pull request, but only for the master branch
on:
pull_request:
push:
branches: [master]
jobs:
build_wheels:
name: Build wheel on ${{ matrix.os }}
runs-on: ${{ matrix.os }}
strategy:
fail-fast: true
matrix:
os: [ubuntu-18.04, macos-10.15]
steps:
- uses: actions/checkout@v1
- uses: actions/setup-python@v1
name: Install Python
with:
python-version: '3.7'
- name: Install cibuildwheel
run: |
python -m pip install git+https://github.com/joerick/cibuildwheel.git@main
- name: Install build tools for OSX
if: startsWith(matrix.os, 'macos')
run: |
brew install automake
- name: Build wheels on Linux
if: startsWith(matrix.os, 'macos') != true
env:
CIBW_BEFORE_BUILD: cd src/runtime/c && autoreconf -i && ./configure && make && make install
run: |
python -m cibuildwheel src/runtime/python --output-dir wheelhouse
- name: Build wheels on OSX
if: startsWith(matrix.os, 'macos')
env:
CIBW_BEFORE_BUILD: cd src/runtime/c && glibtoolize && autoreconf -i && ./configure && make && make install
run: |
python -m cibuildwheel src/runtime/python --output-dir wheelhouse
- uses: actions/upload-artifact@v2
with:
path: ./wheelhouse
build_sdist:
name: Build source distribution
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v2
- uses: actions/setup-python@v2
name: Install Python
with:
python-version: '3.7'
- name: Build sdist
run: cd src/runtime/python && python setup.py sdist
- uses: actions/upload-artifact@v2
with:
path: ./src/runtime/python/dist/*.tar.gz
upload_pypi:
name: Upload to PyPI
needs: [build_wheels, build_sdist]
runs-on: ubuntu-latest
if: github.ref == 'refs/heads/master' && github.event_name == 'push'
steps:
- uses: actions/checkout@v2
- name: Set up Python
uses: actions/setup-python@v2
with:
python-version: '3.x'
- name: Install twine
run: pip install twine
- uses: actions/download-artifact@v2
with:
name: artifact
path: ./dist
- name: Publish
env:
TWINE_USERNAME: __token__
TWINE_PASSWORD: ${{ secrets.pypi_password }}
run: |
(cd ./src/runtime/python && curl -I --fail https://pypi.org/project/$(python setup.py --name)/$(python setup.py --version)/) || twine upload dist/*

11
.gitignore vendored
View File

@@ -5,14 +5,7 @@
*.jar
*.gfo
*.pgf
debian/.debhelper
debian/debhelper-build-stamp
debian/gf
debian/gf.debhelper.log
debian/gf.substvars
debian/files
dist/
dist-newstyle/
src/runtime/c/.libs/
src/runtime/c/Makefile
src/runtime/c/Makefile.in
@@ -53,10 +46,6 @@ DATA_DIR
stack*.yaml.lock
# Output files for test suite
*.out
gf-tests.html
# Generated documentation (not exhaustive)
demos/index-numbers.html
demos/resourcegrammars.html

41
Makefile
View File

@@ -1,48 +1,31 @@
.PHONY: all build install doc clean html deb pkg bintar sdist
.PHONY: all build install doc clean gf html deb pkg bintar sdist
# This gets the numeric part of the version from the cabal file
VERSION=$(shell sed -ne "s/^version: *\([0-9.]*\).*/\1/p" gf.cabal)
# Check if stack is installed
STACK=$(shell if hash stack 2>/dev/null; then echo "1"; else echo "0"; fi)
# Check if cabal >= 2.4 is installed (with v1- and v2- commands)
CABAL_NEW=$(shell if cabal v1-repl --help >/dev/null 2>&1 ; then echo "1"; else echo "0"; fi)
ifeq ($(STACK),1)
CMD=stack
else
CMD=cabal
ifeq ($(CABAL_NEW),1)
CMD_PFX=v1-
endif
endif
all: build
dist/setup-config: gf.cabal Setup.hs WebSetup.hs
ifneq ($(STACK),1)
cabal ${CMD_PFX}configure
endif
cabal configure
build: dist/setup-config
${CMD} ${CMD_PFX}build
cabal build
install:
ifeq ($(STACK),1)
stack install
else
cabal ${CMD_PFX}copy
cabal ${CMD_PFX}register
endif
cabal copy
cabal register
doc:
${CMD} ${CMD_PFX}haddock
cabal haddock
clean:
${CMD} ${CMD_PFX}clean
cabal clean
bash bin/clean_html
gf:
cabal build rgl-none
strip dist/build/gf/gf
html::
bash bin/update_html
@@ -52,7 +35,7 @@ html::
deb:
dpkg-buildpackage -b -uc
# Make a macOS installer package
# Make an OS X Installer package
pkg:
FMT=pkg bash bin/build-binary-dist.sh

11
README.md
View File

@@ -2,6 +2,8 @@
# Grammatical Framework (GF)
[![Build Status](https://travis-ci.org/GrammaticalFramework/gf-core.svg?branch=master)](https://travis-ci.org/GrammaticalFramework/gf-core)
The Grammatical Framework is a grammar formalism based on type theory.
It consists of:
@@ -30,16 +32,13 @@ GF particularly addresses four aspects of grammars:
## Compilation and installation
The simplest way of installing GF from source is with the command:
The simplest way of installing GF is with the command:
```
cabal install
```
or:
```
stack install
```
For more information, including links to precompiled binaries, see the [download page](http://www.grammaticalframework.org/download/index.html).
For more details, see the [download page](http://www.grammaticalframework.org/download/index.html)
and [developers manual](http://www.grammaticalframework.org/doc/gf-developers.html).
## About this repository

66
RELEASE.md
View File

@@ -1,66 +0,0 @@
# GF Core releases
**Note:**
The RGL is now released completely separately from GF Core.
See the [RGL's RELEASE.md](https://github.com/GrammaticalFramework/gf-rgl/blob/master/RELEASE.md).
## Creating a new release
### 1. Prepare the repository
**Web pages**
1. Create `download/index-X.Y.md` with installation instructions.
2. Create `download/release-X.Y.md` with changelog information.
3. Update `download/index.html` to redirect to the new version.
4. Add announcement in news section in `index.html`.
**Version numbers**
1. Update version number in `gf.cabal` (ommitting `-git` suffix).
2. Add a new line in `debian/changelog`.
### 2. Create GitHub release
1. When the above changes are committed to the `master` branch in the repository
and pushed, check that all CI workflows are successful (fixing as necessary):
- <https://github.com/GrammaticalFramework/gf-core/actions>
- <https://travis-ci.org/github/GrammaticalFramework/gf-core>
2. Create a GitHub release [here](https://github.com/GrammaticalFramework/gf-core/releases/new):
- Tag version format `RELEASE-X.Y`
- Title: "GF X.Y"
- Description: mention major changes since last release
3. Publish the release to trigger the building of the binary packages (below).
### 3. Binary packages
The binaries will be built automatically by GitHub Actions when the release is created,
but the generated _artifacts_ must be manually attached to the release as _assets_.
1. Go to the [actions page](https://github.com/GrammaticalFramework/gf-core/actions) and click "Build Binary Packages" under _Workflows_.
2. Choose the workflow run corresponding to the newly created release.
3. Download the artifacts locally. Extract the Ubuntu and macOS ones to get the `.deb` and `.pkg` files.
4. Go back to the [releases page](https://github.com/GrammaticalFramework/gf-core/releases) and click to edit the release information.
5. Add the downloaded artifacts as release assets, giving them names with format `gf-X.Y-PLATFORM.EXT` (e.g. `gf-3.11-macos.pkg`).
### 4. Upload to Hackage
In order to do this you will need to be added the [GF maintainers](https://hackage.haskell.org/package/gf/maintainers/) on Hackage.
1. Run `make sdist`
2. Upload the package, either:
1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file `dist/gf-X.Y.tar.gz`
2. **via Cabal (≥2.4)**: `cabal upload dist/gf-X.Y.tar.gz`
3. If the documentation-building fails on the Hackage server, do:
```
cabal v2-haddock --builddir=dist/docs --haddock-for-hackage --enable-doc
cabal upload --documentation dist/docs/*-docs.tar.gz
```
## Miscellaneous
### What is the tag `GF-3.10`?
For GF 3.10, the Core and RGL repositories had already been separated, however
the binary packages still included the RGL. `GF-3.10` is a tag that was created
in both repositories ([gf-core](https://github.com/GrammaticalFramework/gf-core/releases/tag/GF-3.10) and [gf-rgl](https://github.com/GrammaticalFramework/gf-rgl/releases/tag/GF-3.10)) to indicate which versions of each went into the binaries.

7
Setup.hs
View File

@@ -19,6 +19,7 @@ main = defaultMainWithHooks simpleUserHooks
, preInst = gfPreInst
, postInst = gfPostInst
, postCopy = gfPostCopy
, sDistHook = gfSDist
}
where
gfPreBuild args = gfPre args . buildDistPref
@@ -28,17 +29,17 @@ main = defaultMainWithHooks simpleUserHooks
return emptyHookedBuildInfo
gfPostBuild args flags pkg lbi = do
-- noRGLmsg
noRGLmsg
let gf = default_gf lbi
buildWeb gf flags (pkg,lbi)
gfPostInst args flags pkg lbi = do
-- noRGLmsg
noRGLmsg
saveInstallPath args flags (pkg,lbi)
installWeb (pkg,lbi)
gfPostCopy args flags pkg lbi = do
-- noRGLmsg
noRGLmsg
saveCopyPath args flags (pkg,lbi)
copyWeb flags (pkg,lbi)

15
WebSetup.hs
View File

@@ -26,14 +26,6 @@ import Distribution.PackageDescription(PackageDescription(..))
so users won't see this message unless they check the log.)
-}
-- | Notice about contrib grammars
noContribMsg :: IO ()
noContribMsg = putStr $ unlines
[ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
, "If you want them to be built, clone the following repository in the same directory as gf-core:"
, "https://github.com/GrammaticalFramework/gf-contrib.git"
]
example_grammars :: [(String, String, [String])] -- [(pgf, subdir, source modules)]
example_grammars =
[("Letter.pgf","letter",letterSrc)
@@ -58,8 +50,11 @@ buildWeb gf flags (pkg,lbi) = do
contrib_exists <- doesDirectoryExist contrib_dir
if contrib_exists
then mapM_ build_pgf example_grammars
-- else noContribMsg
else return ()
else putStr $ unlines
[ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
, "If you want these example grammars to be built, clone this repository in the same top-level directory as GF:"
, "https://github.com/GrammaticalFramework/gf-contrib.git"
]
where
gfo_dir = buildDir lbi </> "examples"

74
bin/build-binary-dist.sh
View File

@@ -1,18 +1,15 @@
#! /bin/bash
### This script builds a binary distribution of GF from source.
### It assumes that you have Haskell and Cabal installed.
### Two binary package formats are supported (specified with the FMT env var):
### - plain tar files (.tar.gz)
### - macOS installer packages (.pkg)
### This script builds a binary distribution of GF from the source
### package that this script is a part of. It assumes that you have installed
### a recent version of the Haskell Platform.
### Two binary package formats are supported: plain tar files (.tar.gz) and
### OS X Installer packages (.pkg).
os=$(uname) # Operating system name (e.g. Darwin or Linux)
hw=$(uname -m) # Hardware name (e.g. i686 or x86_64)
cabal="cabal v1-" # Cabal >= 2.4
# cabal="cabal " # Cabal <= 2.2
## Get GF version number from Cabal file
# GF version number:
ver=$(grep -i ^version: gf.cabal | sed -e 's/version://' -e 's/ //g')
name="gf-$ver"
@@ -32,7 +29,6 @@ set -x # print commands before executing them
pushd src/runtime/c
bash setup.sh configure --prefix="$prefix"
bash setup.sh build
bash setup.sh install prefix="$prefix" # hack required for GF build on macOS
bash setup.sh install prefix="$destdir$prefix"
popd
@@ -42,11 +38,11 @@ if which >/dev/null python; then
EXTRA_INCLUDE_DIRS="$extrainclude" EXTRA_LIB_DIRS="$extralib" python setup.py build
python setup.py install --prefix="$destdir$prefix"
if [ "$fmt" == pkg ] ; then
# A hack for Python on macOS to find the PGF modules
pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
pydest="$destdir/Library/Python/$pyver/site-packages"
mkdir -p "$pydest"
ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
# A hack for Python on OS X to find the PGF modules
pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
pydest="$destdir/Library/Python/$pyver/site-packages"
mkdir -p "$pydest"
ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
fi
popd
else
@@ -57,42 +53,52 @@ fi
if which >/dev/null javac && which >/dev/null jar ; then
pushd src/runtime/java
rm -f libjpgf.la # In case it contains the wrong INSTALL_PATH
if make CFLAGS="-I$extrainclude -L$extralib" INSTALL_PATH="$prefix"
if make CFLAGS="-I$extrainclude -L$extralib" INSTALL_PATH="$prefix/lib"
then
make INSTALL_PATH="$destdir$prefix" install
make INSTALL_PATH="$destdir$prefix/lib" install
else
echo "Skipping the Java binding because of errors"
echo "*** Skipping the Java binding because of errors"
fi
popd
else
echo "Java SDK is not installed, so the Java binding will not be included"
fi
## To find dynamic C run-time libraries when building GF below
export DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib"
## Build GF, with C run-time support enabled
${cabal}install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
${cabal}configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
${cabal}build
cabal install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
cabal configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
# Building the example grammars will fail, because the RGL is missing
cabal copy --destdir="$destdir" # create www directory
## Build the RGL and copy it to $destdir
PATH=$PWD/dist/build/gf:$PATH
export GF_LIB_PATH="$(dirname $(find "$destdir" -name www))/lib" # hmm
mkdir -p "$GF_LIB_PATH"
pushd ../gf-rgl
make build
make copy
popd
# Build GF again, including example grammars that need the RGL
DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
## Copy GF to $destdir
${cabal}copy --destdir="$destdir"
cabal copy --destdir="$destdir"
libdir=$(dirname $(find "$destdir" -name PGF.hi))
${cabal}register --gen-pkg-config="$libdir/gf-$ver.conf"
cabal register --gen-pkg-config=$libdir/gf-$ver.conf
## Create the binary distribution package
case $fmt in
tar.gz)
targz="$name-bin-$hw-$os.tar.gz" # the final tar file
tar --directory "$destdir/$prefix" --gzip --create --file "dist/$targz" .
echo "Created $targz"
;;
targz="$name-bin-$hw-$os.tar.gz" # the final tar file
tar -C "$destdir/$prefix" -zcf "dist/$targz" .
echo "Created $targz, consider renaming it to something more user friendly"
;;
pkg)
pkg=$name.pkg
pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
echo "Created $pkg"
pkg=$name.pkg
pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
echo "Created $pkg"
esac
## Cleanup
rm -r "$destdir"

3
bin/template.html
View File

@@ -82,10 +82,9 @@ $body$
<li><a href="http://cloud.grammaticalframework.org/">GF Cloud</a></li>
<li>
<a href="$rel-root$/doc/tutorial/gf-tutorial.html">Tutorial</a>
·
/
<a href="$rel-root$/lib/doc/rgl-tutorial/index.html">RGL Tutorial</a>
</li>
<li><a href="$rel-root$/doc/gf-video-tutorials.html">Video Tutorials</a></li>
<li><a href="$rel-root$/download"><strong>Download GF</strong></a></li>
</ul>
</div>

2
bin/update_html
View File

@@ -147,7 +147,7 @@ else
fi
done
find . -name '*.md' | while read file ; do
if [[ "$file" == *"README.md" ]] || [[ "$file" == *"RELEASE.md" ]] ; then continue ; fi
if [[ "$file" == *"README.md" ]] ; then continue ; fi
html="${file%.md}.html"
if [ "$file" -nt "$html" ] || [ "$template" -nt "$html" ] ; then
render_md_html "$file" "$html"

12
debian/changelog vendored
View File

@@ -1,15 +1,3 @@
gf (3.11) bionic focal; urgency=low
* GF 3.11
-- Inari Listenmaa <inari@digitalgrammars.com> Sun, 25 Jul 2021 10:27:40 +0800
gf (3.10.4-1) xenial bionic cosmic; urgency=low
* GF 3.10.4
-- Thomas Hallgren <hallgren@chalmers.se> Fri, 18 Nov 2019 15:00:00 +0100
gf (3.10.3-1) xenial bionic cosmic; urgency=low
* GF 3.10.3

4
debian/control vendored
View File

@@ -3,14 +3,14 @@ Section: devel
Priority: optional
Maintainer: Thomas Hallgren <hallgren@chalmers.se>
Standards-Version: 3.9.2
Build-Depends: debhelper (>= 5), haskell-platform (>= 2011.2.0.1), libghc-haskeline-dev, libghc-mtl-dev, libghc-json-dev, autoconf, automake, libtool-bin, python-dev, java-sdk
Build-Depends: debhelper (>= 5), haskell-platform (>= 2011.2.0.1), libghc-haskeline-dev, libghc-mtl-dev, libghc-json-dev, autoconf, automake, libtool-bin, python-dev, java-sdk, txt2tags, pandoc
Homepage: http://www.grammaticalframework.org/
Package: gf
Architecture: any
Depends: ${shlibs:Depends}
Description: Tools for GF, a grammar formalism based on type theory
Grammatical Framework (GF) is a grammar formalism based on type theory.
Grammatical Framework (GF) is a grammar formalism based on type theory.
It consists of a special-purpose programming language,
a compiler of the language, and a generic grammar processor.
.

20
debian/rules vendored
View File

@@ -1,6 +1,6 @@
#!/usr/bin/make -f
%:
%:
+dh $@
#dh_shlibdeps has a problem finding which package some of the Haskell
@@ -16,23 +16,27 @@ override_dh_shlibdeps:
override_dh_auto_configure:
cd src/runtime/c && bash setup.sh configure --prefix=/usr
cd src/runtime/c && bash setup.sh build
cabal v1-update
cabal v1-install --only-dependencies
cabal v1-configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
cabal update
cabal install --only-dependencies
cabal configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
override_dh_auto_build:
cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build
cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr
cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr/lib
echo $(SET_LDL)
-$(SET_LDL) cabal v1-build
-$(SET_LDL) cabal build # builds gf, fails to build example grammars
export $(SET_LDL); PATH=$(CURDIR)/dist/build/gf:$$PATH && make -C ../gf-rgl build
GF_LIB_PATH=$(CURDIR)/../gf-rgl/dist $(SET_LDL) cabal build # have RGL now, ok to build example grammars
make html
override_dh_auto_install:
$(SET_LDL) cabal v1-copy --destdir=$(CURDIR)/debian/gf
$(SET_LDL) cabal copy --destdir=$(CURDIR)/debian/gf # creates www directory
export GF_LIB_PATH="$$(dirname $$(find "$(CURDIR)/debian/gf" -name www))/lib" && echo "GF_LIB_PATH=$$GF_LIB_PATH" && mkdir -p "$$GF_LIB_PATH" && make -C ../gf-rgl copy
cd src/runtime/c && bash setup.sh copy prefix=$(CURDIR)/debian/gf/usr
cd src/runtime/python && python setup.py install --prefix=$(CURDIR)/debian/gf/usr
cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr install
cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr/lib install
D="`find debian/gf -name site-packages`" && [ -n "$$D" ] && cd $$D && cd .. && mv site-packages dist-packages
override_dh_auto_clean:

27
doc/errors/gluing.md
View File

@@ -1,27 +0,0 @@
## unsupported token gluing `foo + bar`
There was a problem in an expression using +, e.g. `foo + bar`.
This can be due to two causes, check which one applies in your case.
1. You are trying to use + on runtime arguments. Even if you are using
`foo + bar` in an oper, make sure that the oper isn't called in a
linearization that takes arguments. Both of the following are illegal:
lin Test foo bar = foo.s + bar.s -- explicit + in a lin
lin Test foo bar = opWithPlus foo bar -- the oper uses +
2. One of the arguments in `foo + bar` is a bound variable
from pattern matching a string, but the cases are non-exhaustive.
Example:
case "test" of {
x + "a" => x + "b" -- no applicable case for "test", so x = ???
} ;
You can fix this by adding a catch-all case in the end:
{ x + "a" => x + "b" ;
_ => "default case" } ;
3. If neither applies to your problem, submit a bug report and we
will update the error message and this documentation.
https://github.com/GrammaticalFramework/gf-core/issues

201
doc/gf-developers-old-cabal.t2t
View File

@@ -1,201 +0,0 @@
GF Developer's Guide: Old installation instructions with Cabal
This page contains the old installation instructions from the [Developer's Guide ../doc/gf-developers.html].
We recommend Stack as a primary installation method, because it's easier for a Haskell beginner, and we want to keep the main instructions short.
But if you are an experienced Haskeller and want to keep using Cabal, here are the old instructions using ``cabal install``.
Note that some of these instructions may be outdated. Other parts may still be useful.
== Compilation from source with Cabal ==
The build system of GF is based on //Cabal//, which is part of the
Haskell Platform, so no extra steps are needed to install it. In the simplest
case, all you need to do to compile and install GF, after downloading the
source code as described above, is
```
$ cabal install
```
This will automatically download any additional Haskell libraries needed to
build GF. If this is the first time you use Cabal, you might need to run
``cabal update`` first, to update the list of available libraries.
If you want more control, the process can also be split up into the usual
//configure//, //build// and //install// steps.
=== Configure ===
During the configuration phase Cabal will check that you have all
necessary tools and libraries needed for GF. The configuration is
started by the command:
```
$ cabal configure
```
If you don't see any error message from the above command then you
have everything that is needed for GF. You can also add the option
``-v`` to see more details about the configuration.
You can use ``cabal configure --help`` to get a list of configuration options.
=== Build ===
The build phase does two things. First it builds the GF compiler from
the Haskell source code and after that it builds the GF Resource Grammar
Library using the already build compiler. The simplest command is:
```
$ cabal build
```
Again you can add the option ``-v`` if you want to see more details.
==== Parallel builds ====
If you have Cabal>=1.20 you can enable parallel compilation by using
```
$ cabal build -j
```
or by putting a line
```
jobs: $ncpus
```
in your ``.cabal/config`` file. Cabal
will pass this option to GHC when building the GF compiler, if you
have GHC>=7.8.
Cabal also passes ``-j`` to GF to enable parallel compilation of the
Resource Grammar Library. This is done unconditionally to avoid
causing problems for developers with Cabal<1.20. You can disable this
by editing the last few lines in ``WebSetup.hs``.
=== Install ===
After you have compiled GF you need to install the executable and libraries
to make the system usable.
```
$ cabal copy
$ cabal register
```
This command installs the GF compiler for a single user, in the standard
place used by Cabal.
On Linux and Mac this could be ``$HOME/.cabal/bin``.
On Mac it could also be ``$HOME/Library/Haskell/bin``.
On Windows this is ``C:\Program Files\Haskell\bin``.
The compiled GF Resource Grammar Library will be installed
under the same prefix, e.g. in
``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and
in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows.
If you want to install in some other place then use the ``--prefix``
option during the configuration phase.
=== Clean ===
Sometimes you want to clean up the compilation and start again from clean
sources. Use the clean command for this purpose:
```
$ cabal clean
```
%=== SDist ===
%
%You can use the command:
%
%% This does *NOT* include everything that is needed // TH 2012-08-06
%```
%$ cabal sdist
%```
%
%to prepare archive with all source codes needed to compile GF.
=== Known problems with Cabal ===
Some versions of Cabal (at least version 1.16) seem to have a bug that can
cause the following error:
```
Configuring gf-3.x...
setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed
```
The exact cause of this problem is unclear, but it seems to happen
during the configure phase if the same version of GF is already installed,
so a workaround is to remove the existing installation with
```
ghc-pkg unregister gf
```
You can check with ``ghc-pkg list gf`` that it is gone.
== Compilation with make ==
If you feel more comfortable with Makefiles then there is a thin Makefile
wrapper arround Cabal for you. If you just type:
```
$ make
```
the configuration phase will be run automatically if needed and after that
the sources will be compiled.
%% cabal build rgl-none does not work with recent versions of Cabal
%If you don't want to compile the resource library
%every time then you can use:
%```
%$ make gf
%```
For installation use:
```
$ make install
```
For cleaning:
```
$ make clean
```
%and to build source distribution archive run:
%```
%$ make sdist
%```
== Partial builds of RGL ==
**NOTE**: The following doesn't work with recent versions of ``cabal``. //(This comment was left in 2015, so make your own conclusions.)//
%% // TH 2015-06-22
%Sometimes you just want to work on the GF compiler and don't want to
%recompile the resource library after each change. In this case use
%this extended command:
%```
%$ cabal build rgl-none
%```
The resource grammar library can be compiled in two modes: with present
tense only and with all tenses. By default it is compiled with all
tenses. If you want to use the library with only present tense you can
compile it in this special mode with the command:
```
$ cabal build present
```
You could also control which languages you want to be recompiled by
adding the option ``langs=list``. For example the following command
will compile only the English and the Swedish language:
```
$ cabal build langs=Eng,Swe
```

660
doc/gf-developers.t2t
View File

@@ -1,6 +1,6 @@
GF Developers Guide
2021-07-15
2018-07-26
%!options(html): --toc
@@ -15,287 +15,386 @@ you are a GF user who just wants to download and install GF
== Setting up your system for building GF ==
To build GF from source you need to install some tools on your
system: the Haskell build tool //Stack//, the version control software //Git// and the //Haskeline// library.
system: the //Haskell Platform//, //Git// and the //Haskeline library//.
%**On Linux** the best option is to install the tools via the standard
%software distribution channels, i.e. by using the //Software Center//
%in Ubuntu or the corresponding tool in other popular Linux distributions.
**On Linux** the best option is to install the tools via the standard
software distribution channels, i.e. by using the //Software Center//
in Ubuntu or the corresponding tool in other popular Linux distributions.
Or, from a Terminal window, the following command should be enough:
%**On Mac OS and Windows**, the tools can be downloaded from their respective
%web sites, as described below.
=== Stack ===
The primary installation method is via //Stack//.
(You can also use Cabal, but we recommend Stack to those who are new to Haskell.)
To install Stack:
- **On Linux and Mac OS**, do either
``$ curl -sSL https://get.haskellstack.org/ | sh``
or
``$ wget -qO- https://get.haskellstack.org/ | sh``
- On Ubuntu: ``sudo apt-get install haskell-platform git libghc6-haskeline-dev``
- On Fedora: ``sudo dnf install haskell-platform git ghc-haskeline-devel``
- **On other operating systems**, see the [installation guide https://docs.haskellstack.org/en/stable/install_and_upgrade].
**On Mac OS and Windows**, the tools can be downloaded from their respective
web sites, as described below.
=== The Haskell Platform ===
%If you already have Stack installed, upgrade it to the latest version by running: ``stack upgrade``
GF is written in Haskell, so first of all you need
the //Haskell Platform//, e.g. version 8.0.2 or 7.10.3. Downloads
and installation instructions are available from here:
http://hackage.haskell.org/platform/
Once you have installed the Haskell Platform, open a terminal
(Command Prompt on Windows) and try to execute the following command:
```
$ ghc --version
```
This command should show you which version of GHC you have. If the installation
of the Haskell Platform was successful you should see a message like:
```
The Glorious Glasgow Haskell Compilation System, version 8.0.2
```
Other required tools included in the Haskell Platform are
[Cabal http://www.haskell.org/cabal/],
[Alex http://www.haskell.org/alex/]
and
[Happy http://www.haskell.org/happy/].
=== Git ===
To get the GF source code, you also need //Git//, a distributed version control system.
To get the GF source code, you also need //Git//.
//Git// is a distributed version control system, see
https://git-scm.com/downloads for more information.
- **On Linux**, the best option is to install the tools via the standard
software distribution channels:
- On Ubuntu: ``sudo apt-get install git-all``
- On Fedora: ``sudo dnf install git-all``
- **On other operating systems**, see
https://git-scm.com/book/en/v2/Getting-Started-Installing-Git for installation.
=== Haskeline ===
=== The haskeline library ===
GF uses //haskeline// to enable command line editing in the GF shell.
This should work automatically on Mac OS and Windows, but on Linux one
extra step is needed to make sure the C libraries (terminfo)
required by //haskeline// are installed. Here is one way to do this:
- **On Mac OS and Windows**, this should work automatically.
- **On Linux**, an extra step is needed to make sure the C libraries (terminfo)
required by //haskeline// are installed:
- On Ubuntu: ``sudo apt-get install libghc-haskeline-dev``
- On Fedora: ``sudo dnf install ghc-haskeline-devel``
- On Ubuntu: ``sudo apt-get install libghc-haskeline-dev``
- On Fedora: ``sudo dnf install ghc-haskeline-devel``
== Getting the source ==[getting-source]
== Getting the source ==
Once you have all tools in place you can get the GF source code from
[GitHub https://github.com/GrammaticalFramework/]:
Once you have all tools in place you can get the GF source code. If you
just want to compile and use GF then it is enough to have read-only
access. It is also possible to make changes in the source code but if you
want these changes to be applied back to the main source repository you will
have to send the changes to us. If you plan to work continuously on
GF then you should consider getting read-write access.
- https://github.com/GrammaticalFramework/gf-core for the GF compiler
- https://github.com/GrammaticalFramework/gf-rgl for the Resource Grammar Library
=== Read-only access ===
==== Getting a fresh copy for read-only access ====
=== Read-only access: clone the main repository ===
If you only want to compile and use GF, you can just clone the repositories as follows:
Anyone can get the latest development version of GF by running:
```
$ git clone https://github.com/GrammaticalFramework/gf-core.git
$ git clone https://github.com/GrammaticalFramework/gf-rgl.git
$ git clone https://github.com/GrammaticalFramework/gf-core.git
$ git clone https://github.com/GrammaticalFramework/gf-rgl.git
```
To get new updates, run the following anywhere in your local copy of the repository:
This will create directories ``gf-core`` and ``gf-rgl`` in the current directory.
==== Updating your copy ====
To get all new patches from each repo:
```
$ git pull
```
This can be done anywhere in your local repository.
==== Recording local changes ====[record]
Since every copy is a repository, you can have local version control
of your changes.
If you have added files, you first need to tell your local repository to
keep them under revision control:
```
$ git pull
$ git add file1 file2 ...
```
=== Contribute your changes: fork the main repository ===
If you want the possibility to contribute your changes,
you should create your own fork, do your changes there,
and then send a pull request to the main repository.
+ **Creating and cloning a fork —**
See GitHub documentation for instructions how to [create your own fork https://docs.github.com/en/get-started/quickstart/fork-a-repo]
of the repository. Once you've done it, clone the fork to your local computer.
To record changes, use:
```
$ git clone https://github.com/<YOUR_USERNAME>/gf-core.git
$ git commit file1 file2 ...
```
+ **Updating your copy —**
Once you have cloned your fork, you need to set up the main repository as a remote:
This creates a patch against the previous version and stores it in your
local repository. You can record any number of changes before
pushing them to the main repo. In fact, you don't have to push them at
all if you want to keep the changes only in your local repo.
Instead of enumerating all modified files on the command line,
you can use the flag ``-a`` to automatically record //all// modified
files. You still need to use ``git add`` to add new files.
=== Read-write access ===
If you are a member of the GF project on GitHub, you can push your
changes directly to the GF git repository on GitHub.
```
$ git remote add upstream https://github.com/GrammaticalFramework/gf-core.git
$ git push
```
Then you can get the latest updates by running the following:
It is also possible for anyone else to contribute by
```
$ git pull upstream master
```
+ **Recording local changes —**
See Git tutorial on how to [record and push your changes https://git-scm.com/book/en/v2/Git-Basics-Recording-Changes-to-the-Repository] to your fork.
+ **Pull request —**
When you want to contribute your changes to the main gf-core repository,
[create a pull request https://docs.github.com/en/github/collaborating-with-pull-requests/proposing-changes-to-your-work-with-pull-requests/creating-a-pull-request]
from your fork.
- creating a fork of the GF repository on GitHub,
- working with local clone of the fork (obtained with ``git clone``),
- pushing changes to the fork,
- and finally sending a pull request.
If you want to contribute to the RGL as well, do the same process for the RGL repository.
== Compilation from source with Cabal ==
== Compilation from source ==
By now you should have installed Stack and Haskeline, and cloned the Git repository on your own computer, in a directory called ``gf-core``.
=== Primary recommendation: use Stack ===
Open a terminal, go to the top directory (``gf-core``), and type the following command.
```
$ stack install
```
It will install GF and all necessary tools and libraries to do that.
=== Alternative: use Cabal ===
You can also install GF using Cabal, if you prefer Cabal to Stack. In that case, you may need to install some prerequisites yourself.
The actual installation process is similar to Stack: open a terminal, go to the top directory (``gf-core``), and type the following command.
The build system of GF is based on //Cabal//, which is part of the
Haskell Platform, so no extra steps are needed to install it. In the simplest
case, all you need to do to compile and install GF, after downloading the
source code as described above, is
```
$ cabal install
```
//The old (potentially outdated) instructions for Cabal are moved to a [separate page ../doc/gf-developers-old-cabal.html]. If you run into trouble with ``cabal install``, you may want to take a look.//
This will automatically download any additional Haskell libraries needed to
build GF. If this is the first time you use Cabal, you might need to run
``cabal update`` first, to update the list of available libraries.
== Compiling GF with C runtime system support ==
If you want more control, the process can also be split up into the usual
//configure//, //build// and //install// steps.
The C runtime system is a separate implementation of the PGF runtime services.
=== Configure ===
During the configuration phase Cabal will check that you have all
necessary tools and libraries needed for GF. The configuration is
started by the command:
```
$ cabal configure
```
If you don't see any error message from the above command then you
have everything that is needed for GF. You can also add the option
``-v`` to see more details about the configuration.
You can use ``cabal configure --help`` to get a list of configuration options.
=== Build ===
The build phase does two things. First it builds the GF compiler from
the Haskell source code and after that it builds the GF Resource Grammar
Library using the already build compiler. The simplest command is:
```
$ cabal build
```
Again you can add the option ``-v`` if you want to see more details.
==== Parallel builds ====
If you have Cabal>=1.20 you can enable parallel compilation by using
```
$ cabal build -j
```
or by putting a line
```
jobs: $ncpus
```
in your ``.cabal/config`` file. Cabal
will pass this option to GHC when building the GF compiler, if you
have GHC>=7.8.
Cabal also passes ``-j`` to GF to enable parallel compilation of the
Resource Grammar Library. This is done unconditionally to avoid
causing problems for developers with Cabal<1.20. You can disable this
by editing the last few lines in ``WebSetup.hs``.
==== Partial builds ====
**NOTE**: The following doesn't work with recent versions of ``cabal``.
%% // TH 2015-06-22
Sometimes you just want to work on the GF compiler and don't want to
recompile the resource library after each change. In this case use
this extended command:
```
$ cabal build rgl-none
```
The resource library could also be compiled in two modes: with present
tense only and with all tenses. By default it is compiled with all
tenses. If you want to use the library with only present tense you can
compile it in this special mode with the command:
```
$ cabal build present
```
You could also control which languages you want to be recompiled by
adding the option ``langs=list``. For example the following command
will compile only the English and the Swedish language:
```
$ cabal build langs=Eng,Swe
```
=== Install ===
After you have compiled GF you need to install the executable and libraries
to make the system usable.
```
$ cabal copy
$ cabal register
```
This command installs the GF compiler for a single user, in the standard
place used by Cabal.
On Linux and Mac this could be ``$HOME/.cabal/bin``.
On Mac it could also be ``$HOME/Library/Haskell/bin``.
On Windows this is ``C:\Program Files\Haskell\bin``.
The compiled GF Resource Grammar Library will be installed
under the same prefix, e.g. in
``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and
in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows.
If you want to install in some other place then use the ``--prefix``
option during the configuration phase.
=== Clean ===
Sometimes you want to clean up the compilation and start again from clean
sources. Use the clean command for this purpose:
```
$ cabal clean
```
%=== SDist ===
%
%You can use the command:
%
%% This does *NOT* include everything that is needed // TH 2012-08-06
%```
%$ cabal sdist
%```
%
%to prepare archive with all source codes needed to compile GF.
=== Known problems with Cabal ===
Some versions of Cabal (at least version 1.16) seem to have a bug that can
cause the following error:
```
Configuring gf-3.x...
setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed
```
The exact cause of this problem is unclear, but it seems to happen
during the configure phase if the same version of GF is already installed,
so a workaround is to remove the existing installation with
```
ghc-pkg unregister gf
```
You can check with ``ghc-pkg list gf`` that it is gone.
== Compilation with make ==
If you feel more comfortable with Makefiles then there is a thin Makefile
wrapper arround Cabal for you. If you just type:
```
$ make
```
the configuration phase will be run automatically if needed and after that
the sources will be compiled.
%% cabal build rgl-none does not work with recent versions of Cabal
%If you don't want to compile the resource library
%every time then you can use:
%```
%$ make gf
%```
For installation use:
```
$ make install
```
For cleaning:
```
$ make clean
```
%and to build source distribution archive run:
%```
%$ make sdist
%```
== Compiling GF with C run-time system support ==
The C run-time system is a separate implementation of the PGF run-time services.
It makes it possible to work with very large, ambiguous grammars, using
probabilistic models to obtain probable parses. The C runtime system might
also be easier to use than the Haskell runtime system on certain platforms,
probabilistic models to obtain probable parses. The C run-time system might
also be easier to use than the Haskell run-time system on certain platforms,
e.g. Android and iOS.
To install the C runtime system, go to the ``src/runtime/c`` directory.
To install the C run-time system, go to the ``src/runtime/c`` directory
%and follow the instructions in the ``INSTALL`` file.
and use the ``install.sh`` script:
```
bash setup.sh configure
bash setup.sh build
bash setup.sh install
```
This will install
the C header files and libraries need to write C programs that use PGF grammars.
Some example C programs are included in the ``utils`` subdirectory, e.g.
``pgf-translate.c``.
- **On Linux and Mac OS —**
You should have autoconf, automake, libtool and make.
If you are missing some of them, follow the
instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file.
Once you have the required libraries, the easiest way to install the C runtime is to use the ``install.sh`` script. Just type
``$ bash install.sh``
This will install the C header files and libraries need to write C programs
that use PGF grammars.
% If this doesn't work for you, follow the manual instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system.
- **On other operating systems —** Follow the instructions in the
[INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system.
Depending on what you want to do with the C runtime, you can follow one or more of the following steps.
=== Use the C runtime from another programming language ===[bindings]
% **If you just want to use the C runtime from Python, Java, or Haskell, you don't need to change your GF installation.**
- **What —**
This is the most common use case for the C runtime: compile
your GF grammars into PGF with the standard GF executable,
and manipulate the PGFs from another programming language,
using the bindings to the C runtime.
- **How —**
The Python, Java and Haskell bindings are found in the
``src/runtime/{python,java,haskell-bind}`` directories,
respecively. Compile them by following the instructions
in the ``INSTALL`` or ``README`` files in those directories.
The Python library can also be installed from PyPI using ``pip install pgf``.
//If you are on Mac and get an error about ``clang`` version, you can try some of [these solutions https://stackoverflow.com/questions/63972113/big-sur-clang-invalid-version-error-due-to-macosx-deployment-target]—but be careful before removing any existing installations.//
=== Use GF shell with C runtime support ===
- **What —**
If you want to use the GF shell with C runtime functionalities, then you need to (re)compile GF with special flags.
The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
the C run-time system instead of the Haskell run-time system.
Only limited functionality is available when running the shell in these
modes (use the ``help`` command in the shell for details).
(Re)compiling your GF with these flags will also give you
Haskell bindings to the C runtime, as a library called ``PGF2``,
but if you want Python or Java bindings, you need to do [the previous step #bindings].
% ``PGF2``: a module to import in Haskell programs, providing a binding to the C run-time system.
- **How —**
If you use cabal, run the following command:
When the C run-time system is installed, you can install GF with C run-time
support by doing
```
cabal install -fc-runtime
cabal install -fserver -fc-runtime
```
from the top directory. This give you three new things:
from the top directory (``gf-core``).
- ``PGF2``: a module to import in Haskell programs, providing a binding to
the C run-time system.
If you use stack, uncomment the following lines in the ``stack.yaml`` file:
- The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
the C run-time system instead of the Haskell run-time system.
Only limited functionality is available when running the shell in these
modes (use the ``help`` command in the shell for details).
```
flags:
gf:
c-runtime: true
extra-lib-dirs:
- /usr/local/lib
```
and then run ``stack install`` from the top directory (``gf-core``).
- ``gf -server`` mode is extended with new requests to call the C run-time
system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
//If you get an "``error while loading shared libraries``" when trying to run GF with C runtime, remember to declare your ``LD_LIBRARY_PATH``.//
//Add ``export LD_LIBRARY_PATH="/usr/local/lib"`` to either your ``.bashrc`` or ``.profile``. You should now be able to start GF with C runtime.//
=== Use GF server mode with C runtime ===
- **What —**
With this feature, ``gf -server`` mode is extended with new requests to call the C run-time
system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
- **How —**
If you use cabal, run the following command:
```
cabal install -fc-runtime -fserver
```
from the top directory.
If you use stack, add the following lines in the ``stack.yaml`` file:
```
flags:
gf:
c-runtime: true
server: true
extra-lib-dirs:
- /usr/local/lib
```
and then run ``stack install``, also from the top directory.
=== Python and Java bindings ===
The C run-time system can also be used from Python and Java. Python and Java
bindings are found in the ``src/runtime/python`` and ``src/runtime/java``
directories, respecively. Compile them by following the instructions in
the ``INSTALL`` files in those directories.
== Compilation of RGL ==
As of 2018-07-26, the RGL is distributed separately from the GF compiler and runtimes.
To get the source, follow the previous instructions on [how to clone a repository with Git #getting-source].
After cloning the RGL, you should have a directory named ``gf-rgl`` on your computer.
=== Simple ===
To install the RGL, you can use the following commands from within the ``gf-rgl`` repository:
```
@@ -317,68 +416,103 @@ If you do not have Haskell installed, you can use the simple build script ``Setu
== Creating binary distribution packages ==
The binaries are generated with Github Actions. More details can be viewed here:
=== Creating .deb packages for Ubuntu ===
https://github.com/GrammaticalFramework/gf-core/actions/workflows/build-binary-packages.yml
This was tested on Ubuntu 14.04 for the release of GF 3.6, and the
resulting ``.deb`` packages appears to work on Ubuntu 12.04, 13.10 and 14.04.
For the release of GF 3.7, we generated ``.deb`` packages on Ubuntu 15.04 and
tested them on Ubuntu 12.04 and 14.04.
Under Ubuntu, Haskell executables are statically linked against other Haskell
libraries, so the .deb packages are fairly self-contained.
== Running the test suite ==
The GF test suite is run with one of the following commands from the top directory:
==== Preparations ====
```
$ cabal test
sudo apt-get install dpkg-dev debhelper
```
or
==== Creating the package ====
Make sure the ``debian/changelog`` starts with an entry that describes the
version you are building. Then run
```
$ stack test
make deb
```
If get error messages about missing dependencies
(e.g. ``autoconf``, ``automake``, ``libtool-bin``, ``python-dev``,
``java-sdk``, ``txt2tags``)
use ``apt-get intall`` to install them, then try again.
=== Creating OS X Installer packages ===
Run
```
make pkg
```
=== Creating binary tar distributions ===
Run
```
make bintar
```
=== Creating .rpm packages for Fedora ===
This is possible, but the procedure has not been automated.
It involves using the cabal-rpm tool,
```
sudo dnf install cabal-rpm
```
and following the Fedora guide
[How to create an RPM package http://fedoraproject.org/wiki/How_to_create_an_RPM_package].
Under Fedora, Haskell executables are dynamically linked against other Haskell
libraries, so ``.rpm`` packages for all Haskell libraries that GF depends on
are required. Most of them are already available in the Fedora distribution,
but a few of them might have to be built and distributed along with
the GF ``.rpm`` package.
When building ``.rpm`` packages for GF 3.4, we also had to build ``.rpm``s for
``fst`` and ``httpd-shed``.
== Running the testsuite ==
**NOTE:** The test suite has not been maintained recently, so expect many
tests to fail.
%% // TH 2012-08-06
GF has testsuite. It is run with the following command:
```
$ cabal test
```
The testsuite architecture for GF is very simple but still very flexible.
GF by itself is an interpreter and could execute commands in batch mode.
This is everything that we need to organize a testsuite. The root of the
testsuite is the ``testsuite/`` directory. It contains subdirectories
which themselves contain GF batch files (with extension ``.gfs``).
The above command searches the subdirectories of the ``testsuite/`` directory
for files with extension ``.gfs`` and when it finds one, it is executed with
the GF interpreter. The output of the script is stored in file with extension ``.out``
and is compared with the content of the corresponding file with extension ``.gold``, if there is one.
testsuite is the testsuite/ directory. It contains subdirectories which
themself contain GF batch files (with extension .gfs). The above command
searches the subdirectories of the testsuite/ directory for files with extension
.gfs and when it finds one it is executed with the GF interpreter.
The output of the script is stored in file with extension .out and is compared
with the content of the corresponding file with extension .gold, if there is one.
If the contents are identical the command reports that the test was passed successfully.
Otherwise the test had failed.
Every time when you make some changes to GF that have to be tested,
instead of writing the commands by hand in the GF shell, add them to one ``.gfs``
file in the testsuite subdirectory where its ``.gf`` file resides and run the test.
In this way you can use the same test later and we will be sure that we will not
accidentally break your code later.
**Test Outcome - Passed:** If the contents of the files with the ``.out`` extension
are identical to their correspondingly-named files with the extension ``.gold``,
the command will report that the tests passed successfully, e.g.
Every time when you make some changes to GF that have to be tested, instead of
writing the commands by hand in the GF shell, add them to one .gfs file in the testsuite
and run the test. In this way you can use the same test later and we will be sure
that we will not incidentaly break your code later.
If you don't want to run the whole testsuite you can write the path to the subdirectory
in which you are interested. For example:
```
Running 1 test suites...
Test suite gf-tests: RUNNING...
Test suite gf-tests: PASS
1 of 1 test suites (1 of 1 test cases) passed.
$ cabal test testsuite/compiler
```
**Test Outcome - Failed:** If there is a contents mismatch between the files
with the ``.out`` extension and their corresponding files with the extension ``.gold``,
the test diagnostics will show a fail and the areas that failed. e.g.
```
testsuite/compiler/compute/Records.gfs: OK
testsuite/compiler/compute/Variants.gfs: FAIL
testsuite/compiler/params/params.gfs: OK
Test suite gf-tests: FAIL
0 of 1 test suites (0 of 1 test cases) passed.
```
The fail results overview is available in gf-tests.html which shows 4 columns:
+ __Results__ - only areas that fail will appear. (Note: There are 3 failures in the gf-tests.html which are labelled as (expected). These failures should be ignored.)
+ __Input__ - which is the test written in the .gfs file
+ __Gold__ - the expected output from running the test set out in the .gfs file. This column refers to the contents from the .gold extension files.
+ __Output__ - This column refers to the contents from the .out extension files which are generated as test output.
After fixing the areas which fail, rerun the test command. Repeat the entire process of fix-and-test until the test suite passes before submitting a pull request to include your changes.
will run only the testsuite for the compiler.

1
doc/gf-people.md
View File

@@ -32,7 +32,6 @@ The following people have contributed code to some of the versions:
- [Janna Khegai](http://www.cs.chalmers.se/~janna) (Chalmers)
- [Peter Ljunglöf](http://www.cse.chalmers.se/~peb) (University of Gothenburg)
- Petri Mäenpää (Nokia)
- Lauri Alanko (University of Helsinki)
At least the following colleagues are thanked for suggestions, bug
reports, and other indirect contributions to the code.

19
doc/gf-refman.md
View File

@@ -1809,23 +1809,6 @@ As the last rule, subtyping is transitive:
- if *A* is a subtype of *B* and *B* is a subtype of *C*, then *A* is
a subtype of *C*.
### List categories
[]{#lists}
Since categories of lists of elements of another category are a common idiom, the following syntactic sugar is available:
cat [C] {n}
abbreviates a set of three judgements:
cat ListC ;
fun BaseC : C -> ... -> C -> ListC ; --n C’s
fun ConsC : C -> ListC -> ListC
The functions `BaseC` and `ConsC` are automatically generated in the abstract syntax, but their linearizations, as well as the linearization type of `ListC`, must be defined manually. The type expression `[C]` is in all contexts interchangeable with `ListC`.
More information on lists in GF can be found [here](https://inariksit.github.io/gf/2021/02/22/lists.html).
### Tables and table types
@@ -2130,7 +2113,7 @@ of *x*, and the application thereby disappears.
[]{#reuse}
*This section is valid for GF 3.0, which abandons the \"[lock field](https://inariksit.github.io/gf/2018/05/25/subtyping-gf.html#lock-fields)\"*
*This section is valid for GF 3.0, which abandons the \"lock field\"*
*discipline of GF 2.8.*
As explained [here](#openabstract), abstract syntax modules can be

35
doc/gf-video-tutorials.md
View File

@@ -1,35 +0,0 @@
---
title: "Video tutorials"
---
The GF [YouTube channel](https://www.youtube.com/channel/UCZ96DechSUVcXAhtOId9VVA) keeps a playlist of [all GF videos](https://www.youtube.com/playlist?list=PLrgqBB5thLeT15fUtJ8_Dtk8ppdtH90MK), and more specific playlists for narrower topics.
If you make a video about GF, let us know and we'll add it to the suitable playlist(s)!
- [General introduction to GF](#general-introduction-to-gf)
- [Beginner resources](#beginner-resources)
- [Resource grammar tutorials](#resource-grammar-tutorials)
## General introduction to GF
These videos introduce GF at a high level, and present some use cases.
__Grammatical Framework: Formalizing the Grammars of the World__
<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/x1LFbDQhbso" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
__Aarne Ranta: Automatic Translation for Consumers and Producers__
<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/An-AmFScw1o" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
## Beginner resources
These videos show how to install GF on your computer (Mac or Windows), and how to play with simple grammars in a [Jupyter notebook](https://github.com/GrammaticalFramework/gf-binder) (any platform, hosted at [mybinder.org](https://mybinder.org)).
<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/videoseries?list=PLrgqBB5thLeRa8eViJJnjT8jBhxqCPMF2" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
## Resource grammar tutorials
These videos show incremental improvements to a [miniature version of the resource grammar](https://github.com/inariksit/comp-syntax-2020/tree/master/lab2/grammar/dummy#readme).
They assume some prior knowledge of GF, roughly lessons 1-3 from the [GF tutorial](http://www.grammaticalframework.org/doc/tutorial/gf-tutorial.html).
<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/videoseries?list=PLrgqBB5thLeTPkp88lnOmRtprCa8g0wX2" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>

89
doc/tutorial/gf-tutorial.t2t
View File

@@ -898,7 +898,7 @@ Parentheses are only needed for grouping.
Parsing something that is not in grammar will fail:
```
> parse "hello dad"
The parser failed at token 2: "dad"
Unknown words: dad
> parse "world hello"
no tree found
@@ -2475,7 +2475,7 @@ can be used to read a text and return for each word its analyses
```
The command ``morpho_quiz = mq`` generates inflection exercises.
```
% gf alltenses/IrregFre.gfo
% gf -path=alltenses:prelude $GF_LIB_PATH/alltenses/IrregFre.gfo
> morpho_quiz -cat=V
@@ -2488,6 +2488,11 @@ The command ``morpho_quiz = mq`` generates inflection exercises.
réapparaîtriez
Score 0/1
```
To create a list for later use, use the command ``morpho_list = ml``
```
> morpho_list -number=25 -cat=V | write_file exx.txt
```
@@ -2646,12 +2651,12 @@ The verb //switch off// is called a
We can define transitive verbs and their combinations as follows:
```
lincat V2 = {s : Number => Str ; part : Str} ;
lincat TV = {s : Number => Str ; part : Str} ;
fun AppV2 : Item -> V2 -> Item -> Phrase ;
fun AppTV : Item -> TV -> Item -> Phrase ;
lin AppV2 subj v2 obj =
{s = subj.s ++ v2.s ! subj.n ++ obj.s ++ v2.part} ;
lin AppTV subj tv obj =
{s = subj.s ++ tv.s ! subj.n ++ obj.s ++ tv.part} ;
```
**Exercise**. Define the language ``a^n b^n c^n`` in GF, i.e.
@@ -2717,11 +2722,11 @@ This topic will be covered in #Rseclexing.
The symbol ``**`` is used for both record types and record objects.
```
lincat V2 = Verb ** {c : Case} ;
lincat TV = Verb ** {c : Case} ;
lin Follow = regVerb "folgen" ** {c = Dative} ;
```
``V2`` (transitive verb) becomes a **subtype** of ``Verb``.
``TV`` becomes a **subtype** of ``Verb``.
If //T// is a subtype of //R//, an object of //T// can be used whenever
an object of //R// is required.
@@ -2752,11 +2757,7 @@ Thus the labels ``p1, p2,...`` are hard-coded.
English indefinite article:
```
oper artIndef : Str =
pre {
("a" | "e" | "i" | "o") => "an" ;
_ => "a"
} ;
pre {"a" ; "an" / strs {"a" ; "e" ; "i" ; "o"}} ;
```
Thus
```
@@ -2947,7 +2948,7 @@ We need the following combinations:
```
We also need **lexical insertion**, to form phrases from single words:
```
mkCN : N -> CN ;
mkCN : N -> NP ;
mkAP : A -> AP ;
```
Naming convention: to construct a //C//, use a function ``mk``//C//.
@@ -2968,7 +2969,7 @@ can be built as follows:
```
mkCl
(mkNP these_Det
(mkCN (mkAP very_AdA (mkAP warm_A)) (mkCN pizza_N)))
(mkCN (mkAP very_AdA (mkAP warm_A)) (mkCN pizza_CN)))
(mkAP italian_AP)
```
The task now: to define the concrete syntax of ``Foods`` so that
@@ -3717,24 +3718,48 @@ Concrete syntax does not know if a category is a dependent type.
```
Notice that the ``Kind`` argument is suppressed in linearization.
Parsing with dependent types consists of two phases:
Parsing with dependent types is performed in two phases:
+ context-free parsing
+ filtering through type checker
Parsing a type-correct command works as expected:
By just doing the first phase, the ``kind`` argument is not found:
```
> parse "dim the light"
CAction light dim (DKindOne light)
CAction ? dim (DKindOne light)
```
However, type-incorrect commands are rejected by the typecheck:
Moreover, type-incorrect commands are not rejected:
```
> parse "dim the fan"
The parsing is successful but the type checking failed with error(s):
Couldn't match expected type Device light
against the interred type Device fan
In the expression: DKindOne fan
CAction ? dim (DKindOne fan)
```
The term ``?`` is a **metavariable**, returned by the parser
for any subtree that is suppressed by a linearization rule.
These are the same kind of metavariables as were used #Rsecediting
to mark incomplete parts of trees in the syntax editor.
#NEW
===Solving metavariables===
Use the command ``put_tree = pt`` with the option ``-typecheck``:
```
> parse "dim the light" | put_tree -typecheck
CAction light dim (DKindOne light)
```
The ``typecheck`` process may fail, in which case an error message
is shown and no tree is returned:
```
> parse "dim the fan" | put_tree -typecheck
Error in tree UCommand (CAction ? 0 dim (DKindOne fan)) :
(? 0 <> fan) (? 0 <> light)
```
#NEW
@@ -3761,19 +3786,23 @@ to express Haskell-type library functions:
\_,_,_,f,x,y -> f y x ;
```
#NEW
===Dependent types: exercises===
1. Write an abstract syntax module with above contents
and an appropriate English concrete syntax. Try to parse the commands
//dim the light// and //dim the fan//.
//dim the light// and //dim the fan//, with and without ``solve`` filtering.
2. Perform random and exhaustive generation.
2. Perform random and exhaustive generation, with and without
``solve`` filtering.
3. Add some device kinds and actions to the grammar.
#NEW
==Proof objects==
@@ -3883,6 +3912,7 @@ fun
Classes for new actions can be added incrementally.
#NEW
==Variable bindings==
@@ -4170,8 +4200,7 @@ We construct a calculator with addition, subtraction, multiplication, and
division of integers.
```
abstract Calculator = {
flags startcat = Exp ;
cat Exp ;
fun
@@ -4197,7 +4226,7 @@ We begin with a
concrete syntax that always uses parentheses around binary
operator applications:
```
concrete CalculatorP of Calculator = open Prelude in {
concrete CalculatorP of Calculator = {
lincat
Exp = SS ;
@@ -4708,6 +4737,10 @@ abstract Query = {
To make it easy to define a transfer function, we export the
abstract syntax to a system of Haskell datatypes:
```
% gf --output-format=haskell Query.pgf
```
It is also possible to produce the Haskell file together with PGF, by
```
% gf -make --output-format=haskell QueryEng.gf
```

25
download/gfc Normal file
View File

@@ -0,0 +1,25 @@
#!/bin/sh
prefix="/usr/local"
case "i386-apple-darwin9.3.0" in
*-cygwin)
prefix=`cygpath -w "$prefix"`;;
esac
exec_prefix="${prefix}"
GF_BIN_DIR="${exec_prefix}/bin"
GF_DATA_DIR="${prefix}/share/GF-3.0-beta"
GFBIN="$GF_BIN_DIR/gf"
if [ ! -x "${GFBIN}" ]; then
GFBIN=`which gf`
fi
if [ ! -x "${GFBIN}" ]; then
echo "gf not found."
exit 1
fi
exec $GFBIN --batch "$@"

173
download/index-3.11.md
View File

@@ -1,173 +0,0 @@
---
title: Grammatical Framework Download and Installation
...
**GF 3.11** was released on ... December 2020.
What's new? See the [release notes](release-3.11.html).
#### Note: GF core and the RGL
The following instructions explain how to install **GF core**, i.e. the compiler, shell and run-time systems.
Obtaining the **Resource Grammar Library (RGL)** is done separately; see the section at the bottom of this page.
---
## Installing from a binary package
Binary packages are available for Debian/Ubuntu, macOS, and Windows and include:
- GF shell and grammar compiler
- `gf -server` mode
- C run-time system
- Java & Python bindings to the C run-time system
Unlike in previous versions, the binaries **do not** include the RGL.
[Binary packages on GitHub](https://github.com/GrammaticalFramework/gf-core/releases/tag/RELEASE-3.11)
#### Debian/Ubuntu
To install the package use:
```
sudo dpkg -i gf_3.11.deb
```
The Ubuntu `.deb` packages should work on Ubuntu 16.04, 18.04 and similar Linux distributions.
#### macOS
To install the package, just double-click it and follow the installer instructions.
The packages should work on at least 10.13 (High Sierra) and 10.14 (Mojave).
#### Windows
To install the package, unpack it anywhere.
You will probably need to update the `PATH` environment variable to include your chosen install location.
For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
## Installing the latest Hackage release (macOS, Linux, and WSL2 on Windows)
[GF is on Hackage](http://hackage.haskell.org/package/gf), so under
normal circumstances the procedure is fairly simple:
1. Install ghcup https://www.haskell.org/ghcup/
2. `ghcup install ghc 8.10.4`
3. `ghcup set ghc 8.10.4`
4. `cabal update`
5. On Linux: install some C libraries from your Linux distribution (see note below)
6. `cabal install gf-3.11`
You can also download the source code release from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases),
and follow the instructions below under **Installing from the latest developer source code**.
### Notes
**Installation location**
The above steps installs GF for a single user.
The executables are put in `$HOME/.cabal/bin` (or on macOS in `$HOME/Library/Haskell/bin`),
so you might want to add this directory to your path (in `.bash_profile` or similar):
```
PATH=$HOME/.cabal/bin:$PATH
```
**Haskeline**
GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
on Linux depends on some non-Haskell libraries that won't be installed
automatically by cabal, and therefore need to be installed manually.
Here is one way to do this:
- On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
- On Fedora: `sudo dnf install ghc-haskeline-devel`
**GHC version**
The GF source code has been updated to compile with GHC versions 7.10 through to 8.8.
## Installing from the latest developer source code
If you haven't already, clone the repository with:
```
git clone https://github.com/GrammaticalFramework/gf-core.git
```
If you've already cloned the repository previously, update with:
```
git pull
```
Then install with:
```
cabal install
```
or, if you're a Stack user:
```
stack install
```
The above notes for installing from source apply also in these cases.
For more info on working with the GF source code, see the
[GF Developers Guide](../doc/gf-developers.html).
## Installing the Python bindings from PyPI
The Python library is available on PyPI as `pgf`, so it can be installed using:
```
pip install pgf
```
We provide binary wheels for Linux and macOS, which include the C runtime and are ready-to-go.
If there is no binary distribution for your platform, this will install the source tarball,
which will attempt to build the binding during installation,
and requires the GF C runtime to be installed on your system.
---
## Installing the RGL from a binary release
Binary releases of the RGL are made available on [GitHub](https://github.com/GrammaticalFramework/gf-rgl/releases).
In general the steps to follow are:
1. Download a binary release and extract it somewhere on your system.
2. Set the environment variable `GF_LIB_PATH` to point to wherever you extracted the RGL.
## Installing the RGL from source
To compile the RGL, you will need to have GF already installed and in your path.
1. Obtain the RGL source code, either by:
- cloning with `git clone https://github.com/GrammaticalFramework/gf-rgl.git`
- downloading a source archive [here](https://github.com/GrammaticalFramework/gf-rgl/archive/master.zip)
2. Run `make` in the source code folder.
For more options, see the [RGL README](https://github.com/GrammaticalFramework/gf-rgl/blob/master/README.md).
---
## Older releases
- [GF 3.10](index-3.10.html) (December 2018)
- [GF 3.9](index-3.9.html) (August 2017)
- [GF 3.8](index-3.8.html) (June 2016)
- [GF 3.7.1](index-3.7.1.html) (October 2015)
- [GF 3.7](index-3.7.html) (June 2015)
- [GF 3.6](index-3.6.html) (June 2014)
- [GF 3.5](index-3.5.html) (August 2013)
- [GF 3.4](index-3.4.html) (January 2013)
- [GF 3.3.3](index-3.3.3.html) (March 2012)
- [GF 3.3](index-3.3.html) (October 2011)
- [GF 3.2.9](index-3.2.9.html) source-only snapshot (September 2011)
- [GF 3.2](index-3.2.html) (December 2010)
- [GF 3.1.6](index-3.1.6.html) (April 2010)

8
download/index.html
View File

@@ -1,8 +0,0 @@
<html>
<head>
<meta http-equiv="refresh" content="0; URL=/download/index-3.10.html" />
</head>
<body>
You are being redirected to <a href="index-3.10.html">the current version</a> of this page.
</body>
</html>

16
download/index-3.10.md → download/index.md
View File

@@ -114,7 +114,7 @@ automatically by cabal, and therefore need to be installed manually.
Here is one way to do this:
- On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
- On Fedora: `sudo dnf install ghc-haskeline-devel`
- On Fedora: `sudo yum install ghc-haskeline-devel`
**GHC version**
@@ -171,20 +171,6 @@ in the RGL folder.
This assumes that you already have GF installed.
For more details about building the RGL, see the [RGL README](https://github.com/GrammaticalFramework/gf-rgl/blob/master/README.md).
## Installing the Python bindings from PyPI
The Python library is available on PyPI as `pgf`, so it can be installed using:
```
pip install pgf
```
We provide binary wheels for Linux and OSX (with Windows missing so far), which
include the C runtime and a ready-to-go. If there is no binary distribution for
your platform, this will install the source tarball, which will attempt to build
the binding during installation, and requires the GF C runtime to be installed on
your system.
## Older releases
- [GF 3.9](index-3.9.html) (August 2017)

43
download/release-3.11.md
View File

@@ -1,43 +0,0 @@
---
title: GF 3.11 Release Notes
date: ... July 2021
...
## Installation
See the [download page](index-3.11.html).
## What's new
From this release, the binary GF core packages do not contain the RGL.
The RGL's release cycle is now completely separate from GF's. See [RGL releases](https://github.com/GrammaticalFramework/gf-rgl/releases).
Over 500 changes have been pushed to GF core
since the release of GF 3.10 in December 2018.
## General
- Make the test suite work again.
- Compatibility with new versions of GHC, including multiple Stack files for the different versions.
- Support for newer version of Ubuntu 20.04 in the precompiled binaries.
- Updates to build scripts and CI workflows.
- Bug fixes and code cleanup.
## GF compiler and run-time library
- Add CoNLL output to `visualize_tree` shell command.
- Add canonical GF as output format in the compiler.
- Add PGF JSON as output format in the compiler.
- Deprecate JavaScript runtime in favour of updated [TypeScript runtime](https://github.com/GrammaticalFramework/gf-typescript).
- Improvements in time & space requirements when compiling certain grammars.
- Improvements to Haskell export.
- Improvements to the GF shell.
- Improvements to canonical GF compilation.
- Improvements to the C runtime.
- Improvements to `gf -server` mode.
- Clearer compiler error messages.
## Other
- Web page and documentation improvements.
- Add WordNet module to GFSE.

279
gf.cabal
View File

@@ -1,19 +1,19 @@
name: gf
version: 3.11.0-git
version: 3.10.3-git
cabal-version: 1.22
cabal-version: >= 1.22
build-type: Custom
license: OtherLicense
license-file: LICENSE
category: Natural Language Processing, Compiler
synopsis: Grammatical Framework
description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
homepage: https://www.grammaticalframework.org/
homepage: http://www.grammaticalframework.org/
bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
maintainer: Thomas Hallgren
tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
data-dir: src
extra-source-files: WebSetup.hs
data-files:
www/*.html
www/*.css
@@ -41,150 +41,73 @@ data-files:
custom-setup
setup-depends:
base >= 4.9.1 && < 4.15,
Cabal >= 1.22.0.0,
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
process >= 1.0.1.1 && < 1.7
base,
Cabal >=1.22.0.0,
directory,
filepath,
process >=1.0.1.1
--source-repository head
-- type: darcs
-- location: http://www.grammaticalframework.org/
source-repository head
type: git
type: git
location: https://github.com/GrammaticalFramework/gf-core.git
flag interrupt
Description: Enable Ctrl+Break in the shell
Default: True
Default: True
flag server
Description: Include --server mode
Default: True
Default: True
flag network-uri
description: Get Network.URI from the network-uri package
default: True
--flag new-comp
-- Description: Make -new-comp the default
-- Default: True
executable gf
hs-source-dirs: src/programs
main-is: gf-main.hs
default-language: Haskell2010
build-depends: pgf2,
base >= 4.6 && <5,
array,
containers,
bytestring,
utf8-string,
random,
pretty,
mtl,
exceptions,
ghc-prim,
filepath, directory>=1.2, time,
process, haskeline, parallel>=3, json
ghc-options: -threaded
flag c-runtime
Description: Include functionality from the C run-time library (which must be installed already)
Default: False
if impl(ghc>=7.0)
ghc-options: -rtsopts -with-rtsopts=-I5
if impl(ghc<7.8)
ghc-options: -with-rtsopts=-K64M
library
default-language: Haskell2010
build-depends:
-- GHC 8.0.2 to GHC 8.10.4
array >= 0.5.1 && < 0.6,
base >= 4.9.1 && < 4.15,
bytestring >= 0.10.8 && < 0.11,
containers >= 0.5.7 && < 0.7,
exceptions >= 0.8.3 && < 0.11,
ghc-prim >= 0.5.0 && < 0.7,
mtl >= 2.2.1 && < 2.3,
pretty >= 1.1.3 && < 1.2,
random >= 1.1 && < 1.3,
utf8-string >= 1.0.1.1 && < 1.1,
-- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
transformers-compat >= 0.5.1.4 && < 0.7
if impl(ghc<8.0)
build-depends:
fail >= 4.9.0 && < 4.10
hs-source-dirs: src/runtime/haskell
other-modules:
-- not really part of GF but I have changed the original binary library
-- and we have to keep the copy for now.
Data.Binary
Data.Binary.Put
Data.Binary.Get
Data.Binary.Builder
Data.Binary.IEEE754
--ghc-options: -fwarn-unused-imports
--if impl(ghc>=7.8)
-- ghc-options: +RTS -A20M -RTS
ghc-prof-options: -fprof-auto
exposed-modules:
PGF
PGF.Internal
PGF.Haskell
other-modules:
PGF.Data
PGF.Macros
PGF.Binary
PGF.Optimize
PGF.Printer
PGF.CId
PGF.Expr
PGF.Generate
PGF.Linearize
PGF.Morphology
PGF.Paraphrase
PGF.Parse
PGF.Probabilistic
PGF.SortTop
PGF.Tree
PGF.Type
PGF.TypeCheck
PGF.Forest
PGF.TrieMap
PGF.VisualizeTree
PGF.ByteCode
PGF.OldBinary
PGF.Utilities
if flag(c-runtime)
exposed-modules: PGF2
other-modules:
PGF2.FFI
PGF2.Expr
PGF2.Type
GF.Interactive2
GF.Command.Commands2
hs-source-dirs: src/runtime/haskell-bind
build-tools: hsc2hs
extra-libraries: pgf gu
c-sources: src/runtime/haskell-bind/utils.c
cc-options: -std=c99
---- GF compiler as a library:
build-depends:
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
haskeline >= 0.7.3 && < 0.9,
json >= 0.9.1 && < 0.11,
parallel >= 3.2.1.1 && < 3.3,
process >= 1.4.3 && < 1.7,
time >= 1.6.0 && < 1.10
ghc-prof-options: -auto-all
hs-source-dirs: src/compiler
exposed-modules:
other-modules:
GF
GF.Support
GF.Text.Pretty
GF.Text.Lexing
GF.Grammar.Canonical
other-modules:
GF.Main
GF.Compiler
GF.Interactive
GF.Main GF.Compiler GF.Interactive
GF.Compile
GF.CompileInParallel
GF.CompileOne
GF.Compile.GetGrammar
GF.Compile GF.CompileInParallel GF.CompileOne GF.Compile.GetGrammar
GF.Grammar
GF.Data.Operations
GF.Infra.Option
GF.Infra.UseIO
GF.Data.Operations GF.Infra.Option GF.Infra.UseIO
GF.Command.Abstract
GF.Command.CommandInfo
@@ -199,7 +122,8 @@ library
GF.Command.TreeOperations
GF.Compile.CFGtoPGF
GF.Compile.CheckGrammar
GF.Compile.Compute.Concrete
GF.Compile.Compute.AppPredefined
GF.Compile.Compute.ConcreteNew
GF.Compile.Compute.Predef
GF.Compile.Compute.Value
GF.Compile.ExampleBased
@@ -209,16 +133,14 @@ library
GF.Compile.GrammarToPGF
GF.Compile.Multi
GF.Compile.Optimize
GF.Compile.OptimizePGF
GF.Compile.PGFtoHaskell
GF.Compile.PGFtoJava
GF.Haskell
GF.Compile.ConcreteToHaskell
GF.Compile.GrammarToCanonical
GF.Grammar.CanonicalJSON
GF.Compile.PGFtoJS
GF.Compile.PGFtoJSON
GF.Compile.PGFtoProlog
GF.Compile.PGFtoPython
GF.Compile.ReadFiles
GF.Compile.Rename
GF.Compile.SubExOpt
@@ -228,6 +150,7 @@ library
GF.Compile.TypeCheck.Concrete
GF.Compile.TypeCheck.ConcreteNew
GF.Compile.TypeCheck.Primitives
GF.Compile.TypeCheck.RConcrete
GF.Compile.TypeCheck.TC
GF.Compile.Update
GF.Data.BacktrackM
@@ -287,24 +210,25 @@ library
GF.System.Signal
GF.Text.Clitics
GF.Text.Coding
GF.Text.Lexing
GF.Text.Transliterations
Paths_gf
if flag(c-runtime)
cpp-options: -DC_RUNTIME
-- not really part of GF but I have changed the original binary library
-- and we have to keep the copy for now.
Data.Binary
Data.Binary.Put
Data.Binary.Get
Data.Binary.Builder
Data.Binary.IEEE754
if flag(server)
build-depends:
cgi >= 3001.3.0.2 && < 3001.6,
httpd-shed >= 0.4.0 && < 0.5,
network>=2.3 && <2.7
build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7,
cgi>=3001.2.2.0
if flag(network-uri)
build-depends:
network-uri >= 2.6.1.0 && < 2.7,
network>=2.6 && <2.7
build-depends: network-uri>=2.6, network>=2.6
else
build-depends:
network >= 2.5 && <2.6
build-depends: network<2.6
cpp-options: -DSERVER_MODE
other-modules:
@@ -319,12 +243,7 @@ library
CGIUtils
Cache
Fold
ExampleDemo
ExampleService
hs-source-dirs:
src/server
src/server/transfer
src/example-based
hs-source-dirs: src/server src/server/transfer src/example-based
if flag(interrupt)
cpp-options: -DUSE_INTERRUPT
@@ -333,72 +252,28 @@ library
other-modules: GF.System.NoSignal
if impl(ghc>=7.8)
build-tools:
happy>=1.19,
alex>=3.1
-- ghc-options: +RTS -A20M -RTS
build-tools: happy>=1.19, alex>=3.1
else
build-tools:
happy,
alex>=3
build-tools: happy, alex>=3
ghc-options: -fno-warn-tabs
if os(windows)
build-depends:
Win32 >= 2.3.1.1 && < 2.7
build-depends: Win32
else
build-depends:
terminfo >=0.4.0 && < 0.5,
unix >= 2.7.2 && < 2.8
build-depends: unix, terminfo>=0.4
if impl(ghc>=8.2)
ghc-options: -fhide-source-paths
executable gf
hs-source-dirs: src/programs
main-is: gf-main.hs
default-language: Haskell2010
build-depends:
gf,
base
ghc-options: -threaded
--ghc-options: -fwarn-unused-imports
if impl(ghc>=7.0)
ghc-options: -rtsopts -with-rtsopts=-I5
if impl(ghc<7.8)
ghc-options: -with-rtsopts=-K64M
ghc-prof-options: -auto-all
if impl(ghc>=8.2)
ghc-options: -fhide-source-paths
-- executable pgf-shell
-- --if !flag(c-runtime)
-- buildable: False
-- main-is: pgf-shell.hs
-- hs-source-dirs: src/runtime/haskell-bind/examples
-- build-depends:
-- gf,
-- base,
-- containers,
-- mtl,
-- lifted-base
-- default-language: Haskell2010
-- if impl(ghc>=7.0)
-- ghc-options: -rtsopts
test-suite rgl-tests
type: exitcode-stdio-1.0
main-is: run.hs
hs-source-dirs: lib/tests/
build-depends: base, HTF, process, HUnit, filepath, directory
default-language: Haskell2010
test-suite gf-tests
type: exitcode-stdio-1.0
main-is: run.hs
type: exitcode-stdio-1.0
main-is: run.hs
hs-source-dirs: testsuite
build-depends:
base >= 4.9.1 && < 4.15,
Cabal >= 1.8,
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
process >= 1.4.3 && < 1.7
build-tool-depends: gf:gf
default-language: Haskell2010
build-depends: base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
default-language: Haskell2010

50
index.html
View File

@@ -22,9 +22,9 @@
<h4 class="text-black-50">A programming language for multilingual grammar applications</h4>
</div>
<div class="row mt-4">
<div class="row my-4">
<div class="col-sm-6 col-md-3 mb-4">
<div class="col-sm-6 col-md-3">
<h3>Get started</h3>
<ul class="mb-2">
<li><a href="https://www.youtube.com/watch?v=x1LFbDQhbso">Google Tech Talk</a></li>
@@ -39,7 +39,6 @@
/
<a href="lib/doc/rgl-tutorial/index.html">RGL Tutorial</a>
</li>
<li><a href="doc/gf-video-tutorials.html">Video Tutorials</a></li>
</ul>
<a href="download/index.html" class="btn btn-primary ml-3">
@@ -48,7 +47,7 @@
</a>
</div>
<div class="col-sm-6 col-md-3 mb-4">
<div class="col-sm-6 col-md-3">
<h3>Learn more</h3>
<ul class="mb-2">
@@ -56,7 +55,6 @@
<li><a href="doc/gf-refman.html">Reference Manual</a></li>
<li><a href="doc/gf-shell-reference.html">Shell Reference</a></li>
<li><a href="http://www.molto-project.eu/sites/default/files/MOLTO_D2.3.pdf">Best Practices</a> <small>[PDF]</small></li>
<li><a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Scaling Up (Computational Linguistics 2020)</a></li>
</ul>
<a href="lib/doc/synopsis/index.html" class="btn btn-primary ml-3">
@@ -65,30 +63,27 @@
</a>
</div>
<div class="col-sm-6 col-md-3 mb-4">
<div class="col-sm-6 col-md-3">
<h3>Develop</h3>
<ul class="mb-2">
<li><a href="doc/gf-developers.html">Developers Guide</a></li>
<!-- <li><a href="/~hallgren/gf-experiment/browse/">Browse Source Code</a></li> -->
<li>PGF library API:<br>
<a href="http://hackage.haskell.org/package/gf/docs/PGF.html">Haskell</a> /
<a href="doc/runtime-api.html">C&nbsp;runtime</a>
</li>
<li><a href="http://hackage.haskell.org/package/gf/docs/PGF.html">PGF library API (Haskell runtime)</a></li>
<li><a href="doc/runtime-api.html">PGF library API (C runtime)</a></li>
<li><a href="http://hackage.haskell.org/package/gf/docs/GF.html">GF compiler API</a></li>
<!-- <li><a href="src/ui/android/README">GF on Android (new)</a></li>
<li><a href="/android/">GF on Android (old) </a></li> -->
<li><a href="doc/gf-editor-modes.html">Text Editor Support</a></li>
<li><a href="http://www.grammaticalframework.org/~john/rgl-browser/">RGL source browser</a></li>
</ul>
</div>
<div class="col-sm-6 col-md-3 mb-4">
<div class="col-sm-6 col-md-3">
<h3>Contribute</h3>
<ul class="mb-2">
<li><a href="http://groups.google.com/group/gf-dev">Mailing List</a></li>
<li><a href="https://github.com/GrammaticalFramework/gf-core/issues">Issue Tracker</a></li>
<li><a href="doc/gf-people.html">Authors</a></li>
<li><a href="//school.grammaticalframework.org/2020/">Summer School</a></li>
<li><a href="//school.grammaticalframework.org/2018/">Summer School</a></li>
</ul>
<a href="https://github.com/GrammaticalFramework/" class="btn btn-primary ml-3">
<i class="fab fa-github mr-1"></i>
@@ -174,7 +169,6 @@ least one, it may help you to get a first idea of what GF is.
<li>macOS</li>
<li>Windows</li>
<li>Android mobile platform (via Java; runtime)</li>
<li>iOS mobile platform (iPhone, iPad)</li>
<li>via compilation to JavaScript, almost any platform that has a web browser (runtime)</li>
</ul>
@@ -214,9 +208,9 @@ least one, it may help you to get a first idea of what GF is.
</p>
<p>
We run the IRC channel <strong><code>#gf</code></strong> on the Libera network, where you are welcome to look for help with small questions or just start a general discussion.
You can <a href="https://web.libera.chat/?channels=#gf">open a web chat</a>
or <a href="https://www.grammaticalframework.org/irc/?C=M;O=D">browse the channel logs</a>.
We run the IRC channel <strong><code>#gf</code></strong> on the Freenode network, where you are welcome to look for help with small questions or just start a general discussion.
You can <a href="https://webchat.freenode.net/?channels=gf">open a web chat</a>
or <a href="/irc/">browse the channel logs</a>.
</p>
<p>
If you have a larger question which the community may benefit from, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
@@ -228,18 +222,6 @@ least one, it may help you to get a first idea of what GF is.
<h2>News</h2>
<dl class="row">
<dt class="col-sm-3 text-center text-nowrap">2021-05-05</dt>
<dd class="col-sm-9">
<a href="https://cloud.grammaticalframework.org/wordnet/">GF WordNet</a> now supports languages for which there are no other WordNets. New additions: Afrikaans, German, Korean, Maltese, Polish, Somali, Swahili.
</dd>
<dt class="col-sm-3 text-center text-nowrap">2021-03-01</dt>
<dd class="col-sm-9">
<a href="//school.grammaticalframework.org/2020/">Seventh GF Summer School</a>, in Singapore and online, 26 July &ndash; 8 August 2021.
</dd>
<dt class="col-sm-3 text-center text-nowrap">2020-09-29</dt>
<dd class="col-sm-9">
<a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Abstract Syntax as Interlingua</a>: Scaling Up the Grammatical Framework from Controlled Languages to Robust Pipelines. A paper in Computational Linguistics (2020) summarizing much of the development in GF in the past ten years.
</dd>
<dt class="col-sm-3 text-center text-nowrap">2018-12-03</dt>
<dd class="col-sm-9">
<a href="//school.grammaticalframework.org/2018/">Sixth GF Summer School</a> in Stellenbosch (South Africa), 3–14 December 2018
@@ -342,11 +324,9 @@ least one, it may help you to get a first idea of what GF is.
Afrikaans,
Amharic (partial),
Arabic (partial),
Basque (partial),
Bulgarian,
Catalan,
Chinese,
Czech (partial),
Danish,
Dutch,
English,
@@ -358,12 +338,10 @@ least one, it may help you to get a first idea of what GF is.
Greek modern,
Hebrew (fragments),
Hindi,
Hungarian (partial),
Interlingua,
Italian,
Japanese,
Korean (partial),
Latin (partial),
Italian,
Latin (fragments),
Latvian,
Maltese,
Mongolian,
@@ -376,9 +354,7 @@ least one, it may help you to get a first idea of what GF is.
Romanian,
Russian,
Sindhi,
Slovak (partial),
Slovene (partial),
Somali (partial),
Spanish,
Swahili (fragments),
Swedish,

0
src/runtime/haskell/Data/Binary.hs → src/compiler/Data/Binary.hs
View File

4
src/runtime/haskell/Data/Binary/Builder.hs → src/compiler/Data/Binary/Builder.hs
View File

@@ -68,7 +68,7 @@ import qualified Data.ByteString.Lazy as L
import Data.ByteString.Base (inlinePerformIO)
import qualified Data.ByteString.Base as S
#else
import Data.ByteString.Internal (accursedUnutterablePerformIO)
import Data.ByteString.Internal (inlinePerformIO)
import qualified Data.ByteString.Internal as S
--import qualified Data.ByteString.Lazy.Internal as L
#endif
@@ -199,7 +199,7 @@ defaultSize = 32 * k - overhead
-- | Sequence an IO operation on the buffer
unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO f = Builder $ \ k buf -> accursedUnutterablePerformIO $ do
unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do
buf' <- f buf
return (k buf')
{-# INLINE unsafeLiftIO #-}

11
src/runtime/haskell/Data/Binary/Get.hs → src/compiler/Data/Binary/Get.hs
View File

@@ -101,10 +101,6 @@ import GHC.Word
--import GHC.Int
#endif
-- Control.Monad.Fail import will become redundant in GHC 8.8+
import qualified Control.Monad.Fail as Fail
-- | The parse state
data S = S {-# UNPACK #-} !B.ByteString -- current chunk
L.ByteString -- the rest of the input
@@ -130,11 +126,6 @@ instance Monad Get where
(a, s') -> unGet (k a) s')
{-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
fail = failDesc
#endif
instance Fail.MonadFail Get where
fail = failDesc
instance MonadFix Get where
@@ -423,7 +414,7 @@ readN n f = fmap f $ getBytes n
getPtr :: Storable a => Int -> Get a
getPtr n = do
(fp,o,_) <- readN n B.toForeignPtr
return . B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
{- INLINE getPtr -}
------------------------------------------------------------------------

0
src/runtime/haskell/Data/Binary/IEEE754.lhs → src/compiler/Data/Binary/IEEE754.lhs
View File

0
src/runtime/haskell/Data/Binary/Put.hs → src/compiler/Data/Binary/Put.hs
View File

24
src/compiler/GF/Command/Abstract.hs
View File

@@ -1,6 +1,6 @@
module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where
import PGF(CId,mkCId,Expr,showExpr)
import PGF2(Expr,showExpr)
import GF.Grammar.Grammar(Term)
type Ident = String
@@ -11,7 +11,7 @@ type Pipe = [Command]
data Command
= Command Ident [Option] Argument
deriving (Eq,Ord,Show)
deriving Show
data Option
= OOpt Ident
@@ -29,13 +29,7 @@ data Argument
| ATerm Term
| ANoArg
| AMacro Ident
deriving (Eq,Ord,Show)
valCIdOpts :: String -> CId -> [Option] -> CId
valCIdOpts flag def opts =
case [v | OFlag f (VId v) <- opts, f == flag] of
(v:_) -> mkCId v
_ -> def
deriving Show
valIntOpts :: String -> Int -> [Option] -> Int
valIntOpts flag def opts =
@@ -49,6 +43,18 @@ valStrOpts flag def opts =
v:_ -> valueString v
_ -> def
maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
maybeIntOpts flag def fn opts =
case [v | OFlag f (VInt v) <- opts, f == flag] of
(v:_) -> fn v
_ -> def
maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
maybeStrOpts flag def fn opts =
case listFlags flag opts of
v:_ -> fn (valueString v)
_ -> def
listFlags flag opts = [v | OFlag f v <- opts, f == flag]
valueString v =

27
src/compiler/GF/Command/CommandInfo.hs
View File

@@ -3,8 +3,7 @@ import GF.Command.Abstract(Option,Expr,Term)
import GF.Text.Pretty(render)
import GF.Grammar.Printer() -- instance Pretty Term
import GF.Grammar.Macros(string2term)
import qualified PGF as H(showExpr)
import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ----
import PGF2(mkStr,unStr,showExpr)
data CommandInfo m = CommandInfo {
exec :: [Option] -> CommandArguments -> m CommandOutput,
@@ -38,21 +37,19 @@ class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
--------------------------------------------------------------------------------
data CommandArguments = Exprs [Expr] | Strings [String] | Term Term
data CommandArguments = Exprs [(Expr,Float)] | Strings [String] | Term Term
newtype CommandOutput = Piped (CommandArguments,String) ---- errors, etc
-- ** Converting command output
fromStrings ss = Piped (Strings ss, unlines ss)
fromExprs es = Piped (Exprs es,unlines (map (H.showExpr []) es))
fromExprs show_p es = Piped (Exprs es,unlines (map (\(e,p) -> (if show_p then (++) ("["++show p++"] ") else id) (showExpr [] e)) es))
fromString s = Piped (Strings [s], s)
pipeWithMessage es msg = Piped (Exprs es,msg)
pipeMessage msg = Piped (Exprs [],msg)
pipeExprs es = Piped (Exprs es,[]) -- only used in emptyCommandInfo
void = Piped (Exprs [],"")
stringAsExpr = H.ELit . H.LStr -- should be a pattern macro
-- ** Converting command input
toStrings args =
@@ -61,23 +58,23 @@ toStrings args =
Exprs es -> zipWith showAsString (True:repeat False) es
Term t -> [render t]
where
showAsString first t =
case t of
H.ELit (H.LStr s) -> s
_ -> ['\n'|not first] ++
H.showExpr [] t ---newline needed in other cases than the first
showAsString first (e,p) =
case unStr e of
Just s -> s
Nothing -> ['\n'|not first] ++
showExpr [] e ---newline needed in other cases than the first
toExprs args =
case args of
Exprs es -> es
Strings ss -> map stringAsExpr ss
Term t -> [stringAsExpr (render t)]
Exprs es -> map fst es
Strings ss -> map mkStr ss
Term t -> [mkStr (render t)]
toTerm args =
case args of
Term t -> t
Strings ss -> string2term $ unwords ss -- hmm
Exprs es -> string2term $ unwords $ map (H.showExpr []) es -- hmm
Exprs es -> string2term $ unwords $ map (showExpr [] . fst) es -- hmm
-- ** Creating documentation

587
src/compiler/GF/Command/Commands.hs
View File

@@ -1,16 +1,12 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands (
PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
HasPGF(..),pgfCommands,
options,flags,
) where
import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import Prelude hiding (putStrLn)
import PGF
import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
import PGF.Internal(ppFun,ppCat)
import PGF.Internal(optimizePGF)
import PGF2
import PGF2.Internal(writePGF)
import GF.Compile.Export
import GF.Compile.ToAPI
@@ -28,28 +24,25 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
import GF.Data.Operations
import PGF.Internal (encodeFile)
import Data.Char
import Data.List(intersperse,nub)
import Data.Maybe
import qualified Data.Map as Map
import GF.Text.Pretty
import Data.List (sort)
import qualified Control.Monad.Fail as Fail
--import Debug.Trace
import Control.Monad(mplus)
class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
instance (Monad m,HasPGF m) => TypeCheckArg m where
typeCheckArg e = do mb_pgf <- getPGF
case mb_pgf of
Just pgf -> either fail
(return . fst)
(inferExpr pgf e)
Nothing -> fail "Import a grammar before using this command"
pgfEnv pgf = Env pgf mos
where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
instance (Monad m,HasPGFEnv m,Fail.MonadFail m) => TypeCheckArg m where
typeCheckArg e = (either (fail . render . ppTcError) (return . fst)
. flip inferExpr e . pgf) =<< getPGFEnv
pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
pgfCommands :: HasPGF m => Map.Map String (CommandInfo m)
pgfCommands = Map.fromList [
("aw", emptyCommandInfo {
longname = "align_words",
@@ -62,7 +55,7 @@ pgfCommands = Map.fromList [
"by the view flag. The target format is png, unless overridden by the",
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
exec = needPGF $ \ opts arg pgf -> do
let es = toExprs arg
let langs = optLangs pgf opts
if isOpt "giza" opts
@@ -74,7 +67,7 @@ pgfCommands = Map.fromList [
let grph = if null es then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
return $ fromString grph
else do
let grphs = map (graphvizAlignment pgf langs) es
let grphs = map (graphvizWordAlignment langs graphvizDefaults) es
if isFlag "view" opts || isFlag "format" opts
then do
let view = optViewGraph opts
@@ -96,6 +89,7 @@ pgfCommands = Map.fromList [
("view", "program to open the resulting file")
]
}),
("ca", emptyCommandInfo {
longname = "clitic_analyse",
synopsis = "print the analyses of all words into stems and clitics",
@@ -106,16 +100,17 @@ pgfCommands = Map.fromList [
"by the flag '-clitics'. The list of stems is given as the list of words",
"of the language given by the '-lang' flag."
],
exec = getEnv $ \opts ts env -> case opts of
_ | isOpt "raw" opts ->
return . fromString .
unlines . map (unwords . map (concat . intersperse "+")) .
map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) .
concatMap words $ toStrings ts
_ ->
return . fromStrings .
getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) .
concatMap words $ toStrings ts,
exec = needPGF $ \opts ts pgf -> do
concr <- optLang pgf opts
case opts of
_ | isOpt "raw" opts ->
return . fromString .
unlines . map (unwords . map (concat . intersperse "+")) .
map (getClitics (not . null . lookupMorpho concr) (optClitics opts)) .
concatMap words $ toStrings ts
_ -> return . fromStrings .
getCliticsText (not . null . lookupMorpho concr) (optClitics opts) .
concatMap words $ toStrings ts,
flags = [
("clitics","the list of possible clitics (comma-separated, no spaces)"),
("lang", "the language of analysis")
@@ -147,19 +142,19 @@ pgfCommands = Map.fromList [
],
flags = [
("file","the file to be converted (suffix .gfe must be given)"),
("lang","the language in which to parse"),
("probs","file with probabilities to rank the parses")
("lang","the language in which to parse")
],
exec = getEnv $ \ opts _ env@(Env pgf mos) -> do
exec = needPGF $ \opts _ pgf -> do
let file = optFile opts
pgf <- optProbs opts pgf
let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
concr <- optLang pgf opts
let conf = configureExBased pgf concr printer
(file',ws) <- restricted $ parseExamplesInGrammar conf file
if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
return (fromString ("wrote " ++ file')),
needsTypeCheck = False
}),
("gr", emptyCommandInfo {
longname = "generate_random",
synopsis = "generate random trees in the current abstract syntax",
@@ -174,54 +169,53 @@ pgfCommands = Map.fromList [
explanation = unlines [
"Generates a list of random trees, by default one tree.",
"If a tree argument is given, the command completes the Tree with values to",
"all metavariables in the tree. The generation can be biased by probabilities,",
"given in a file in the -probs flag."
"all metavariables in the tree. The generation can be biased by probabilities",
"if the grammar was compiled with option -probs"
],
options = [
("show_probs", "show the probability of each result")
],
flags = [
("cat","generation category"),
("lang","uses only functions that have linearizations in all these languages"),
("number","number of trees generated"),
("depth","the maximum generation depth"),
("probs", "file with biased probabilities (format 'f 0.4' one by line)")
("number","number of trees generated")
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
pgf <- optProbs opts (optRestricted opts pgf)
exec = needPGF $ \opts arg pgf -> do
gen <- newStdGen
let dp = valIntOpts "depth" 4 opts
let ts = case mexp (toExprs arg) of
Just ex -> generateRandomFromDepth gen pgf ex (Just dp)
Nothing -> generateRandomDepth gen pgf (optType pgf opts) (Just dp)
returnFromExprs $ take (optNum opts) ts
Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom gen pgf (optType pgf opts)
returnFromExprs (isOpt "show_probs" opts) $ take (optNum opts) ts
}),
("gt", emptyCommandInfo {
longname = "generate_trees",
synopsis = "generates a list of trees, by default exhaustive",
explanation = unlines [
"Generates all trees of a given category. By default, ",
"the depth is limited to 4, but this can be changed by a flag.",
"Generates all trees of a given category.",
"If a Tree argument is given, the command completes the Tree with values",
"to all metavariables in the tree."
],
options = [
("show_probs", "show the probability of each result")
],
flags = [
("cat","the generation category"),
("depth","the maximum generation depth"),
("lang","excludes functions that have no linearization in this language"),
("number","the number of trees generated")
],
examples = [
mkEx "gt -- all trees in the startcat, to depth 4",
mkEx "gt -- all trees in the startcat",
mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP",
mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2",
mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))"
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let pgfr = optRestricted opts pgf
let dp = valIntOpts "depth" 4 opts
let ts = case mexp (toExprs arg) of
Just ex -> generateFromDepth pgfr ex (Just dp)
Nothing -> generateAllDepth pgfr (optType pgf opts) (Just dp)
returnFromExprs $ take (optNumInf opts) ts
exec = needPGF $ \opts arg pgf -> do
let es = case mexp (toExprs arg) of
Just ex -> generateAllFrom pgf ex
Nothing -> generateAll pgf (optType pgf opts)
returnFromExprs (isOpt "show_probs" opts) $ takeOptNum opts es
}),
("i", emptyCommandInfo {
longname = "import",
synopsis = "import a grammar from source code or compiled .pgf file",
@@ -242,33 +236,28 @@ pgfCommands = Map.fromList [
("probs","file with biased probabilities for generation")
],
options = [
-- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
("retain","retain operations (used for cc command)"),
("src", "force compilation from source"),
("v", "be verbose - show intermediate status information")
],
needsTypeCheck = False
}),
("l", emptyCommandInfo {
longname = "linearize",
synopsis = "convert an abstract syntax expression to string",
explanation = unlines [
"Shows the linearization of a Tree by the grammars in scope.",
"Shows the linearization of a tree by the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"A sequence of string operations (see command ps) can be given",
"as options, and works then like a pipe to the ps command, except",
"that it only affect the strings, not e.g. the table labels.",
"These can be given separately to each language with the unlexer flag",
"whose results are prepended to the other lexer flags. The value of the",
"unlexer flag is a space-separated list of comma-separated string operation",
"sequences; see example."
"that it only affect the strings, not e.g. the table labels."
],
examples = [
mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor",
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table"
],
exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings . optLins pgf opts $ toExprs ts,
exec = needPGF $ \ opts ts pgf -> return . fromStrings . optLins pgf opts $ toExprs ts,
options = [
("all", "show all forms and variants, one by line (cf. l -list)"),
("bracket","show tree structure with brackets and paths to nodes"),
@@ -276,33 +265,13 @@ pgfCommands = Map.fromList [
("list","show all forms and variants, comma-separated on one line (cf. l -all)"),
("multi","linearize to all languages (default)"),
("table","show all forms labelled by parameters"),
("tabtreebank","show the tree and its linearizations on a tab-separated line"),
("treebank","show the tree and tag linearizations with language names")
] ++ stringOpOptions,
flags = [
("lang","the languages of linearization (comma-separated, no spaces)"),
("unlexer","set unlexers separately to each language (space-separated)")
]
}),
("lc", emptyCommandInfo {
longname = "linearize_chunks",
synopsis = "linearize a tree that has metavariables in maximal chunks without them",
explanation = unlines [
"A hopefully temporary command, intended to work around the type checker that fails",
"trees where a function node is a metavariable."
],
examples = [
mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)"
],
exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf (opts ++ [OOpt "chunks"]) (toExprs ts),
options = [
("treebank","show the tree and tag linearizations with language names")
] ++ stringOpOptions,
flags = [
("lang","the languages of linearization (comma-separated, no spaces)")
],
needsTypeCheck = False
]
}),
("ma", emptyCommandInfo {
longname = "morpho_analyse",
synopsis = "print the morphological analyses of all words in the string",
@@ -310,18 +279,20 @@ pgfCommands = Map.fromList [
"Prints all the analyses of space-separated words in the input string,",
"using the morphological analyser of the actual grammar (see command pg)"
],
exec = getEnv $ \opts ts env -> case opts of
_ | isOpt "missing" opts ->
return . fromString . unwords .
morphoMissing (optMorpho env opts) .
concatMap words $ toStrings ts
_ | isOpt "known" opts ->
return . fromString . unwords .
morphoKnown (optMorpho env opts) .
concatMap words $ toStrings ts
_ -> return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos env opts) .
concatMap words $ toStrings ts,
exec = needPGF $ \opts ts pgf -> do
concr <- optLang pgf opts
case opts of
_ | isOpt "missing" opts ->
return . fromString . unwords .
morphoMissing concr .
concatMap words $ toStrings ts
_ | isOpt "known" opts ->
return . fromString . unwords .
morphoKnown concr .
concatMap words $ toStrings ts
_ -> return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos pgf opts) .
concatMap words $ toStrings ts,
flags = [
("lang","the languages of analysis (comma-separated, no spaces)")
],
@@ -335,18 +306,16 @@ pgfCommands = Map.fromList [
longname = "morpho_quiz",
synopsis = "start a morphology quiz",
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let lang = optLang pgf opts
exec = needPGF $ \ opts arg pgf -> do
lang <- optLang pgf opts
let typ = optType pgf opts
pgf <- optProbs opts pgf
let mt = mexp (toExprs arg)
restricted $ morphologyQuiz mt pgf lang typ
return void,
flags = [
("lang","language of the quiz"),
("cat","category of the quiz"),
("number","maximum number of questions"),
("probs","file with biased probabilities for generation")
("number","maximum number of questions")
]
}),
@@ -357,24 +326,25 @@ pgfCommands = Map.fromList [
"Shows all trees returned by parsing a string in the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"The default start category can be overridden by the -cat flag.",
"See also the ps command for lexing and character encoding.",
"",
"The -openclass flag is experimental and allows some robustness in ",
"the parser. For example if -openclass=\"A,N,V\" is given, the parser",
"will accept unknown adjectives, nouns and verbs with the resource grammar."
"See also the ps command for lexing and character encoding."
],
exec = needPGF $ \opts ts pgf ->
return $
foldr (joinPiped . fromParse1 opts) void
(concat [
[(s,parse concr (optType pgf opts) s) |
concr <- optLangs pgf opts]
| s <- toStrings ts]),
options = [
("show_probs", "show the probability of each result")
],
exec = getEnv $ \ opts ts (Env pgf mos) ->
return $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
flags = [
("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)"),
("openclass","list of open-class categories for robust parsing"),
("depth","maximal depth for proof search if the abstract syntax tree has meta variables")
],
options = [
("bracket","prints the bracketed string from the parser")
("number","limit the results to the top N trees")
]
}),
("pg", emptyCommandInfo { -----
longname = "print_grammar",
synopsis = "print the actual grammar with the given printer",
@@ -394,9 +364,8 @@ pgfCommands = Map.fromList [
" " ++ opt ++ "\t\t" ++ expl |
((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
]),
exec = getEnv $ \opts _ env -> prGrammar env opts,
exec = needPGF $ \opts _ pgf -> prGrammar pgf opts,
flags = [
--"cat",
("file", "set the file name when printing with -pgf option"),
("lang", "select languages for the some options (default all languages)"),
("printer","select the printing format (see flag values above)")
@@ -416,6 +385,7 @@ pgfCommands = Map.fromList [
mkEx ("pg -funs | ? grep \" S ;\" -- show functions with value cat S")
]
}),
("pt", emptyCommandInfo {
longname = "put_tree",
syntax = "pt OPT? TREE",
@@ -429,11 +399,12 @@ pgfCommands = Map.fromList [
examples = [
mkEx "pt -compute (plus one two) -- compute value"
],
exec = getEnv $ \ opts arg (Env pgf mos) ->
returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
exec = needPGF $ \opts arg pgf ->
returnFromExprs False . takeOptNum opts . map (flip (,) 0) . treeOps pgf opts $ toExprs arg,
options = treeOpOptions undefined{-pgf-},
flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
}),
("rf", emptyCommandInfo {
longname = "read_file",
synopsis = "read string or tree input from a file",
@@ -446,10 +417,9 @@ pgfCommands = Map.fromList [
],
options = [
("lines","return the list of lines, instead of the singleton of all contents"),
("paragraphs","return the list of paragraphs, as separated by empty lines"),
("tree","convert strings into trees")
],
exec = getEnv $ \ opts _ (Env pgf mos) -> do
exec = needPGF $ \ opts _ pgf -> do
let file = valStrOpts "file" "_gftmp" opts
let exprs [] = ([],empty)
exprs ((n,s):ls) | null s
@@ -458,12 +428,12 @@ pgfCommands = Map.fromList [
Just e -> let (es,err) = exprs ls
in case inferExpr pgf e of
Right (e,t) -> (e:es,err)
Left tcerr -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err)
Left err -> (es,"on line" <+> n <> ':' $$ nest 2 err $$ err)
Nothing -> let (es,err) = exprs ls
in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
returnFromLines ls = case exprs ls of
(es, err) | null es -> return $ pipeMessage $ render (err $$ "no trees found")
| otherwise -> return $ pipeWithMessage es (render err)
| otherwise -> return $ pipeWithMessage (map (flip (,) 0) es) (render err)
s <- restricted $ readFile file
case opts of
@@ -472,56 +442,26 @@ pgfCommands = Map.fromList [
_ | isOpt "tree" opts ->
returnFromLines [(1::Int,s)]
_ | isOpt "lines" opts -> return (fromStrings $ lines s)
_ | isOpt "paragraphs" opts -> return (fromStrings $ toParagraphs $ lines s)
_ -> return (fromString s),
flags = [("file","the input file name")]
}),
("rt", emptyCommandInfo {
longname = "rank_trees",
synopsis = "show trees in an order of decreasing probability",
explanation = unlines [
"Order trees from the most to the least probable, using either",
"even distribution in each category (default) or biased as specified",
"by the file given by flag -probs=FILE, where each line has the form",
"'function probability', e.g. 'youPol_Pron 0.01'."
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let ts = toExprs arg
pgf <- optProbs opts pgf
let tds = rankTreesByProbs pgf ts
if isOpt "v" opts
then putStrLn $
unlines [showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds]
else return ()
returnFromExprs $ map fst tds,
flags = [
("probs","probabilities from this file (format 'f 0.6' per line)")
],
options = [
("v","show all trees with their probability scores")
],
examples = [
mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
]
}),
("tq", emptyCommandInfo {
longname = "translation_quiz",
syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
synopsis = "start a translation quiz",
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let from = optLangFlag "from" pgf opts
let to = optLangFlag "to" pgf opts
exec = needPGF $ \ opts arg pgf -> do
from <- optLangFlag "from" pgf opts
to <- optLangFlag "to" pgf opts
let typ = optType pgf opts
let mt = mexp (toExprs arg)
pgf <- optProbs opts pgf
restricted $ translationQuiz mt pgf from to typ
return void,
flags = [
("from","translate from this language"),
("to","translate to this language"),
("cat","translate in this category"),
("number","the maximum number of questions"),
("probs","file with biased probabilities for generation")
("number","the maximum number of questions")
],
examples = [
mkEx ("tq -from=Eng -to=Swe -- any trees in startcat"),
@@ -529,7 +469,6 @@ pgfCommands = Map.fromList [
]
}),
("vd", emptyCommandInfo {
longname = "visualize_dependency",
synopsis = "show word dependency tree graphically",
@@ -547,7 +486,7 @@ pgfCommands = Map.fromList [
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
"See also 'vp -showdep' for another visualization of dependencies."
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
exec = needPGF $ \ opts arg pgf -> do
let absname = abstractName pgf
let es = toExprs arg
let debug = isOpt "v" opts
@@ -560,8 +499,8 @@ pgfCommands = Map.fromList [
mclab <- case cnclabels of
"" -> return Nothing
_ -> (Just . getCncDepLabels) `fmap` restricted (readFile cnclabels)
let lang = optLang pgf opts
let grphs = map (graphvizDependencyTree outp debug mlab mclab pgf lang) es
concr <- optLang pgf opts
let grphs = map (graphvizDependencyTree outp debug mlab mclab concr) es
if isOpt "conll2latex" opts
then return $ fromString $ conlls2latexDoc $ stanzas $ unlines $ toStrings arg
else if isFlag "view" opts && valStrOpts "output" "" opts == "latex"
@@ -596,7 +535,6 @@ pgfCommands = Map.fromList [
]
}),
("vp", emptyCommandInfo {
longname = "visualize_parse",
synopsis = "show parse tree graphically",
@@ -608,9 +546,8 @@ pgfCommands = Map.fromList [
"by the view flag. The target format is png, unless overridden by the",
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let es = toExprs arg
let lang = optLang pgf opts
exec = needPGF $ \opts arg pgf -> do
let es = toExprs arg
let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
@@ -623,10 +560,11 @@ pgfCommands = Map.fromList [
leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
}
let depfile = valStrOpts "file" "" opts
concr <- optLang pgf opts
mlab <- case depfile of
"" -> return Nothing
_ -> (Just . getDepLabels) `fmap` restricted (readFile depfile)
let grphs = map (graphvizParseTreeDep mlab pgf lang gvOptions) es
let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es
if isFlag "view" opts || isFlag "format" opts
then do
let view = optViewGraph opts
@@ -661,7 +599,6 @@ pgfCommands = Map.fromList [
]
}),
("vt", emptyCommandInfo {
longname = "visualize_tree",
synopsis = "show a set of trees graphically",
@@ -674,7 +611,7 @@ pgfCommands = Map.fromList [
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
"With option -mk, use for showing library style function names of form 'mkC'."
],
exec = getEnv $ \ opts arg (Env pgf mos) ->
exec = needPGF $ \opts arg pgf ->
let es = toExprs arg in
if isOpt "mk" opts
then return $ fromString $ unlines $ map (tree2mk pgf) es
@@ -686,7 +623,7 @@ pgfCommands = Map.fromList [
else do
let funs = not (isOpt "nofun" opts)
let cats = not (isOpt "nocat" opts)
let grphs = map (graphvizAbstractTree pgf (funs,cats)) es
let grphs = map (graphvizAbstractTree pgf (graphvizDefaults{noFun=funs,noCat=cats})) es
if isFlag "view" opts || isFlag "format" opts
then do
let view = optViewGraph opts
@@ -708,6 +645,7 @@ pgfCommands = Map.fromList [
("view","program to open the resulting file (default \"open\")")
]
}),
("ai", emptyCommandInfo {
longname = "abstract_info",
syntax = "ai IDENTIFIER or ai EXPR",
@@ -720,205 +658,156 @@ pgfCommands = Map.fromList [
"If a whole expression is given it prints the expression with refined",
"metavariables and the type of the expression."
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
exec = needPGF $ \opts arg pgf -> do
case toExprs arg of
[EFun id] -> case Map.lookup id (funs (abstract pgf)) of
Just fd -> do putStrLn $ render (ppFun id fd)
let (_,_,_,prob) = fd
putStrLn ("Probability: "++show prob)
return void
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just cd -> do putStrLn $
render (ppCat id cd $$
if null (functionsToCat pgf id)
then empty
else ' ' $$
vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
' ')
let (_,_,prob) = cd
putStrLn ("Probability: "++show prob)
return void
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
[e] -> case inferExpr pgf e of
Left tcErr -> errorWithoutStackTrace $ render (ppTcError tcErr)
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
putStrLn ("Type: "++showType [] ty)
putStrLn ("Probability: "++show (probTree pgf e))
return void
[e] -> case unApp e of
Just (id, []) -> case functionType pgf id of
Just ty -> do putStrLn (showFun pgf id ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
return void
Nothing -> case categoryContext pgf id of
Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos)
let ls = [showFun pgf fn ty | fn <- functionsByCat pgf id, Just ty <- [functionType pgf fn]]
if null ls
then return ()
else putStrLn (unlines ("":ls))
putStrLn ("Probability: "++show (categoryProbability pgf id))
return void
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
_ -> case inferExpr pgf e of
Left err -> error err
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
putStrLn ("Type: "++showType [] ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
return void
_ -> do putStrLn "a single identifier or expression is expected from the command"
return void,
needsTypeCheck = False
})
]
where
getEnv exec opts ts = liftSIO . exec opts ts =<< getPGFEnv
par pgf opts s = case optOpenTypes opts of
[] -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
open_typs -> [parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts]
where
dp = valIntOpts "depth" 4 opts
fromParse opts = foldr (joinPiped . fromParse1 opts) void
needPGF exec opts ts = do
mb_pgf <- getPGF
case mb_pgf of
Just pgf -> liftSIO $ exec opts ts pgf
_ -> fail "Import a grammar before using this command"
joinPiped (Piped (es1,ms1)) (Piped (es2,ms2)) = Piped (jA es1 es2,ms1+++-ms2)
where
jA (Exprs es1) (Exprs es2) = Exprs (es1++es2)
-- ^ fromParse1 always output Exprs
fromParse1 opts (s,(po,bs))
| isOpt "bracket" opts = pipeMessage (showBracketedString bs)
| otherwise =
case po of
ParseOk ts -> fromExprs ts
ParseFailed i -> pipeMessage $ "The parser failed at token "
++ show i ++": "
++ show (words s !! max 0 (i-1))
-- ++ " in " ++ show s
ParseIncomplete -> pipeMessage "The sentence is not complete"
TypeError errs ->
pipeMessage . render $
"The parsing is successful but the type checking failed with error(s):"
$$ nest 2 (vcat (map (ppTcError . snd) errs))
fromParse1 opts (s,po) =
case po of
ParseOk ts -> fromExprs (isOpt "show_probs" opts) (takeOptNum opts ts)
ParseFailed i t -> pipeMessage $ "The parser failed at token "
++ show i ++": "
++ show t
ParseIncomplete -> pipeMessage "The sentence is not complete"
optLins pgf opts ts = case opts of
_ | isOpt "groups" opts ->
concatMap snd $ groupResults
[[(lang, s) | lang <- optLangs pgf opts,s <- linear pgf opts lang t] | t <- ts]
_ -> concatMap (optLin pgf opts) ts
optLins pgf opts ts = concatMap (optLin pgf opts) ts
optLin pgf opts t =
case opts of
_ | isOpt "treebank" opts && isOpt "chunks" opts ->
(showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[showCId lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
(abstractName pgf ++ ": " ++ showExpr [] t) :
[lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
_ | isOpt "treebank" opts ->
(showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
_ | isOpt "tabtreebank" opts ->
return $ concat $ intersperse "\t" $ (showExpr [] t) :
[s | lang <- optLangs pgf opts, s <- linear pgf opts lang t]
(abstractName pgf ++ ": " ++ showExpr [] t) :
[concreteName concr ++ ": " ++ s | concr <- optLangs pgf opts, s<-linear opts concr t]
_ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t
_ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
_ -> [s | concr <- optLangs pgf opts, s <- linear opts concr t]
linChunks pgf opts t =
[(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts]
[(concreteName concr, unwords (intersperse "<+>" (map (unlines . linear opts concr) (treeChunks t)))) | concr <- optLangs pgf opts]
linear :: PGF -> [Option] -> CId -> Expr -> [String]
linear pgf opts lang = let unl = unlex opts lang in case opts of
_ | isOpt "all" opts -> concat . -- intersperse [[]] .
map (map (unl . snd)) . tabularLinearizes pgf lang
linear :: [Option] -> Concr -> Expr -> [String]
linear opts concr = case opts of
_ | isOpt "all" opts -> concat .
map (map snd) . tabularLinearizeAll concr
_ | isOpt "list" opts -> (:[]) . commaList . concat .
map (map (unl . snd)) . tabularLinearizes pgf lang
_ | isOpt "table" opts -> concat . -- intersperse [[]] .
map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang
_ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize pgf lang
_ -> (:[]) . unl . linearize pgf lang
map (map snd) . tabularLinearizeAll concr
_ | isOpt "table" opts -> concat .
map (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
_ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
_ -> (:[]) . linearize concr
-- replace each non-atomic constructor with mkC, where C is the val cat
tree2mk pgf = showExpr [] . t2m where
t2m t = case unApp t of
Just (cid,ts@(_:_)) -> mkApp (mk cid) (map t2m ts)
_ -> t
mk = mkCId . ("mk" ++) . showCId . lookValCat (abstract pgf)
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
lexs -> case lookup lang
[(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
Just le -> chunks ',' le
_ -> []
Just (cid,ts@(_:_)) -> mkApp (mk cid) (map t2m ts)
_ -> t
mk f = case functionType pgf f of
Just ty -> let (_,cat,_) = unType ty
in "mk" ++ cat
Nothing -> f
commaList [] = []
commaList ws = concat $ head ws : map (", " ++) (tail ws)
-- Proposed logic of coding in unlexing:
-- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used.
-- - If lang has flag coding=utf8, -to_utf8 is ignored.
-- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
{-
unlexx pgf opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ----
optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of
Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts
Just (LStr other) | isOpt "to_utf8" opts ->
let cod = ("from_" ++ other)
in cod : filter (/=cod) (map prOpt opts)
_ -> map prOpt opts
-}
optRestricted opts pgf =
restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs pgf opts]) pgf
optLang = optLangFlag "lang"
optLangs = optLangsFlag "lang"
optLangsFlag f pgf opts = case valStrOpts f "" opts of
"" -> languages pgf
lang -> map (completeLang pgf) (chunks ',' lang)
completeLang pgf la = let cla = (mkCId la) in
if elem cla (languages pgf)
then cla
else (mkCId (showCId (abstractName pgf) ++ la))
optLangFlag flag pgf opts =
case optLangsFlag flag pgf opts of
[] -> fail "no language specified"
(l:ls) -> return l
optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId]
optLangsFlag flag pgf opts =
case valStrOpts flag "" opts of
"" -> Map.elems langs
str -> mapMaybe (completeLang pgf) (chunks ',' str)
where
langs = languages pgf
optOpenTypes opts = case valStrOpts "openclass" "" opts of
"" -> []
cats -> mapMaybe readType (chunks ',' cats)
optProbs opts pgf = case valStrOpts "probs" "" opts of
"" -> return pgf
file -> do
probs <- restricted $ readProbabilitiesFromFile file pgf
return (setProbabilities probs pgf)
completeLang pgf la =
mplus (Map.lookup la langs)
(Map.lookup (abstractName pgf ++ la) langs)
optFile opts = valStrOpts "file" "_gftmp" opts
optType pgf opts =
let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
in case readType str of
Just ty -> case checkType pgf ty of
Left tcErr -> error $ render (ppTcError tcErr)
Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as a type")
let readOpt str = case readType str of
Just ty -> case checkType pgf ty of
Left err -> error err
Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as a type")
in maybeStrOpts "cat" (startCat pgf) readOpt opts
optViewFormat opts = valStrOpts "format" "png" opts
optViewGraph opts = valStrOpts "view" "open" opts
optNum opts = valIntOpts "number" 1 opts
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
takeOptNum opts = take (optNumInf opts)
returnFromExprs es = return $ case es of
[] -> pipeMessage "no trees found"
_ -> fromExprs es
returnFromExprs show_p es =
return $
case es of
[] -> pipeMessage "no trees found"
_ -> fromExprs show_p es
prGrammar (Env pgf mos) opts
prGrammar pgf opts
| isOpt "pgf" opts = do
let pgf1 = if isOpt "opt" opts then optimizePGF pgf else pgf
let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
restricted $ encodeFile outfile pgf1
let outfile = valStrOpts "file" (abstractName pgf ++ ".pgf") opts
restricted $ writePGF outfile pgf
putStrLn $ "wrote file " ++ outfile
return void
| isOpt "cats" opts = return $ fromString $ unwords $ map showCId $ categories pgf
| isOpt "funs" opts = return $ fromString $ unlines $ map showFun $ funsigs pgf
| isOpt "fullform" opts = return $ fromString $ concatMap (morpho mos "" prFullFormLexicon) $ optLangs pgf opts
| isOpt "langs" opts = return $ fromString $ unwords $ map showCId $ languages pgf
| isOpt "cats" opts = return $ fromString $ unwords $ categories pgf
| isOpt "funs" opts = return $ fromString $ unlines [showFun pgf f ty | f <- functions pgf, Just ty <- [functionType pgf f]]
| isOpt "fullform" opts = return $ fromString $ concatMap prFullFormLexicon $ optLangs pgf opts
| isOpt "langs" opts = return $ fromString $ unwords $ Map.keys $ languages pgf
| isOpt "lexc" opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) |
la <- optLangs pgf opts, let cs = missingLins pgf la]
| isOpt "words" opts = return $ fromString $ concatMap (morpho mos "" prAllWords) $ optLangs pgf opts
| isOpt "lexc" opts = return $ fromString $ concatMap prLexcLexicon $ optLangs pgf opts
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (concreteName concr:":":[f | f <- functions pgf, not (hasLinearization concr f)]) |
concr <- optLangs pgf opts]
| isOpt "words" opts = return $ fromString $ concatMap prAllWords $ optLangs pgf opts
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
where
kwd | functionIsDataCon pgf id = "data"
| otherwise = "fun"
morphos (Env pgf mos) opts s =
[(s,morpho mos [] (\mo -> lookupMorpho mo s) la) | la <- optLangs pgf opts]
morpho mos z f la = maybe z f $ Map.lookup la mos
optMorpho (Env pgf mos) opts = morpho mos (error "no morpho") id (head (optLangs pgf opts))
morphos pgf opts s =
[(s,lookupMorpho concr s) | concr <- optLangs pgf opts]
optClitics opts = case valStrOpts "clitics" "" opts of
"" -> []
@@ -931,18 +820,28 @@ pgfCommands = Map.fromList [
-- ps -f -g s returns g (f s)
treeOps pgf opts s = foldr app s (reverse opts) where
app (OOpt op) | Just (Left f) <- treeOp pgf op = f
app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x)
app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x
app _ = id
morphoMissing :: Concr -> [String] -> [String]
morphoMissing = morphoClassify False
morphoKnown :: Concr -> [String] -> [String]
morphoKnown = morphoClassify True
morphoClassify :: Bool -> Concr -> [String] -> [String]
morphoClassify k concr ws = [w | w <- ws, k /= null (lookupMorpho concr w), notLiteral w] where
notLiteral w = not (all isDigit w)
treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf]
treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO ()
translationQuiz :: Maybe Expr -> PGF -> Concr -> Concr -> Type -> IO ()
translationQuiz mex pgf ig og typ = do
tts <- translationList mex pgf ig og typ infinity
mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO ()
morphologyQuiz :: Maybe Expr -> PGF -> Concr -> Type -> IO ()
morphologyQuiz mex pgf ig typ = do
tts <- morphologyList mex pgf ig typ infinity
mkQuiz "Welcome to GF Morphology Quiz." tts
@@ -951,30 +850,28 @@ morphologyQuiz mex pgf ig typ = do
infinity :: Int
infinity = 256
prLexcLexicon :: Morpho -> String
prLexcLexicon mo =
unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"]
prLexcLexicon :: Concr -> String
prLexcLexicon concr =
unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
where
morpho = fullFormLexicon mo
prLexc l p = showCId l ++ concat (mkTags (words p))
morpho = fullFormLexicon concr
prLexc l p = l ++ concat (mkTags (words p))
mkTags p = case p of
"s":ws -> mkTags ws --- remove record field
ws -> map ('+':) ws
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p) <- lps]
-- thick_A+(AAdj+Posit+Gen):thick's # ;
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
prFullFormLexicon :: Morpho -> String
prFullFormLexicon mo =
unlines (map prMorphoAnalysis (fullFormLexicon mo))
prFullFormLexicon :: Concr -> String
prFullFormLexicon concr =
unlines (map prMorphoAnalysis (fullFormLexicon concr))
prAllWords :: Morpho -> String
prAllWords mo =
unwords [w | (w,_) <- fullFormLexicon mo]
prAllWords :: Concr -> String
prAllWords concr =
unwords [w | (w,_) <- fullFormLexicon concr]
prMorphoAnalysis :: (String,[(Lemma,Analysis)]) -> String
prMorphoAnalysis (w,lps) =
unlines (w:[showCId l ++ " : " ++ p | (l,p) <- lps])
unlines (w:[l ++ " : " ++ p ++ show prob | (l,p,prob) <- lps])
viewGraphviz :: String -> String -> String -> [String] -> SIO CommandOutput
viewGraphviz view format name grphs = do
@@ -1019,7 +916,3 @@ stanzas = map unlines . chop . lines where
chop ls = case break (=="") ls of
(ls1,[]) -> [ls1]
(ls1,_:ls2) -> ls1 : chop ls2
#if !(MIN_VERSION_base(4,9,0))
errorWithoutStackTrace = error
#endif

831
src/compiler/GF/Command/Commands2.hs
View File

@@ -1,831 +0,0 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands2 (
PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands,
options, flags,
) where
import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF2
import qualified PGF as H
import GF.Compile.ToAPI(exprToAPI)
import GF.Infra.UseIO(writeUTF8File)
import GF.Infra.SIO(MonadSIO,liftSIO,putStrLn,restricted,restrictedSystem)
import GF.Command.Abstract
import GF.Command.CommandInfo
import GF.Data.Operations
import Data.List(intersperse,intersect,nub,sortBy)
import Data.Maybe
import qualified Data.Map as Map
import GF.Text.Pretty
import Control.Monad(mplus)
import qualified Control.Monad.Fail as Fail
data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr}
pgfEnv pgf = Env (Just pgf) (languages pgf)
emptyPGFEnv = Env Nothing Map.empty
class (Fail.MonadFail m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
instance (Monad m,HasPGFEnv m) => TypeCheckArg m where
typeCheckArg e = do env <- getPGFEnv
case pgf env of
Just gr -> either fail
(return . hsExpr . fst)
(inferExpr gr (cExpr e))
Nothing -> fail "Import a grammar before using this command"
pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
pgfCommands = Map.fromList [
("aw", emptyCommandInfo {
longname = "align_words",
synopsis = "show word alignments between languages graphically",
explanation = unlines [
"Prints a set of strings in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = needPGF $ \opts es env -> do
let cncs = optConcs env opts
if isOpt "giza" opts
then if length cncs == 2
then let giz = map (gizaAlignment pgf (snd (cncs !! 0)) (snd (cncs !! 1)) . cExpr) (toExprs es)
lsrc = unlines $ map (\(x,_,_) -> x) giz
ltrg = unlines $ map (\(_,x,_) -> x) giz
align = unlines $ map (\(_,_,x) -> x) giz
grph = if null (toExprs es) then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
in return (fromString grph)
else error "For giza alignment you need exactly two languages"
else let gvOptions=graphvizDefaults{leafFont = valStrOpts "font" "" opts,
leafColor = valStrOpts "color" "" opts,
leafEdgeStyle = valStrOpts "edgestyle" "" opts
}
grph = if null (toExprs es) then [] else graphvizWordAlignment (map snd cncs) gvOptions (cExpr (head (toExprs es)))
in if isFlag "view" opts || isFlag "format" opts
then do let file s = "_grph." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grph
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return (fromString grph),
examples = [
("gr | aw" , "generate a tree and show word alignment as graph script"),
("gr | aw -view=\"open\"" , "generate a tree and display alignment on Mac"),
("gr | aw -view=\"eog\"" , "generate a tree and display alignment on Ubuntu"),
("gt | aw -giza | wf -file=aligns" , "generate trees, send giza alignments to file")
],
options = [
("giza", "show alignments in the Giza format; the first two languages")
],
flags = [
("format","format of the visualization file (default \"png\")"),
("lang", "alignments for this list of languages (default: all)"),
("view", "program to open the resulting file"),
("font", "font for the words"),
("color", "color for the words"),
("edgestyle", "the style for links between words")
]
}),
{-
("eb", emptyCommandInfo {
longname = "example_based",
syntax = "eb (-probs=FILE | -lang=LANG)* -file=FILE.gfe",
synopsis = "converts .gfe files to .gf files by parsing examples to trees",
explanation = unlines [
"Reads FILE.gfe and writes FILE.gf. Each expression of form",
"'%ex CAT QUOTEDSTRING' in FILE.gfe is replaced by a syntax tree.",
"This tree is the first one returned by the parser; a biased ranking",
"can be used to regulate the order. If there are more than one parses",
"the rest are shown in comments, with probabilities if the order is biased.",
"The probabilities flag and configuration file is similar to the commands",
"gr and rt. Notice that the command doesn't change the environment,",
"but the resulting .gf file must be imported separately."
],
options = [
("api","convert trees to overloaded API expressions (using Syntax not Lang)")
],
flags = [
("file","the file to be converted (suffix .gfe must be given)"),
("lang","the language in which to parse"),
("probs","file with probabilities to rank the parses")
],
exec = \env@(pgf, mos) opts _ -> do
let file = optFile opts
pgf <- optProbs opts pgf
let printer = if (isOpt "api" opts) then exprToAPI else (H.showExpr [])
let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
(file',ws) <- restricted $ parseExamplesInGrammar conf file
if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
return (fromString ("wrote " ++ file')),
needsTypeCheck = False
}),
-}
{-
("gr", emptyCommandInfo {
longname = "generate_random",
synopsis = "generate random trees in the current abstract syntax",
syntax = "gr [-cat=CAT] [-number=INT]",
examples = [
mkEx "gr -- one tree in the startcat of the current grammar",
mkEx "gr -cat=NP -number=16 -- 16 trees in the category NP",
mkEx "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha",
mkEx "gr -probs=FILE -- generate with bias",
mkEx "gr (AdjCN ? (UseN ?)) -- generate trees of form (AdjCN ? (UseN ?))"
],
explanation = unlines [
"Generates a list of random trees, by default one tree.",
"If a tree argument is given, the command completes the Tree with values to",
"all metavariables in the tree. The generation can be biased by probabilities,",
"given in a file in the -probs flag."
],
flags = [
("cat","generation category"),
("lang","uses only functions that have linearizations in all these languages"),
("number","number of trees generated"),
("depth","the maximum generation depth"),
("probs", "file with biased probabilities (format 'f 0.4' one by line)")
],
exec = \env@(pgf, mos) opts xs -> do
pgf <- optProbs opts (optRestricted opts pgf)
gen <- newStdGen
let dp = valIntOpts "depth" 4 opts
let ts = case mexp xs of
Just ex -> H.generateRandomFromDepth gen pgf ex (Just dp)
Nothing -> H.generateRandomDepth gen pgf (optType pgf opts) (Just dp)
returnFromExprs $ take (optNum opts) ts
}),
-}
("gt", emptyCommandInfo {
longname = "generate_trees",
synopsis = "generates a list of trees, by default exhaustive",
flags = [("cat","the generation category"),
("number","the number of trees generated")],
examples = [
mkEx "gt -- all trees in the startcat",
mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP"],
exec = needPGF $ \ opts _ env@(pgf,_) ->
let ts = map fst (generateAll pgf cat)
cat = optType pgf opts
in returnFromCExprs (takeOptNum opts ts),
needsTypeCheck = False
}),
("i", emptyCommandInfo {
longname = "import",
synopsis = "import a grammar from a compiled .pgf file",
explanation = unlines [
"Reads a grammar from a compiled .pgf file.",
"Old modules are discarded.",
{-
"The grammar parser depends on the file name suffix:",
" .cf context-free (labelled BNF) source",
" .ebnf extended BNF source",
" .gfm multi-module GF source",
" .gf normal GF source",
" .gfo compiled GF source",
-}
" .pgf precompiled grammar in Portable Grammar Format"
],
flags = [
-- ("probs","file with biased probabilities for generation")
],
options = [
-- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
-- ("retain","retain operations (used for cc command)"),
-- ("src", "force compilation from source"),
-- ("v", "be verbose - show intermediate status information")
],
needsTypeCheck = False
}),
("l", emptyCommandInfo {
longname = "linearize",
synopsis = "convert an abstract syntax expression to string",
explanation = unlines [
"Shows the linearization of a Tree by the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"A sequence of string operations (see command ps) can be given",
"as options, and works then like a pipe to the ps command, except",
"that it only affect the strings, not e.g. the table labels.",
"These can be given separately to each language with the unlexer flag",
"whose results are prepended to the other lexer flags. The value of the",
"unlexer flag is a space-separated list of comma-separated string operation",
"sequences; see example."
],
examples = [
mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize a tree to LangSwe and LangNor",
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
],
exec = needPGF $ \ opts arg env ->
return . fromStrings . optLins env opts . map cExpr $ toExprs arg,
options = [
("all", "show all forms and variants, one by line (cf. l -list)"),
("bracket","show tree structure with brackets and paths to nodes"),
("groups", "all languages, grouped by lang, remove duplicate strings"),
("list","show all forms and variants, comma-separated on one line (cf. l -all)"),
("multi","linearize to all languages (default)"),
("table","show all forms labelled by parameters"),
("treebank","show the tree and tag linearizations with language names")
],
flags = [
("lang","the languages of linearization (comma-separated, no spaces)")
]
}),
("ma", emptyCommandInfo {
longname = "morpho_analyse",
synopsis = "print the morphological analyses of the (multiword) expression in the string",
explanation = unlines [
"Prints all the analyses of the (multiword) expression in the input string,",
"using the morphological analyser of the actual grammar (see command pg)"
],
exec = needPGF $ \opts args env ->
return ((fromString . unlines .
map prMorphoAnalysis . concatMap (morphos env opts) . toStrings) args),
flags = [
("lang","the languages of analysis (comma-separated, no spaces)")
]
}),
{-
("mq", emptyCommandInfo {
longname = "morpho_quiz",
synopsis = "start a morphology quiz",
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
exec = \env@(pgf, mos) opts xs -> do
let lang = optLang pgf opts
let typ = optType pgf opts
pgf <- optProbs opts pgf
let mt = mexp xs
restricted $ morphologyQuiz mt pgf lang typ
return void,
flags = [
("lang","language of the quiz"),
("cat","category of the quiz"),
("number","maximum number of questions"),
("probs","file with biased probabilities for generation")
]
}),
-}
("p", emptyCommandInfo {
longname = "parse",
synopsis = "parse a string to abstract syntax expression",
explanation = unlines [
"Shows all trees returned by parsing a string in the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"The default start category can be overridden by the -cat flag.",
"See also the ps command for lexing and character encoding."
],
flags = [
("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)"),
("number","maximum number of trees returned")
],
examples = [
mkEx "p \"this fish is fresh\" | l -lang=Swe -- try parsing with all languages and translate the successful parses to Swedish"
],
exec = needPGF $ \ opts ts env -> return . cParse env opts $ toStrings ts
}),
("pg", emptyCommandInfo {
longname = "print_grammar",
synopsis = "prints different information about the grammar",
exec = needPGF $ \opts _ env -> prGrammar env opts,
options = [
("cats", "show just the names of abstract syntax categories"),
("fullform", "print the fullform lexicon"),
("funs", "show just the names and types of abstract syntax functions"),
("langs", "show just the names of top concrete syntax modules"),
("lexc", "print the lexicon in Xerox LEXC format"),
("missing","show just the names of functions that have no linearization"),
("words", "print the list of words")
],
flags = [
("lang","the languages that need to be printed")
],
examples = [
mkEx "pg -langs -- show the names of top concrete syntax modules",
mkEx "pg -funs | ? grep \" S ;\" -- show functions with value cat S"
]
}),
{-
("pt", emptyCommandInfo {
longname = "put_tree",
syntax = "pt OPT? TREE",
synopsis = "return a tree, possibly processed with a function",
explanation = unlines [
"Returns a tree obtained from its argument tree by applying",
"tree processing functions in the order given in the command line",
"option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors",
"are type checking and semantic computation."
],
examples = [
mkEx "pt -compute (plus one two) -- compute value",
mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..."
],
exec = \env@(pgf, mos) opts ->
returnFromExprs . takeOptNum opts . treeOps pgf opts,
options = treeOpOptions undefined{-pgf-},
flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
}),
-}
("rf", emptyCommandInfo {
longname = "read_file",
synopsis = "read string or tree input from a file",
explanation = unlines [
"Reads input from file. The filename must be in double quotes.",
"The input is interpreted as a string by default, and can hence be",
"piped e.g. to the parse command. The option -tree interprets the",
"input as a tree, which can be given e.g. to the linearize command.",
"The option -lines will result in a list of strings or trees, one by line."
],
options = [
("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees")
],
exec = needPGF $ \opts _ env@(pgf, mos) -> do
let file = optFile opts
let exprs [] = ([],empty)
exprs ((n,s):ls) | null s
= exprs ls
exprs ((n,s):ls) = case readExpr s of
Just e -> let (es,err) = exprs ls
in case inferExpr pgf e of
Right (e,t) -> (e:es,err)
Left msg -> (es,"on line" <+> n <> ':' $$ msg $$ err)
Nothing -> let (es,err) = exprs ls
in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
returnFromLines ls = case exprs ls of
(es, err) | null es -> return $ pipeMessage $ render (err $$ "no trees found")
| otherwise -> return $ pipeWithMessage (map hsExpr es) (render err)
s <- restricted $ readFile file
case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
returnFromLines (zip [1::Int ..] (lines s))
_ | isOpt "tree" opts ->
returnFromLines [(1::Int,s)]
_ | isOpt "lines" opts -> return (fromStrings $ lines s)
_ -> return (fromString s),
flags = [("file","the input file name")]
}),
("rt", emptyCommandInfo {
longname = "rank_trees",
synopsis = "show trees in an order of decreasing probability",
explanation = unlines [
"Order trees from the most to the least probable, using either",
"even distribution in each category (default) or biased as specified",
"by the file given by flag -probs=FILE, where each line has the form",
"'function probability', e.g. 'youPol_Pron 0.01'."
],
exec = needPGF $ \opts es env@(pgf, _) -> do
let tds = sortBy (\(_,p) (_,q) -> compare p q)
[(t, treeProbability pgf t) | t <- map cExpr (toExprs es)]
if isOpt "v" opts
then putStrLn $
unlines [PGF2.showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds]
else return ()
returnFromExprs $ map (hsExpr . fst) tds,
flags = [
("probs","probabilities from this file (format 'f 0.6' per line)")
],
options = [
("v","show all trees with their probability scores")
],
examples = [
mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
]
}),
{-
("tq", emptyCommandInfo {
longname = "translation_quiz",
syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
synopsis = "start a translation quiz",
exec = \env@(pgf, mos) opts xs -> do
let from = optLangFlag "from" pgf opts
let to = optLangFlag "to" pgf opts
let typ = optType pgf opts
let mt = mexp xs
pgf <- optProbs opts pgf
restricted $ translationQuiz mt pgf from to typ
return void,
flags = [
("from","translate from this language"),
("to","translate to this language"),
("cat","translate in this category"),
("number","the maximum number of questions"),
("probs","file with biased probabilities for generation")
],
examples = [
mkEx ("tq -from=Eng -to=Swe -- any trees in startcat"),
mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form")
]
}),
("vd", emptyCommandInfo {
longname = "visualize_dependency",
synopsis = "show word dependency tree graphically",
explanation = unlines [
"Prints a dependency tree in the .dot format (the graphviz format, default)",
"or the CoNLL/MaltParser format (flag -output=conll for training, malt_input",
"for unanalysed input).",
"By default, the last argument is the head of every abstract syntax",
"function; moreover, the head depends on the head of the function above.",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is png, unless overridden by the",
"flag -format."
],
exec = \env@(pgf, mos) opts es -> do
let debug = isOpt "v" opts
let file = valStrOpts "file" "" opts
let outp = valStrOpts "output" "dot" opts
mlab <- case file of
"" -> return Nothing
_ -> (Just . H.getDepLabels . lines) `fmap` restricted (readFile file)
let lang = optLang pgf opts
let grphs = unlines $ map (H.graphvizDependencyTree outp debug mlab Nothing pgf lang) es
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grphd." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grphs
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return $ fromString grphs,
examples = [
mkEx "gr | vd -- generate a tree and show dependency tree in .dot",
mkEx "gr | vd -view=open -- generate a tree and display dependency tree on a Mac",
mkEx "gr -number=1000 | vd -file=dep.labels -output=malt -- generate training treebank",
mkEx "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences"
],
options = [
("v","show extra information")
],
flags = [
("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"),
("format","format of the visualization file (default \"png\")"),
("output","output format of graph source (default \"dot\")"),
("view","program to open the resulting file (default \"open\")"),
("lang","the language of analysis")
]
}),
-}
("vp", emptyCommandInfo {
longname = "visualize_parse",
synopsis = "show parse tree graphically",
explanation = unlines [
"Prints a parse tree in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is png, unless overridden by the",
"flag -format."
],
exec = needPGF $ \opts arg env@(pgf, concs) ->
do let es = toExprs arg
let concs = optConcs env opts
let gvOptions=graphvizDefaults{noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
nodeFont = valStrOpts "nodefont" "" opts,
leafFont = valStrOpts "leaffont" "" opts,
nodeColor = valStrOpts "nodecolor" "" opts,
leafColor = valStrOpts "leafcolor" "" opts,
nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
}
let grph= if null es || null concs
then []
else graphvizParseTree (snd (head concs)) gvOptions (cExpr (head es))
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grph
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return $ fromString grph,
examples = [
mkEx "p -lang=Eng \"John walks\" | vp -- generate a tree and show parse tree as .dot script",
mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac"
],
options = [
("showcat","show categories in the tree nodes (default)"),
("nocat","don't show categories"),
("showfun","show function names in the tree nodes"),
("nofun","don't show function names (default)"),
("showleaves","show the leaves of the tree (default)"),
("noleaves","don't show the leaves of the tree (i.e., only the abstract tree)")
],
flags = [
("lang","the language to visualize"),
("format","format of the visualization file (default \"png\")"),
("view","program to open the resulting file (default \"open\")"),
("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
("leaffont","font for tree leaves (default: nodefont)"),
("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
("leafcolor","color for tree leaves (default: nodecolor)"),
("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)"),
("leafedgestyle","edge style for links to leaves (solid/dashed/dotted/bold, default: dashed)")
]
}),
("vt", emptyCommandInfo {
longname = "visualize_tree",
synopsis = "show a set of trees graphically",
explanation = unlines [
"Prints a set of trees in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = needPGF $ \opts arg env@(pgf, _) ->
let es = toExprs arg in
if isOpt "api" opts
then do
mapM_ (putStrLn . exprToAPI) es
return void
else do
let gvOptions=graphvizDefaults{noFun = isOpt "nofun" opts,
noCat = isOpt "nocat" opts,
nodeFont = valStrOpts "nodefont" "" opts,
nodeColor = valStrOpts "nodecolor" "" opts,
nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts
}
let grph = unlines (map (graphvizAbstractTree pgf gvOptions . cExpr) es)
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grph
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return $ fromString grph,
examples = [
mkEx "p \"hello\" | vt -- parse a string and show trees as graph script",
mkEx "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac"
],
options = [
("api", "show the tree with function names converted to 'mkC' with value cats C"),
("nofun","don't show functions but only categories"),
("nocat","don't show categories but only functions")
],
flags = [
("format","format of the visualization file (default \"png\")"),
("view","program to open the resulting file (default \"open\")"),
("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)")
]
}),
("ai", emptyCommandInfo {
longname = "abstract_info",
syntax = "ai IDENTIFIER or ai EXPR",
synopsis = "Provides an information about a function, an expression or a category from the abstract syntax",
explanation = unlines [
"The command has one argument which is either function, expression or",
"a category defined in the abstract syntax of the current grammar. ",
"If the argument is a function then its type is printed out.",
"If it is a category then the category definition is printed.",
"If a whole expression is given it prints the expression with refined",
"metavariables and the type of the expression."
],
exec = needPGF $ \opts args env@(pgf,cncs) ->
case map cExpr (toExprs args) of
[e] -> case unApp e of
Just (id,[]) -> return (fromString
(case functionType pgf id of
Just ty -> showFun id ty
Nothing -> let funs = functionsByCat pgf id
in showCat id funs))
where
showCat c funs = "cat "++c++
" ;\n\n"++
unlines [showFun f ty| f<-funs,
Just ty <- [functionType pgf f]]
showFun f ty = "fun "++f++" : "++showType [] ty++" ;"
_ -> case inferExpr pgf e of
Left msg -> error msg
Right (e,ty) -> do putStrLn ("Expression: "++PGF2.showExpr [] e)
putStrLn ("Type: "++PGF2.showType [] ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
return void
_ -> do putStrLn "a single function name or category name is expected"
return void,
needsTypeCheck = False
})
]
where
cParse env@(pgf,_) opts ss =
parsed [ parse cnc cat s | s<-ss,(lang,cnc)<-cncs]
where
cat = optType pgf opts
cncs = optConcs env opts
parsed rs = Piped (Exprs ts,unlines msgs)
where
ts = [hsExpr t|ParseOk ts<-rs,(t,p)<-takeOptNum opts ts]
msgs = concatMap mkMsg rs
mkMsg (ParseOk ts) = (map (PGF2.showExpr [] . fst).takeOptNum opts) ts
mkMsg (ParseFailed _ tok) = ["Parse failed: "++tok]
mkMsg (ParseIncomplete) = ["The sentence is incomplete"]
optLins env opts ts = case opts of
_ | isOpt "groups" opts ->
concatMap snd $ groupResults
[[(lang, s) | (lang,concr) <- optConcs env opts,s <- linear opts lang concr t] | t <- ts]
_ -> concatMap (optLin env opts) ts
optLin env@(pgf,_) opts t =
case opts of
_ | isOpt "treebank" opts ->
(abstractName pgf ++ ": " ++ PGF2.showExpr [] t) :
[lang ++ ": " ++ s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t]
_ -> [s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t]
linear :: [Option] -> ConcName -> Concr -> PGF2.Expr -> [String]
linear opts lang concr = case opts of
_ | isOpt "all" opts -> concat . map (map snd) . tabularLinearizeAll concr
_ | isOpt "list" opts -> (:[]) . commaList .
concatMap (map snd) . tabularLinearizeAll concr
_ | isOpt "table" opts -> concatMap (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
_ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
_ -> (:[]) . linearize concr
groupResults :: [[(ConcName,String)]] -> [(ConcName,[String])]
groupResults = Map.toList . foldr more Map.empty . start . concat
where
start ls = [(l,[s]) | (l,s) <- ls]
more (l,s) =
Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
optConcs = optConcsFlag "lang"
optConcsFlag f (pgf,cncs) opts =
case valStrOpts f "" opts of
"" -> Map.toList cncs
lang -> mapMaybe pickLang (chunks ',' lang)
where
pickLang l = pick l `mplus` pick fl
where
fl = abstractName pgf++l
pick l = (,) l `fmap` Map.lookup l cncs
{-
-- replace each non-atomic constructor with mkC, where C is the val cat
tree2mk pgf = H.showExpr [] . t2m where
t2m t = case H.unApp t of
Just (cid,ts@(_:_)) -> H.mkApp (mk cid) (map t2m ts)
_ -> t
mk = H.mkCId . ("mk" ++) . H.showCId . H.lookValCat (H.abstract pgf)
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
lexs -> case lookup lang
[(H.mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
Just le -> chunks ',' le
_ -> []
-}
commaList [] = []
commaList ws = concat $ head ws : map (", " ++) (tail ws)
optFile opts = valStrOpts "file" "_gftmp" opts
optType pgf opts =
case listFlags "cat" opts of
v:_ -> let str = valueString v
in case readType str of
Just ty -> case checkType pgf ty of
Left msg -> error msg
Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as a type")
_ -> startCat pgf
optViewFormat opts = valStrOpts "format" "png" opts
optViewGraph opts = valStrOpts "view" "open" opts
{-
optNum opts = valIntOpts "number" 1 opts
-}
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
takeOptNum opts = take (optNumInf opts)
returnFromCExprs = returnFromExprs . map hsExpr
returnFromExprs es =
return $ case es of
[] -> pipeMessage "no trees found"
_ -> fromExprs es
prGrammar env@(pgf,cncs) opts
| isOpt "langs" opts = return . fromString . unwords $ (map fst (optConcs env opts))
| isOpt "cats" opts = return . fromString . unwords $ categories pgf
| isOpt "funs" opts = return . fromString . unwords $ functions pgf
| isOpt "missing" opts = return . fromString . unwords $
[f | f <- functions pgf, not (and [hasLinearization concr f | (_,concr) <- optConcs env opts])]
| isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . snd) $ optConcs env opts
| isOpt "words" opts = return $ fromString $ concatMap (prAllWords . snd) $ optConcs env opts
| isOpt "lexc" opts = return $ fromString $ concatMap (prLexcLexicon . snd) $ optConcs env opts
| otherwise = return void
gizaAlignment pgf src_cnc tgt_cnc e =
let src_res = alignWords src_cnc e
tgt_res = alignWords tgt_cnc e
alignment = [show i++"-"++show j | (i,(_,src_fids)) <- zip [0..] src_res, (j,(_,tgt_fids)) <- zip [0..] tgt_res, not (null (intersect src_fids tgt_fids))]
in (unwords (map fst src_res), unwords (map fst tgt_res), unwords alignment)
morphos env opts s =
[(s,res) | (lang,concr) <- optConcs env opts, let res = lookupMorpho concr s, not (null res)]
{-
mexp xs = case xs of
t:_ -> Just t
_ -> Nothing
-}
-- ps -f -g s returns g (f s)
{-
treeOps pgf opts s = foldr app s (reverse opts) where
app (OOpt op) | Just (Left f) <- treeOp pgf op = f
app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (H.mkCId x)
app _ = id
treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf]
treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
translationQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Language -> H.Type -> IO ()
translationQuiz mex pgf ig og typ = do
tts <- translationList mex pgf ig og typ infinity
mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Type -> IO ()
morphologyQuiz mex pgf ig typ = do
tts <- morphologyList mex pgf ig typ infinity
mkQuiz "Welcome to GF Morphology Quiz." tts
-- | the maximal number of precompiled quiz problems
infinity :: Int
infinity = 256
-}
prLexcLexicon :: Concr -> String
prLexcLexicon concr =
unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
where
morpho = fullFormLexicon concr
prLexc l p = l ++ concat (mkTags (words p))
mkTags p = case p of
"s":ws -> mkTags ws --- remove record field
ws -> map ('+':) ws
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
-- thick_A+(AAdj+Posit+Gen):thick's # ;
prFullFormLexicon :: Concr -> String
prFullFormLexicon concr =
unlines (map prMorphoAnalysis (fullFormLexicon concr))
prAllWords :: Concr -> String
prAllWords concr =
unwords [w | (w,_) <- fullFormLexicon concr]
prMorphoAnalysis :: (String,[MorphoAnalysis]) -> String
prMorphoAnalysis (w,lps) =
unlines (w:[fun ++ " : " ++ cat | (fun,cat,p) <- lps])
hsExpr c =
case unApp c of
Just (f,cs) -> H.mkApp (H.mkCId f) (map hsExpr cs)
_ -> case unStr c of
Just str -> H.mkStr str
_ -> case unInt c of
Just n -> H.mkInt n
_ -> case unFloat c of
Just d -> H.mkFloat d
_ -> error $ "GF.Command.Commands2.hsExpr "++show c
cExpr e =
case H.unApp e of
Just (f,es) -> mkApp (H.showCId f) (map cExpr es)
_ -> case H.unStr e of
Just str -> mkStr str
_ -> case H.unInt e of
Just n -> mkInt n
_ -> case H.unFloat e of
Just d -> mkFloat d
_ -> error $ "GF.Command.Commands2.cExpr "++show e
needPGF exec opts ts =
do Env mb_pgf cncs <- getPGFEnv
case mb_pgf of
Just pgf -> liftSIO $ exec opts ts (pgf,cncs)
_ -> fail "Import a grammar before using this command"

47
src/compiler/GF/Command/CommonCommands.hs
View File

@@ -3,7 +3,6 @@
-- elsewhere
module GF.Command.CommonCommands where
import Data.List(sort)
import Data.Char (isSpace)
import GF.Command.CommandInfo
import qualified Data.Map as Map
import GF.Infra.SIO
@@ -15,9 +14,8 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
import GF.Text.Pretty
import GF.Text.Transliterations
import GF.Text.Lexing(stringOp,opInEnv)
import Data.Char (isSpace)
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
import PGF2(showExpr)
extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
@@ -103,9 +101,7 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
"To see transliteration tables, use command ut."
],
examples = [
-- mkEx "l (EAdd 3 4) | ps -code -- linearize code-like output",
mkEx "l (EAdd 3 4) | ps -unlexcode -- linearize code-like output",
-- mkEx "ps -lexer=code | p -cat=Exp -- parse code-like input",
mkEx "ps -lexcode | p -cat=Exp -- parse code-like input",
mkEx "gr -cat=QCl | l | ps -bind -- linearization output from LangFin",
mkEx "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal",
@@ -118,13 +114,11 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
let (os,fs) = optsAndFlags opts
trans <- optTranslit opts
case opts of
_ | isOpt "lines" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
_ | isOpt "paragraphs" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toParagraphs $ toStrings x
_ -> return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
if isOpt "lines" opts
then return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
else return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
options = [
("lines","apply the operation separately to each input line, returning a list of lines"),
("paragraphs","apply separately to each input paragraph (as separated by empty lines), returning a list of lines")
("lines","apply the operation separately to each input line, returning a list of lines")
] ++
stringOpOptions,
flags = [
@@ -171,8 +165,7 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
fmap fromString $ restricted $ readFile tmpo,
-}
fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
fmap fromString . restricted . readShellProcess syst $ toString arg,
flags = [
("command","the system command applied to the argument")
],
@@ -180,12 +173,6 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
mkEx "gt | l | ? wc -- generate trees, linearize, and count words"
]
}),
("tt", emptyCommandInfo {
longname = "to_trie",
syntax = "to_trie",
synopsis = "combine a list of trees into a trie",
exec = \ _ -> return . fromString . trie . toExprs
}),
("ut", emptyCommandInfo {
longname = "unicode_table",
synopsis = "show a transliteration table for a unicode character set",
@@ -233,7 +220,6 @@ envFlag fs =
_ -> Nothing
stringOpOptions = sort $ [
("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
("chars","lexer that makes every non-space character a token"),
("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
("from_utf8","decode from utf8 (default)"),
@@ -258,27 +244,6 @@ stringOpOptions = sort $ [
("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] |
(p,n) <- transliterationPrintNames]
trie = render . pptss . H.toTrie . map H.toATree
where
pptss [ts] = "*"<+>nest 2 (ppts ts)
pptss tss = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss]
ppts = vcat . map ppt
ppt t =
case t of
H.Oth e -> pp (H.showExpr [] e)
H.Ap f [[]] -> pp (H.showCId f)
H.Ap f tss -> H.showCId f $$ nest 2 (pptss tss)
-- ** Converting command input
toString = unwords . toStrings
toLines = unlines . toStrings
toParagraphs = map (unwords . words) . toParas
where
toParas ls = case break (all isSpace) ls of
([],[]) -> []
([],_:ll) -> toParas ll
(l, []) -> [unwords l]
(l, _:ll) -> unwords l : toParas ll

34
src/compiler/GF/Command/Importing.hs
View File

@@ -1,7 +1,7 @@
module GF.Command.Importing (importGrammar, importSource) where
import PGF
import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
import PGF2
import PGF2.Internal(unionPGF)
import GF.Compile
import GF.Compile.Multi (readMulti)
@@ -17,14 +17,16 @@ import GF.Data.ErrM
import System.FilePath
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad(foldM)
-- import a grammar in an environment where it extends an existing grammar
importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
importGrammar pgf0 _ [] = return pgf0
importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
importGrammar pgf0 _ [] = return pgf0
importGrammar pgf0 opts files =
case takeExtensions (last files) of
".cf" -> importCF opts files getBNFCRules bnfc2cf
".ebnf" -> importCF opts files getEBNFRules ebnf2cf
".cf" -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
".gfm" -> do
ascss <- mapM readMulti files
let cs = concatMap snd ascss
@@ -36,14 +38,15 @@ importGrammar pgf0 opts files =
Bad msg -> do putStrLn ('\n':'\n':msg)
return pgf0
".pgf" -> do
pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
ioUnionPGF pgf0 pgf2
mapM readPGF files >>= foldM ioUnionPGF pgf0
ext -> die $ "Unknown filename extension: " ++ show ext
ioUnionPGF :: PGF -> PGF -> IO PGF
ioUnionPGF one two = case msgUnionPGF one two of
(pgf, Just msg) -> putStrLn msg >> return pgf
(pgf,_) -> return pgf
ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
ioUnionPGF Nothing two = return (Just two)
ioUnionPGF (Just one) two =
case unionPGF one two of
Nothing -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two)
Just pgf -> return (Just pgf)
importSource :: Options -> [FilePath] -> IO SourceGrammar
importSource opts files = fmap (snd.snd) (batchCompile opts files)
@@ -56,7 +59,6 @@ importCF opts files get convert = impCF
startCat <- case rules of
(Rule cat _ _ : _) -> return cat
_ -> fail "empty CFG"
let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
return $ setProbabilities probs
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf
probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
return pgf

18
src/compiler/GF/Command/Interpreter.hs
View File

@@ -6,13 +6,11 @@ module GF.Command.Interpreter (
import GF.Command.CommandInfo
import GF.Command.Abstract
import GF.Command.Parse
import PGF.Internal(Expr(..))
import GF.Infra.UseIO(putStrLnE)
import PGF2
import Control.Monad(when)
import qualified Data.Map as Map
import GF.Infra.UseIO (Output)
import qualified Control.Monad.Fail as Fail
data CommandEnv m = CommandEnv {
commands :: Map.Map String (CommandInfo m),
@@ -24,7 +22,6 @@ data CommandEnv m = CommandEnv {
mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty
--interpretCommandLine :: CommandEnv -> String -> SIO ()
interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m ()
interpretCommandLine env line =
case readCommandLine line of
Just [] -> return ()
@@ -56,17 +53,8 @@ interpretPipe env cs = do
-- | macro definition applications: replace ?i by (exps !! i)
appCommand :: CommandArguments -> Command -> Command
appCommand args c@(Command i os arg) = case arg of
AExpr e -> Command i os (AExpr (app e))
AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
_ -> c
where
xs = toExprs args
app e = case e of
EAbs b x e -> EAbs b x (app e)
EApp e1 e2 -> EApp (app e1) (app e2)
ELit l -> ELit l
EMeta i -> xs !! i
EFun x -> EFun x
-- | return the trees to be sent in pipe, and the output possibly printed
--interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
@@ -113,4 +101,4 @@ getCommandTrees env needsTypeCheck a args =
ATerm t -> return (Term t)
ANoArg -> return args -- use piped
where
one e = return (Exprs [e]) -- ignore piped
one e = return (Exprs [(e,0)]) -- ignore piped

10
src/compiler/GF/Command/Parse.hs
View File

@@ -1,6 +1,6 @@
module GF.Command.Parse(readCommandLine, pCommand) where
import PGF(pExpr,pIdent)
import PGF2(pExpr,pIdent)
import GF.Grammar.Parser(runPartial,pTerm)
import GF.Command.Abstract
@@ -22,7 +22,7 @@ pCommandLine =
pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
pCommand = (do
cmd <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
cmd <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent))
skipSpaces
opts <- sepBy pOption skipSpaces
arg <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
@@ -37,7 +37,7 @@ pCommand = (do
pOption = do
char '-'
flg <- pIdent
flg <- readS_to_P pIdent
option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
pValue = do
@@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
pArgument =
option ANoArg
(fmap AExpr pExpr
(fmap AExpr (readS_to_P pExpr)
<++
(skipSpaces >> char '%' >> fmap AMacro pIdent))
(skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
pArgTerm = ATerm `fmap` readS_to_P sTerm
where

6
src/compiler/GF/Command/SourceCommands.hs
View File

@@ -18,8 +18,8 @@ import GF.Grammar.Parser (runP, pExp)
import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
import GF.Infra.Dependencies(depGraph)
import GF.Infra.CheckM(runCheck)
@@ -259,7 +259,7 @@ checkComputeTerm os sgr t =
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t
t2 = evalStr t1
checkPredefError t2
where

6
src/compiler/GF/Command/TreeOperations.hs
View File

@@ -4,15 +4,15 @@ module GF.Command.TreeOperations (
treeChunks
) where
import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
import Data.List
type TreeOp = [Expr] -> [Expr]
treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp))
treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))]
allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
Left $ map (compute pgf))),

40
src/compiler/GF/Compile.hs
View File

@@ -1,6 +1,6 @@
module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
import GF.Compile.GrammarToPGF(mkCanon2pgf)
import GF.Compile.GrammarToPGF(grammar2PGF)
import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
importsOfModule)
import GF.CompileOne(compileOne)
@@ -14,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
justModuleName,extendPathEnv,putStrE,putPointE)
import GF.Data.Operations(raise,(+++),err)
import Control.Monad(foldM,when,(<=<),filterM,liftM)
import Control.Monad(foldM,when,(<=<))
import GF.System.Directory(doesFileExist,getModificationTime)
import System.FilePath((</>),isRelative,dropFileName)
import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -22,8 +22,7 @@ import Data.List(nub)
import Data.Time(UTCTime)
import GF.Text.Pretty(render,($$),(<+>),nest)
import PGF.Internal(optimizePGF)
import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
import PGF2(PGF,readProbabilitiesFromFile)
-- | Compiles a number of source files and builds a 'PGF' structure for them.
-- This is a composition of 'link' and 'batchCompile'.
@@ -36,11 +35,10 @@ link :: Options -> (ModuleName,Grammar) -> IOE PGF
link opts (cnc,gr) =
putPointE Normal opts "linking ... " $ do
let abs = srcAbsName gr cnc
pgf <- mkCanon2pgf opts gr abs
probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
pgf <- grammar2PGF opts gr abs probs
when (verbAtLeast opts Normal) $ putStrE "OK"
return $ setProbabilities probs
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf
return pgf
-- | Returns the name of the abstract syntax corresponding to the named concrete syntax
srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
@@ -78,14 +76,10 @@ compileModule opts1 env@(_,rfs) file =
do file <- getRealFile file
opts0 <- getOptionsFromFile file
let curr_dir = dropFileName file
lib_dirs <- getLibraryDirectory (addOptions opts0 opts1)
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dirs opts0) opts1
-- putIfVerb opts $ "curr_dir:" +++ show curr_dir ----
-- putIfVerb opts $ "lib_dir:" +++ show lib_dirs ----
lib_dir <- getLibraryDirectory (addOptions opts0 opts1)
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
ps0 <- extendPathEnv opts
let ps = nub (curr_dir : ps0)
-- putIfVerb opts $ "options from file: " ++ show opts0
-- putIfVerb opts $ "augmented options: " ++ show opts
putIfVerb opts $ "module search path:" +++ show ps ----
files <- getAllFiles opts ps rfs file
putIfVerb opts $ "files to read:" +++ show files ----
@@ -98,17 +92,13 @@ compileModule opts1 env@(_,rfs) file =
if exists
then return file
else if isRelative file
then do
lib_dirs <- getLibraryDirectory opts1
let candidates = [ lib_dir </> file | lib_dir <- lib_dirs ]
putIfVerb opts1 (render ("looking for: " $$ nest 2 candidates))
file1s <- filterM doesFileExist candidates
case length file1s of
0 -> raise (render ("Unable to find: " $$ nest 2 candidates))
1 -> do return $ head file1s
_ -> do putIfVerb opts1 ("matched multiple candidates: " +++ show file1s)
return $ head file1s
else raise (render ("File" <+> file <+> "does not exist"))
then do lib_dir <- getLibraryDirectory opts1
let file1 = lib_dir </> file
exists <- doesFileExist file1
if exists
then return file1
else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
else raise (render ("File" <+> file <+> "does not exist."))
compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr

135
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -1,99 +1,110 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
module GF.Compile.CFGtoPGF (cf2pgf) where
import GF.Grammar.CFG
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Compile.OptimizePGF
import PGF
import PGF.Internal
import PGF2
import PGF2.Internal
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Array.IArray
import Data.List
import Data.Maybe(fromMaybe)
--------------------------
-- the compiler ----------
--------------------------
cf2pgf :: FilePath -> ParamCFG -> PGF
cf2pgf fpath cf =
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
in updateProductionIndices pgf
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
cf2pgf opts fpath cf probs =
build (let abstr = cf2abstr cf probs
in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
where
name = justModuleName fpath
aname = mkCId (name ++ "Abs")
cname = mkCId name
aname = name ++ "Abs"
cname = name
cf2abstr :: ParamCFG -> Abstr
cf2abstr cfg = Abstr aflags afuns acats
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
cf2abstr cfg probs = newAbstr aflags acats afuns
where
aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
[(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
| rule <- allRules cfg]
acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, [], toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
| rule <- allRules cfg
, let f' = mkRuleName rule]
cat2id = mkCId . fst
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
[(cat,[(f',Map.lookup f' probs)]) | rule <- allRules cfg,
let cat = cat2id (ruleLhs rule),
let f' = mkRuleName rule]
where
pad :: [(a,Maybe Double)] -> [(a,Double)]
pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
where
deflt = case length [f | (f,Nothing) <- pfs] of
0 -> 0
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
cf2concr :: ParamCFG -> Concr
cf2concr cfg = Concr Map.empty Map.empty
cncfuns lindefsrefs lindefsrefs
sequences productions
IntMap.empty Map.empty
cnccats
IntMap.empty
totalCats
toLogProb = realToFrac . negate . log
cat2id = fst
cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
cf2concr opts abstr cfg =
let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
(if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
(lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
in newConcr abstr [] []
lindefs' linrefs'
productions' cncfuns'
sequences' cnccats' totalCats
where
cats = allCats' cfg
rules = allRules cfg
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
map mkSequence rules)
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
idSeq = [SymCat 0 0]
idFun = CncFun wildCId (listArray (0,0) [seqid])
where
seq = listArray (0,0) [SymCat 0 0]
seqid = binSearch seq sequences (bounds sequences)
sequences0 = Set.fromList (idSeq :
map mkSequence rules)
sequences = Set.toList sequences0
idFun = ("_",[Set.findIndex idSeq sequences0])
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
cncfuns = reverse cncfuns0
lbls = listArray (0,0) ["s"]
(fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
[(c,p) | (c,ps) <- cats, p <- ps]
lbls = ["s"]
(fid,cnccats) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
[(c,p) | (c,ps) <- cats, p <- ps]
((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
cnccats = Map.fromList cnccats0
lindefsrefs =
IntMap.fromList (map mkLinDefRef cats)
lindefsrefs = map mkLinDefRef cats
convertRule cs (funid,funs) rule =
let args = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
prod = PApply funid args
seqid = binSearch (mkSequence rule) sequences (bounds sequences)
fun = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
seqid = Set.findIndex (mkSequence rule) sequences0
fun = (mkRuleName rule, [seqid])
funid' = funid+1
in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
mkSequence rule = listArray (0,length syms-1) syms
mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
where
syms = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
convertSymbol d (Terminal t) = (d, SymKS t)
mkCncCat fid (cat,n)
| cat == "Int" = (fid, (mkCId cat, CncCat fidInt fidInt lbls))
| cat == "Float" = (fid, (mkCId cat, CncCat fidFloat fidFloat lbls))
| cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
| cat == "Int" = (fid, (cat, fidInt, fidInt, lbls))
| cat == "Float" = (fid, (cat, fidFloat, fidFloat, lbls))
| cat == "String" = (fid, (cat, fidString, fidString, lbls))
| otherwise = let fid' = fid+n+1
in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
in fid' `seq` (fid', (cat, fid, fid+n, lbls))
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
mkCoercions (fid,cs) c@(cat,ps ) =
@@ -105,22 +116,13 @@ cf2concr cfg = Concr Map.empty Map.empty
addProd prods (fid,prod) =
case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.insert prod set) prods
Nothing -> IntMap.insert fid (Set.singleton prod) prods
binSearch v arr (i,j)
| i <= j = case compare v (arr ! k) of
LT -> binSearch v arr (i,k-1)
EQ -> k
GT -> binSearch v arr (k+1,j)
| otherwise = error "binSearch"
where
k = (i+j) `div` 2
Just set -> IntMap.insert fid (prod:set) prods
Nothing -> IntMap.insert fid [prod] prods
cat2fid cat p =
case Map.lookup (mkCId cat) cnccats of
Just (CncCat fid _ _) -> fid+p
_ -> error "cat2fid"
case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
(start:_) -> fid+p
_ -> error "cat2fid"
cat2arg c@(cat,[p]) = cat2fid cat p
cat2arg c@(cat,ps ) =
@@ -130,5 +132,6 @@ cf2concr cfg = Concr Map.empty Map.empty
mkRuleName rule =
case ruleName rule of
CFObj n _ -> n
_ -> wildCId
CFObj n _ -> n
_ -> "_"

77
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:33 $
-- > CVS $Date: 2005/11/11 23:24:33 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.31 $
--
@@ -21,15 +21,14 @@
-----------------------------------------------------------------------------
module GF.Compile.CheckGrammar(checkModule) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident
import GF.Infra.Option
import GF.Compile.TypeCheck.Abstract
import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
import GF.Compile.TypeCheck.RConcrete
import qualified GF.Compile.TypeCheck.ConcreteNew as CN
import qualified GF.Compile.Compute.ConcreteNew as CN
import GF.Grammar
import GF.Grammar.Lexer
@@ -74,9 +73,9 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
let incld c = Set.member c (Set.fromList incl)
let illegal c = Set.member c (Set.fromList excl)
let illegals = [(f,is) |
let illegals = [(f,is) |
(f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
case illegals of
case illegals of
[] -> return ()
cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
@@ -92,12 +91,12 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
-- check that all abstract constants are in concrete; build default lin and lincats
jsc <- foldM checkAbs jsc (Map.toList jsa)
return (cm,cnc{jments=jsc})
where
checkAbs js i@(c,info) =
case info of
AbsFun (Just (L loc ty)) _ _ _
AbsFun (Just (L loc ty)) _ _ _
-> do let mb_def = do
let (cxt,(_,i),_) = typeForm ty
info <- lookupIdent i js
@@ -136,11 +135,11 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
_ -> return js
checkCnc js (c,info) =
case info of
CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val)
return $ Map.insert c (CncFun (Just linty) d mn mf) js
@@ -159,14 +158,14 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
_ -> return $ Map.insert c info js
-- | General Principle: only Just-values are checked.
-- | General Principle: only Just-values are checked.
-- A May-value has always been checked in its origin module.
checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
checkReservedId c
case info of
AbsCat (Just (L loc cont)) ->
mkCheck loc "the category" $
AbsCat (Just (L loc cont)) ->
mkCheck loc "the category" $
checkContext gr cont
AbsFun (Just (L loc typ0)) ma md moper -> do
@@ -175,13 +174,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
checkTyp gr typ
case md of
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
checkDef gr (m,c) typ eq) eqs
checkDef gr (m,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
CncCat mty mdef mref mpr mpmcfg -> do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $
Just (L loc typ) -> chIn loc "linearization type of" $
(if False --flag optNewComp opts
then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
typ <- computeLType gr [] typ
@@ -191,19 +190,19 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
return (Just (L loc typ)))
Nothing -> return Nothing
mdef <- case (mty,mdef) of
(Just (L _ typ),Just (L loc def)) ->
(Just (L _ typ),Just (L loc def)) ->
chIn loc "default linearization of" $ do
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
return (Just (L loc def))
_ -> return Nothing
mref <- case (mty,mref) of
(Just (L _ typ),Just (L loc ref)) ->
(Just (L _ typ),Just (L loc ref)) ->
chIn loc "reference linearization of" $ do
(ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
return (Just (L loc ref))
_ -> return Nothing
mpr <- case mpr of
(Just (L loc t)) ->
(Just (L loc t)) ->
chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr
return (Just (L loc t))
@@ -212,13 +211,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
CncFun mty mt mpr mpmcfg -> do
mt <- case (mty,mt) of
(Just (cat,cont,val),Just (L loc trm)) ->
(Just (cat,cont,val),Just (L loc trm)) ->
chIn loc "linearization of" $ do
(trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
return (Just (L loc trm))
_ -> return mt
mpr <- case mpr of
(Just (L loc t)) ->
(Just (L loc t)) ->
chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr
return (Just (L loc t))
@@ -251,32 +250,44 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
ResOverload os tysts -> chIn NoLoc "overloading" $ do
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given
checkUniq $
checkUniq $
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
return (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (L loc pcs)) _ -> do
ts <- chIn loc "parameter type" $
liftM concat $ mapM mkPar pcs
return (ResParam (Just (L loc pcs)) (Just ts))
(vs,pcs) <- chIn loc "parameter type" $
mkParams 0 [] pcs
return (ResParam (Just (L loc pcs)) (Just vs))
ResValue (L loc ty) _ ->
chIn loc "operation" $ do
let (_,Cn x) = typeFormCnc ty
is = case Map.lookup x (jments mo) of
Just (ResParam (Just (L _ pcs)) _) -> [i | (f,_,i) <- pcs, f == c]
_ -> []
case is of
[i] -> return (ResValue (L loc ty) i)
_ -> checkError (pp "Failed to find the value index for parameter" <+> pp c)
_ -> return info
where
gr = prependModule sgr (m,mo)
chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
mkPar (f,co) = do
vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs
mkParams i vs [] = return (vs,[])
mkParams i vs ((f,co,_):pcs) = do
vs0 <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
(vs,pcs) <- mkParams (i + length vs0) (vs ++ map (mkApp (QC (m,f))) vs0) pcs
return (vs,(f,co,i):pcs)
checkUniq xss = case xss of
x:y:xs
x:y:xs
| x == y -> checkError $ "ambiguous for type" <+>
ppType (mkFunType (tail x) (head x))
ppType (mkFunType (tail x) (head x))
| otherwise -> checkUniq $ y:xs
_ -> return ()
@@ -294,7 +305,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
t' <- compAbsTyp ((x,Vr x):g) t
return $ Prod b x a' t'
Abs _ _ _ -> return t
_ -> composOp (compAbsTyp g) t
_ -> composOp (compAbsTyp g) t
-- | for grammars obtained otherwise than by parsing ---- update!!
@@ -316,7 +327,7 @@ linTypeOfType cnc m typ = do
mkLinArg (i,(n,mc@(m,cat))) = do
val <- lookLin mc
let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i
symb = argIdent n cat i
rec <- if n==0 then return val else
errIn (render ("extending" $$
nest 2 vars $$

143
src/compiler/GF/Compile/Compute/AppPredefined.hs Normal file
View File

@@ -0,0 +1,143 @@
----------------------------------------------------------------------
-- |
-- Module : AppPredefined
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/06 14:21:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module GF.Compile.Compute.AppPredefined ({-
isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined-}
) where
{-
import GF.Compile.TypeCheck.Primitives
import GF.Infra.Option
import GF.Data.Operations
import GF.Grammar
import GF.Grammar.Predef
import qualified Data.Map as Map
import GF.Text.Pretty
import Data.Char (isUpper,toUpper,toLower)
-- predefined function type signatures and definitions. AR 12/3/2003.
isInPredefined :: Ident -> Bool
isInPredefined f = Map.member f primitives
arrityPredefined :: Ident -> Maybe Int
arrityPredefined f = do ty <- typPredefined f
let (ctxt,_) = typeFormCnc ty
return (length ctxt)
predefModInfo :: SourceModInfo
predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
App f x0 -> do
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q (mod,f) | mod == cPredef ->
case x of
(K s) | f == cLength -> retb $ EInt $ length s
(K s) | f == cIsUpper -> retb $ if (all isUpper s) then predefTrue else predefFalse
(K s) | f == cToUpper -> retb $ K $ map toUpper s
(K s) | f == cToLower -> retb $ K $ map toLower s
(K s) | f == cError -> retb $ Error s
_ -> retb t
-- two-place functions
App (Q (mod,f)) z0 | mod == cPredef -> do
(z,_) <- appPredefined z0
case (norm z, norm x) of
(EInt i, K s) | f == cDrop -> retb $ K (drop i s)
(EInt i, K s) | f == cTake -> retb $ K (take i s)
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - i)) s)
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - i)) s)
(K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
(K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
(K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
(EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
(EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
(EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
(_, t) | f == cShow && notVar t -> retb $ foldrC $ map K $ words $ render (ppTerm Unqualified 0 t)
(_, K s) | f == cRead -> retb $ Cn (identS s) --- because of K, only works for atomic tags
(_, t) | f == cToStr -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t
-- three-place functions
App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (z, y, x) of
(ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
_ | f == cEqVal && notVar y && notVar x -> retb $ if y==x then predefTrue else predefFalse
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t
---- should really check the absence of arg variables
where
retb t = return (retc t,True) -- no further computing needed
retf t = return (retc t,False) -- must be computed further
retc t = case t of
K [] -> t
K s -> foldr1 C (map K (words s))
_ -> t
norm t = case t of
Empty -> K []
C u v -> case (norm u,norm v) of
(K x,K y) -> K (x +++ y)
_ -> t
_ -> t
notVar t = case t of
Vr _ -> False
App f a -> notVar f && notVar a
_ -> True ---- would need to check that t is a value
foldrC ts = if null ts then Empty else foldr1 C ts
-- read makes variables into constants
predefTrue = QC (cPredef,cPTrue)
predefFalse = QC (cPredef,cPFalse)
substring :: String -> String -> Bool
substring s t = case (s,t) of
(c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
([],_) -> True
_ -> False
trm2str :: Term -> Err Term
trm2str t = case t of
R ((_,(_,s)):_) -> trm2str s
T _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated
-- (this has been done in type checking)
mapStr :: Type -> Term -> Term -> Term
mapStr ty f t = case (ty,t) of
_ | elem ty [typeStr,typeTok] -> App f t
(_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
(Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
_ -> t
where
mapField (mty,te) = case mty of
Just ty -> (mty,mapStr ty f te)
_ -> (mty,te)
-}

593
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -1,590 +1,3 @@
-- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation.
module GF.Compile.Compute.Concrete
(GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
normalForm,
Value(..), Bind(..), Env, value2term, eval, vapply
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
import GF.Compile.Compute.Value hiding (Error)
import GF.Compile.Compute.Predef(predef,predefName,delta)
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
import GF.Data.Utilities(mapFst,mapSnd)
import GF.Infra.Option
import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
--import Data.Char (isUpper,toUpper,toLower)
import GF.Text.Pretty
import qualified Data.Map as Map
import Debug.Trace(trace)
-- * Main entry points
normalForm :: GlobalEnv -> L Ident -> Term -> Term
normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
nfx :: GlobalEnv -> Term -> Err Term
nfx env@(GE _ _ _ loc) t = do
v <- eval env [] t
return (value2term loc [] v)
-- Old value2term error message:
-- Left i -> fail ("variable #"++show i++" is out of scope")
eval :: GlobalEnv -> Env -> Term -> Err Value
eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
where
cenv = CE gr rvs opts loc (map fst env)
--apply env = apply' env
--------------------------------------------------------------------------------
-- * Environments
type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
data GlobalEnv = GE Grammar ResourceValues Options GLocation
data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
opts::Options,
gloc::GLocation,local::LocalScope}
type GLocation = L Ident
type LocalScope = [Ident]
type Stack = [Value]
type OpenValue = Stack->Value
geLoc (GE _ _ _ loc) = loc
geGrammar (GE gr _ _ _) = gr
ext b env = env{local=b:local env}
extend bs env = env{local=bs++local env}
global env = GE (srcgr env) (rvs env) (opts env) (gloc env)
var :: CompleteEnv -> Ident -> Err OpenValue
var env x = maybe unbound pick' (elemIndex x (local env))
where
unbound = fail ("Unknown variable: "++showIdent x)
pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs)
err i vs = bug $ "Stack problem: "++showIdent x++": "
++unwords (map showIdent (local env))
++" => "++show (i,length vs)
ok v = --trace ("var "++show x++" = "++show v) $
v
pick :: Int -> Stack -> Maybe Value
pick 0 (v:_) = Just v
pick i (_:vs) = pick (i-1) vs
pick i vs = Nothing -- bug $ "pick "++show (i,vs)
resource env (m,c) =
-- err bug id $
if isPredefCat c
then value0 env =<< lockRecType c defLinType -- hmm
else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
where e = fail $ "Not found: "++render m++"."++showIdent c
-- | Convert operators once, not every time they are looked up
resourceValues :: Options -> SourceGrammar -> GlobalEnv
resourceValues opts gr = env
where
env = GE gr rvs opts (L NoLoc identW)
rvs = Map.mapWithKey moduleResources (moduleMap gr)
moduleResources m = Map.mapWithKey (moduleResource m) . jments
moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
let loc = L l c
qloc = L l (Q (m,c))
eval (GE gr rvs opts loc) [] (traceRes qloc t)
traceRes = if flag optTrace opts
then traceResource
else const id
-- * Tracing
-- | Insert a call to the trace function under the top-level lambdas
traceResource (L l q) t =
case termFormCnc t of
(abs,body) -> mkAbs abs (mkApp traceQ [args,body])
where
args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
lstr = render (l<>":"<>ppTerm Qualified 0 q)
traceQ = Q (cPredef,cTrace)
-- * Computing values
-- | Computing the value of a top-level term
value0 :: CompleteEnv -> Term -> Err Value
value0 env = eval (global env) []
-- | Computing the value of a term
value :: CompleteEnv -> Term -> Err OpenValue
value env t0 =
-- Each terms is traversed only once by this function, using only statically
-- available information. Notably, the values of lambda bound variables
-- will be unknown during the term traversal phase.
-- The result is an OpenValue, which is a function that may be applied many
-- times to different dynamic values, but without the term traversal overhead
-- and without recomputing other statically known information.
-- For this to work, there should be no recursive calls under lambdas here.
-- Whenever we need to construct the OpenValue function with an explicit
-- lambda, we have to lift the recursive calls outside the lambda.
-- (See e.g. the rules for Let, Prod and Abs)
{-
trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
brackets (fsep (map ppIdent (local env))),
ppTerm Unqualified 10 t0]) $
--}
errIn (render t0) $
case t0 of
Vr x -> var env x
Q x@(m,f)
| m == cPredef -> if f==cErrorType -- to be removed
then let p = identS "P"
in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
else if f==cPBool
then const # resource env x
else const . flip VApp [] # predef f
| otherwise -> const # resource env x --valueResDef (fst env) x
QC x -> return $ const (VCApp x [])
App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
Let (x,(oty,t)) body -> do vb <- value (ext x env) body
vt <- value env t
return $ \ vs -> vb (vt vs:vs)
Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
Prod bt x t1 t2 ->
do vt1 <- value env t1
vt2 <- value (ext x env) t2
return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
Abs bt x t -> do vt <- value (ext x env) t
return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
EInt n -> return $ const (VInt n)
EFloat f -> return $ const (VFloat f)
K s -> return $ const (VString s)
Empty -> return $ const (VString "")
Sort s | s == cTok -> return $ const (VSort cStr) -- to be removed
| otherwise -> return $ const (VSort s)
ImplArg t -> (VImplArg.) # value env t
Table p res -> liftM2 VTblType # value env p <# value env res
RecType rs -> do lovs <- mapPairsM (value env) rs
return $ \vs->VRecType $ mapSnd ($vs) lovs
t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
FV ts -> ((vfv .) # sequence) # mapM (value env) ts
R as -> do lovs <- mapPairsM (value env.snd) as
return $ \ vs->VRec $ mapSnd ($vs) lovs
T i cs -> valueTable env i cs
V ty ts -> do pvs <- paramValues env ty
((VV ty pvs .) . sequence) # mapM (value env) ts
C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $
do ov <- value env t
return $ \ vs -> let v = ov vs
in maybe (VP v l) id (proj l v)
Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts
Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
ELin c r -> (unlockVRec (gloc env) c.) # value env r
EPatt p -> return $ const (VPatt p) -- hmm
EPattType ty -> do vt <- value env ty
return (VPattType . vt)
Typed t ty -> value env t
t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t
vconcat vv@(v1,v2) =
case vv of
(VString "",_) -> v2
(_,VString "") -> v1
(VApp NonExist _,_) -> v1
(_,VApp NonExist _) -> v2
_ -> VC v1 v2
proj l v | isLockLabel l = return (VRec [])
---- a workaround 18/2/2005: take this away and find the reason
---- why earlier compilation destroys the lock field
proj l v =
case v of
VFV vs -> liftM vfv (mapM (proj l) vs)
VRec rs -> lookup l rs
-- VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs
_ -> return (ok1 VP v l)
ok1 f v1@(VError {}) _ = v1
ok1 f v1 v2 = f v1 v2
ok2 f v1@(VError {}) _ = v1
ok2 f _ v2@(VError {}) = v2
ok2 f v1 v2 = f v1 v2
ok2p f (v1@VError {},_) = v1
ok2p f (_,v2@VError {}) = v2
ok2p f vv = f vv
unlockVRec loc c0 v0 = v0
{-
unlockVRec loc c0 v0 = unlockVRec' c0 v0
where
unlockVRec' ::Ident -> Value -> Value
unlockVRec' c v =
case v of
-- VClosure env t -> err bug (VClosure env) (unlockRecord c t)
VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v))
VRec rs -> plusVRec rs lock
-- _ -> VExtR v (VRec lock) -- hmm
_ -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm
-- _ -> bugloc loc $ "unlock non-record "++show v0
where
lock = [(lockLabel c,VRec [])]
-}
-- suspicious, but backwards compatible
plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
where ls2 = map fst rs2
extR t vv =
case vv of
(VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
(v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
(VRecType rs1, VRecType rs2) ->
case intersect (map fst rs1) (map fst rs2) of
[] -> VRecType (rs1 ++ rs2)
ls -> error $ "clash"<+>show ls
(VRec rs1, VRec rs2) -> plusVRec rs1 rs2
(v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
(VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
-- (v1,v2) -> ok2 VExtR v1 v2 -- hmm
(v1,v2) -> error $ "not records" $$ show v1 $$ show v2
where
error explain = ppbug $ "The term" <+> t
<+> "is not reducible" $$ explain
glue env (v1,v2) = glu v1 v2
where
glu v1 v2 =
case (v1,v2) of
(VFV vs,v2) -> vfv [glu v1 v2|v1<-vs]
(v1,VFV vs) -> vfv [glu v1 v2|v2<-vs]
(VString s1,VString s2) -> VString (s1++s2)
(v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
where glx v2 = glu v1 v2
(v1@(VAlts {}),v2) ->
--err (const (ok2 VGlue v1 v2)) id $
err bug id $
do y' <- strsFromValue v2
x' <- strsFromValue v1
return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
(VC va vb,v2) -> VC va (glu vb v2)
(v1,VC va vb) -> VC (glu v1 va) vb
(VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb
(v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb
(v1@(VApp NonExist _),_) -> v1
(_,v2@(VApp NonExist _)) -> v2
-- (v1,v2) -> ok2 VGlue v1 v2
(v1,v2) -> if flag optPlusAsBind (opts env)
then VC v1 (VC (VApp BIND []) v2)
else let loc = gloc env
vt v = value2term loc (local env) v
-- Old value2term error message:
-- Left i -> Error ('#':show i)
originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
(Glue (vt v1) (vt v2)))
term = render $ pp $ Glue (vt v1) (vt v2)
in error $ unlines
[originalMsg
,""
,"There was a problem in the expression `"++term++"`, either:"
,"1) You are trying to use + on runtime arguments, possibly via an oper."
,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive."
,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md"
]
-- | to get a string from a value that represents a sequence of terminals
strsFromValue :: Value -> Err [Str]
strsFromValue t = case t of
VString s -> return [str s]
VC s t -> do
s' <- strsFromValue s
t' <- strsFromValue t
return [plusStr x y | x <- s', y <- t']
{-
VGlue s t -> do
s' <- strsFromValue s
t' <- strsFromValue t
return [glueStr x y | x <- s', y <- t']
-}
VAlts d vs -> do
d0 <- strsFromValue d
v0 <- mapM (strsFromValue . fst) vs
c0 <- mapM (strsFromValue . snd) vs
--let vs' = zip v0 c0
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- sequence v0]
]
VFV ts -> concat # mapM strsFromValue ts
VStrs ts -> concat # mapM strsFromValue ts
_ -> fail ("cannot get Str from value " ++ show t)
vfv vs = case nub vs of
[v] -> v
vs -> VFV vs
select env vv =
case vv of
(v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
(VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
(v1@(VV pty vs rs),v2) ->
err (const (VS v1 v2)) id $
do --ats <- allParamValues (srcgr env) pty
--let vs = map (value0 env) ats
i <- maybeErr "no match" $ findIndex (==v2) vs
return (ix (gloc env) "select" rs i)
(VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
(v1@(VT _ _ cs),v2) ->
err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
match (gloc env) cs v2
(VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
(v1,v2) -> ok2 VS v1 v2
match loc cs v =
err bad return (matchPattern cs (value2term loc [] v))
-- Old value2term error message:
-- Left i -> bad ("variable #"++show i++" is out of scope")
where
bad = fail . ("In pattern matching: "++)
valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
valueTable env i cs =
case i of
TComp ty -> do pvs <- paramValues env ty
((VV ty pvs .) # sequence) # mapM (value env.snd) cs
_ -> do ty <- getTableType i
cs' <- mapM valueCase cs
err (dynamic cs' ty) return (convert cs' ty)
where
dynamic cs' ty _ = cases cs' # value env ty
cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
where
keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
VT wild (vty vs) (mapSnd ($vs) cs')
wild = case i of TWild _ -> True; _ -> False
convertv cs' vty =
convert' cs' =<< paramValues'' env (value2term (gloc env) [] vty)
-- Old value2term error message: Left i -> fail ("variable #"++show i++" is out of scope")
convert cs' ty = convert' cs' =<< paramValues' env ty
convert' cs' ((pty,vs),pvs) =
do sts <- mapM (matchPattern cs') vs
return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
(mapFst ($vs) sts)
valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
pvs <- linPattVars p'
vt <- value (extend pvs env) t
return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs))
inlinePattMacro p =
case p of
PM qc -> do r <- resource env qc
case r of
VPatt p' -> inlinePattMacro p'
_ -> ppbug $ hang "Expected pattern macro:" 4
(show r)
_ -> composPattOp inlinePattMacro p
paramValues env ty = snd # paramValues' env ty
paramValues' env ty = paramValues'' env =<< nfx (global env) ty
paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
pvs <- mapM (eval (global env) []) ats
return ((pty,ats),pvs)
push' p bs xs = if length bs/=length xs
then bug $ "push "++show (p,bs,xs)
else push bs xs
push :: Env -> LocalScope -> Stack -> Stack
push bs [] vs = vs
push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
where err = bug $ "Unbound pattern variable "++showIdent x
apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
apply' env t [] = value env t
apply' env t vs =
case t of
QC x -> return $ \ svs -> VCApp x (map ($svs) vs)
{-
Q x@(m,f) | m==cPredef -> return $
let constr = --trace ("predef "++show x) .
VApp x
in \ svs -> maybe constr id (Map.lookup f predefs)
$ map ($svs) vs
| otherwise -> do r <- resource env x
return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
-}
App t1 t2 -> apply' env t1 . (:vs) =<< value env t2
_ -> do fv <- value env t
return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
vapply :: GLocation -> Value -> [Value] -> Value
vapply loc v [] = v
vapply loc v vs =
case v of
VError {} -> v
-- VClosure env (Abs b x t) -> beta gr env b x t vs
VAbs bt _ (Bind f) -> vbeta loc bt f vs
VApp pre vs1 -> delta' pre (vs1++vs)
where
delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
in vtrace loc v1 vr
delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
--msg = const (VApp pre (vs1++vs))
msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
VFV fs -> vfv [vapply loc f vs|f<-fs]
VCApp f vs0 -> VCApp f (vs0++vs)
VMeta i env vs0 -> VMeta i env (vs0++vs)
VGen i vs0 -> VGen i (vs0++vs)
v -> bug $ "vapply "++show v++" "++show vs
vbeta loc bt f (v:vs) =
case (bt,v) of
(Implicit,VImplArg v) -> ap v
(Explicit, v) -> ap v
where
ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
ap v = vapply loc (f v) vs
vary (VFV vs) = vs
vary v = [v]
varyList = mapM vary
{-
beta env b x t (v:vs) =
case (b,v) of
(Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
(Explicit, v) -> apply' (ext (x,v) env) t vs
-}
vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
where
pv v = case v of
VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
_ -> ppV v
pf (_,VString n) = pp n
pf (_,v) = ppV v
pa (_,v) = ppV v
ppV v = ppTerm Unqualified 10 (value2term' True loc [] v)
-- Old value2term error message:
-- Left i -> "variable #" <> pp i <+> "is out of scope"
-- | Convert a value back to a term
value2term :: GLocation -> [Ident] -> Value -> Term
value2term = value2term' False
value2term' :: Bool -> p -> [Ident] -> Value -> Term
value2term' stop loc xs v0 =
case v0 of
VApp pre vs -> applyMany (Q (cPredef,predefName pre)) vs
VCApp f vs -> applyMany (QC f) vs
VGen j vs -> applyMany (var j) vs
VMeta j env vs -> applyMany (Meta j) vs
VProd bt v x f -> Prod bt x (v2t v) (v2t' x f)
VAbs bt x f -> Abs bt x (v2t' x f)
VInt n -> EInt n
VFloat f -> EFloat f
VString s -> if null s then Empty else K s
VSort s -> Sort s
VImplArg v -> ImplArg (v2t v)
VTblType p res -> Table (v2t p) (v2t res)
VRecType rs -> RecType [(l, v2t v) | (l,v) <- rs]
VRec as -> R [(l, (Nothing, v2t v)) | (l,v) <- as]
VV t _ vs -> V t (map v2t vs)
VT wild v cs -> T ((if wild then TWild else TTyped) (v2t v)) (map nfcase cs)
VFV vs -> FV (map v2t vs)
VC v1 v2 -> C (v2t v1) (v2t v2)
VS v1 v2 -> S (v2t v1) (v2t v2)
VP v l -> P (v2t v) l
VPatt p -> EPatt p
VPattType v -> EPattType $ v2t v
VAlts v vvs -> Alts (v2t v) [(v2t x, v2t y) | (x,y) <- vvs]
VStrs vs -> Strs (map v2t vs)
-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2)
-- VExtR v1 v2 -> ExtR (v2t v1) (v2t v2)
VError err -> Error err
where
applyMany f vs = foldl App f (map v2t vs)
v2t = v2txs xs
v2txs = value2term' stop loc
v2t' x f = v2txs (x:xs) (bind f (gen xs))
var j
| j<length xs = Vr (reverse xs !! j)
| otherwise = error ("variable #"++show j++" is out of scope")
pushs xs e = foldr push e xs
push x (env,xs) = ((x,gen xs):env,x:xs)
gen xs = VGen (length xs) []
nfcase (p,f) = (,) p (v2txs xs' (bind f env'))
where (env',xs') = pushs (pattVars p) ([],xs)
bind (Bind f) x = if stop
then VSort (identS "...") -- hmm
else f x
linPattVars p =
if null dups
then return pvs
else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p)
where
allpvs = allPattVars p
pvs = nub allpvs
dups = allpvs \\ pvs
pattVars = nub . allPattVars
allPattVars p =
case p of
PV i -> [i]
PAs i p -> i:allPattVars p
_ -> collectPattOp allPattVars p
---
ix loc fn xs i =
if i<n
then xs !! i
else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
where n = length xs
infixl 1 #,<# --,@@
f # x = fmap f x
mf <# mx = ap mf mx
--m1 @@ m2 = (m1 =<<) . m2
both f (x,y) = (,) # f x <# f y
bugloc loc s = ppbug $ ppL loc s
bug msg = ppbug msg
ppbug doc = error $ render $ hang "Internal error in Compute.Concrete:" 4 doc
module GF.Compile.Compute.Concrete{-(module M)-} where
--import GF.Compile.Compute.ConcreteLazy as M -- New
--import GF.Compile.Compute.ConcreteStrict as M -- Old, inefficient

579
src/compiler/GF/Compile/Compute/ConcreteNew.hs Normal file
View File

@@ -0,0 +1,579 @@
-- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation.
module GF.Compile.Compute.ConcreteNew
(GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
normalForm,
Value(..), Bind(..), Env, value2term, eval, vapply
) where
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
import GF.Compile.Compute.Value hiding (Error)
import GF.Compile.Compute.Predef(predef,predefName,delta)
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
import GF.Data.Operations(Err,err,errIn,maybeErr,combinations,mapPairsM)
import GF.Data.Utilities(mapFst,mapSnd)
import GF.Infra.Option
import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
--import Data.Char (isUpper,toUpper,toLower)
import GF.Text.Pretty
import qualified Data.Map as Map
import Debug.Trace(trace)
-- * Main entry points
normalForm :: GlobalEnv -> L Ident -> Term -> Term
normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
nfx env@(GE _ _ _ loc) t = do
v <- eval env [] t
case value2term loc [] v of
Left i -> fail ("variable #"++show i++" is out of scope")
Right t -> return t
eval :: GlobalEnv -> Env -> Term -> Err Value
eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
where
cenv = CE gr rvs opts loc (map fst env)
--apply env = apply' env
--------------------------------------------------------------------------------
-- * Environments
type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
data GlobalEnv = GE Grammar ResourceValues Options GLocation
data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
opts::Options,
gloc::GLocation,local::LocalScope}
type GLocation = L Ident
type LocalScope = [Ident]
type Stack = [Value]
type OpenValue = Stack->Value
geLoc (GE _ _ _ loc) = loc
geGrammar (GE gr _ _ _) = gr
ext b env = env{local=b:local env}
extend bs env = env{local=bs++local env}
global env = GE (srcgr env) (rvs env) (opts env) (gloc env)
var :: CompleteEnv -> Ident -> Err OpenValue
var env x = maybe unbound pick' (elemIndex x (local env))
where
unbound = fail ("Unknown variable: "++showIdent x)
pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs)
err i vs = bug $ "Stack problem: "++showIdent x++": "
++unwords (map showIdent (local env))
++" => "++show (i,length vs)
ok v = --trace ("var "++show x++" = "++show v) $
v
pick :: Int -> Stack -> Maybe Value
pick 0 (v:_) = Just v
pick i (_:vs) = pick (i-1) vs
pick i vs = Nothing -- bug $ "pick "++show (i,vs)
resource env (m,c) =
-- err bug id $
if isPredefCat c
then value0 env =<< lockRecType c defLinType -- hmm
else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
where e = fail $ "Not found: "++render m++"."++showIdent c
-- | Convert operators once, not every time they are looked up
resourceValues :: Options -> SourceGrammar -> GlobalEnv
resourceValues opts gr = env
where
env = GE gr rvs opts (L NoLoc identW)
rvs = Map.mapWithKey moduleResources (moduleMap gr)
moduleResources m = Map.mapWithKey (moduleResource m) . jments
moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
let loc = L l c
qloc = L l (Q (m,c))
eval (GE gr rvs opts loc) [] (traceRes qloc t)
traceRes = if flag optTrace opts
then traceResource
else const id
-- * Tracing
-- | Insert a call to the trace function under the top-level lambdas
traceResource (L l q) t =
case termFormCnc t of
(abs,body) -> mkAbs abs (mkApp traceQ [args,body])
where
args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
lstr = render (l<>":"<>ppTerm Qualified 0 q)
traceQ = Q (cPredef,cTrace)
-- * Computing values
-- | Computing the value of a top-level term
value0 :: CompleteEnv -> Term -> Err Value
value0 env = eval (global env) []
-- | Computing the value of a term
value :: CompleteEnv -> Term -> Err OpenValue
value env t0 =
-- Each terms is traversed only once by this function, using only statically
-- available information. Notably, the values of lambda bound variables
-- will be unknown during the term traversal phase.
-- The result is an OpenValue, which is a function that may be applied many
-- times to different dynamic values, but without the term traversal overhead
-- and without recomputing other statically known information.
-- For this to work, there should be no recursive calls under lambdas here.
-- Whenever we need to construct the OpenValue function with an explicit
-- lambda, we have to lift the recursive calls outside the lambda.
-- (See e.g. the rules for Let, Prod and Abs)
{-
trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
brackets (fsep (map ppIdent (local env))),
ppTerm Unqualified 10 t0]) $
--}
errIn (render t0) $
case t0 of
Vr x -> var env x
Q x@(m,f)
| m == cPredef -> if f==cErrorType -- to be removed
then let p = identS "P"
in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
else if f==cPBool
then const # resource env x
else const . flip VApp [] # predef f
| otherwise -> const # resource env x --valueResDef (fst env) x
QC x -> return $ const (VCApp x [])
App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
Let (x,(oty,t)) body -> do vb <- value (ext x env) body
vt <- value env t
return $ \ vs -> vb (vt vs:vs)
Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
Prod bt x t1 t2 ->
do vt1 <- value env t1
vt2 <- value (ext x env) t2
return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
Abs bt x t -> do vt <- value (ext x env) t
return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
EInt n -> return $ const (VInt n)
EFloat f -> return $ const (VFloat f)
K s -> return $ const (VString s)
Empty -> return $ const (VString "")
Sort s | s == cTok -> return $ const (VSort cStr) -- to be removed
| otherwise -> return $ const (VSort s)
ImplArg t -> (VImplArg.) # value env t
Table p res -> liftM2 VTblType # value env p <# value env res
RecType rs -> do lovs <- mapPairsM (value env) rs
return $ \vs->VRecType $ mapSnd ($vs) lovs
t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
FV ts -> ((vfv .) # sequence) # mapM (value env) ts
R as -> do lovs <- mapPairsM (value env.snd) as
return $ \ vs->VRec $ mapSnd ($vs) lovs
T i cs -> valueTable env i cs
V ty ts -> do pvs <- paramValues env ty
((VV ty pvs .) . sequence) # mapM (value env) ts
C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $
do ov <- value env t
return $ \ vs -> let v = ov vs
in maybe (VP v l) id (proj l v)
Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts
Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
ELin c r -> (unlockVRec (gloc env) c.) # value env r
EPatt p -> return $ const (VPatt p) -- hmm
EPattType ty -> do vt <- value env ty
return (VPattType . vt)
Typed t ty -> value env t
t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t
vconcat vv@(v1,v2) =
case vv of
(VString "",_) -> v2
(_,VString "") -> v1
(VApp NonExist _,_) -> v1
(_,VApp NonExist _) -> v2
_ -> VC v1 v2
proj l v | isLockLabel l = return (VRec [])
---- a workaround 18/2/2005: take this away and find the reason
---- why earlier compilation destroys the lock field
proj l v =
case v of
VFV vs -> liftM vfv (mapM (proj l) vs)
VRec rs -> lookup l rs
-- VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs
_ -> return (ok1 VP v l)
ok1 f v1@(VError {}) _ = v1
ok1 f v1 v2 = f v1 v2
ok2 f v1@(VError {}) _ = v1
ok2 f _ v2@(VError {}) = v2
ok2 f v1 v2 = f v1 v2
ok2p f (v1@VError {},_) = v1
ok2p f (_,v2@VError {}) = v2
ok2p f vv = f vv
unlockVRec loc c0 v0 = v0
{-
unlockVRec loc c0 v0 = unlockVRec' c0 v0
where
unlockVRec' ::Ident -> Value -> Value
unlockVRec' c v =
case v of
-- VClosure env t -> err bug (VClosure env) (unlockRecord c t)
VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v))
VRec rs -> plusVRec rs lock
-- _ -> VExtR v (VRec lock) -- hmm
_ -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm
-- _ -> bugloc loc $ "unlock non-record "++show v0
where
lock = [(lockLabel c,VRec [])]
-}
-- suspicious, but backwards compatible
plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
where ls2 = map fst rs2
extR t vv =
case vv of
(VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
(v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
(VRecType rs1, VRecType rs2) ->
case intersect (map fst rs1) (map fst rs2) of
[] -> VRecType (rs1 ++ rs2)
ls -> error $ "clash"<+>show ls
(VRec rs1, VRec rs2) -> plusVRec rs1 rs2
(v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
(VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
-- (v1,v2) -> ok2 VExtR v1 v2 -- hmm
(v1,v2) -> error $ "not records" $$ show v1 $$ show v2
where
error explain = ppbug $ "The term" <+> t
<+> "is not reducible" $$ explain
glue env (v1,v2) = glu v1 v2
where
glu v1 v2 =
case (v1,v2) of
(VFV vs,v2) -> vfv [glu v1 v2|v1<-vs]
(v1,VFV vs) -> vfv [glu v1 v2|v2<-vs]
(VString s1,VString s2) -> VString (s1++s2)
(v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
where glx v2 = glu v1 v2
(v1@(VAlts {}),v2) ->
--err (const (ok2 VGlue v1 v2)) id $
err bug id $
do y' <- strsFromValue v2
x' <- strsFromValue v1
return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
(VC va vb,v2) -> VC va (glu vb v2)
(v1,VC va vb) -> VC (glu v1 va) vb
(VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb
(v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb
(v1@(VApp NonExist _),_) -> v1
(_,v2@(VApp NonExist _)) -> v2
-- (v1,v2) -> ok2 VGlue v1 v2
(v1,v2) -> if flag optPlusAsBind (opts env)
then VC v1 (VC (VApp BIND []) v2)
else let loc = gloc env
vt v = case value2term loc (local env) v of
Left i -> Error ('#':show i)
Right t -> t
in error . render $
ppL loc (hang "unsupported token gluing:" 4
(Glue (vt v1) (vt v2)))
-- | to get a string from a value that represents a sequence of terminals
strsFromValue :: Value -> Err [Str]
strsFromValue t = case t of
VString s -> return [str s]
VC s t -> do
s' <- strsFromValue s
t' <- strsFromValue t
return [plusStr x y | x <- s', y <- t']
{-
VGlue s t -> do
s' <- strsFromValue s
t' <- strsFromValue t
return [glueStr x y | x <- s', y <- t']
-}
VAlts d vs -> do
d0 <- strsFromValue d
v0 <- mapM (strsFromValue . fst) vs
c0 <- mapM (strsFromValue . snd) vs
--let vs' = zip v0 c0
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- combinations v0]
]
VFV ts -> concat # mapM strsFromValue ts
VStrs ts -> concat # mapM strsFromValue ts
_ -> fail ("cannot get Str from value " ++ show t)
vfv vs = case nub vs of
[v] -> v
vs -> VFV vs
select env vv =
case vv of
(v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
(VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
(v1@(VV pty vs rs),v2) ->
err (const (VS v1 v2)) id $
do --ats <- allParamValues (srcgr env) pty
--let vs = map (value0 env) ats
i <- maybeErr "no match" $ findIndex (==v2) vs
return (ix (gloc env) "select" rs i)
(VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
(v1@(VT _ _ cs),v2) ->
err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
match (gloc env) cs v2
(VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
(v1,v2) -> ok2 VS v1 v2
match loc cs v =
case value2term loc [] v of
Left i -> bad ("variable #"++show i++" is out of scope")
Right t -> err bad return (matchPattern cs t)
where
bad = fail . ("In pattern matching: "++)
valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
valueTable env i cs =
case i of
TComp ty -> do pvs <- paramValues env ty
((VV ty pvs .) # sequence) # mapM (value env.snd) cs
_ -> do ty <- getTableType i
cs' <- mapM valueCase cs
err (dynamic cs' ty) return (convert cs' ty)
where
dynamic cs' ty _ = cases cs' # value env ty
cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
where
keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
VT wild (vty vs) (mapSnd ($vs) cs')
wild = case i of TWild _ -> True; _ -> False
convertv cs' vty =
case value2term (gloc env) [] vty of
Left i -> fail ("variable #"++show i++" is out of scope")
Right pty -> convert' cs' =<< paramValues'' env pty
convert cs' ty = convert' cs' =<< paramValues' env ty
convert' cs' ((pty,vs),pvs) =
do sts <- mapM (matchPattern cs') vs
return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
(mapFst ($vs) sts)
valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
pvs <- linPattVars p'
vt <- value (extend pvs env) t
return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs))
inlinePattMacro p =
case p of
PM qc -> do r <- resource env qc
case r of
VPatt p' -> inlinePattMacro p'
_ -> ppbug $ hang "Expected pattern macro:" 4
(show r)
_ -> composPattOp inlinePattMacro p
paramValues env ty = snd # paramValues' env ty
paramValues' env ty = paramValues'' env =<< nfx (global env) ty
paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
pvs <- mapM (eval (global env) []) ats
return ((pty,ats),pvs)
push' p bs xs = if length bs/=length xs
then bug $ "push "++show (p,bs,xs)
else push bs xs
push :: Env -> LocalScope -> Stack -> Stack
push bs [] vs = vs
push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
where err = bug $ "Unbound pattern variable "++showIdent x
apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
apply' env t [] = value env t
apply' env t vs =
case t of
QC x -> return $ \ svs -> VCApp x (map ($svs) vs)
{-
Q x@(m,f) | m==cPredef -> return $
let constr = --trace ("predef "++show x) .
VApp x
in \ svs -> maybe constr id (Map.lookup f predefs)
$ map ($svs) vs
| otherwise -> do r <- resource env x
return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
-}
App t1 t2 -> apply' env t1 . (:vs) =<< value env t2
_ -> do fv <- value env t
return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
vapply :: GLocation -> Value -> [Value] -> Value
vapply loc v [] = v
vapply loc v vs =
case v of
VError {} -> v
-- VClosure env (Abs b x t) -> beta gr env b x t vs
VAbs bt _ (Bind f) -> vbeta loc bt f vs
VApp pre vs1 -> delta' pre (vs1++vs)
where
delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
in vtrace loc v1 vr
delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
--msg = const (VApp pre (vs1++vs))
msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
VFV fs -> vfv [vapply loc f vs|f<-fs]
VCApp f vs0 -> VCApp f (vs0++vs)
VMeta i env vs0 -> VMeta i env (vs0++vs)
VGen i vs0 -> VGen i (vs0++vs)
v -> bug $ "vapply "++show v++" "++show vs
vbeta loc bt f (v:vs) =
case (bt,v) of
(Implicit,VImplArg v) -> ap v
(Explicit, v) -> ap v
where
ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
ap v = vapply loc (f v) vs
vary (VFV vs) = vs
vary v = [v]
varyList = mapM vary
{-
beta env b x t (v:vs) =
case (b,v) of
(Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
(Explicit, v) -> apply' (ext (x,v) env) t vs
-}
vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
where
pv v = case v of
VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
_ -> ppV v
pf (_,VString n) = pp n
pf (_,v) = ppV v
pa (_,v) = ppV v
ppV v = case value2term' True loc [] v of
Left i -> "variable #" <> pp i <+> "is out of scope"
Right t -> ppTerm Unqualified 10 t
-- | Convert a value back to a term
value2term :: GLocation -> [Ident] -> Value -> Either Int Term
value2term = value2term' False
value2term' stop loc xs v0 =
case v0 of
VApp pre vs -> liftM (foldl App (Q (cPredef,predefName pre))) (mapM v2t vs)
VCApp f vs -> liftM (foldl App (QC f)) (mapM v2t vs)
VGen j vs -> liftM2 (foldl App) (var j) (mapM v2t vs)
VMeta j env vs -> liftM (foldl App (Meta j)) (mapM v2t vs)
VProd bt v x f -> liftM2 (Prod bt x) (v2t v) (v2t' x f)
VAbs bt x f -> liftM (Abs bt x) (v2t' x f)
VInt n -> return (EInt n)
VFloat f -> return (EFloat f)
VString s -> return (if null s then Empty else K s)
VSort s -> return (Sort s)
VImplArg v -> liftM ImplArg (v2t v)
VTblType p res -> liftM2 Table (v2t p) (v2t res)
VRecType rs -> liftM RecType (mapM (\(l,v) -> fmap ((,) l) (v2t v)) rs)
VRec as -> liftM R (mapM (\(l,v) -> v2t v >>= \t -> return (l,(Nothing,t))) as)
VV t _ vs -> liftM (V t) (mapM v2t vs)
VT wild v cs -> v2t v >>= \t -> liftM (T ((if wild then TWild else TTyped) t)) (mapM nfcase cs)
VFV vs -> liftM FV (mapM v2t vs)
VC v1 v2 -> liftM2 C (v2t v1) (v2t v2)
VS v1 v2 -> liftM2 S (v2t v1) (v2t v2)
VP v l -> v2t v >>= \t -> return (P t l)
VPatt p -> return (EPatt p)
VPattType v -> v2t v >>= return . EPattType
VAlts v vvs -> liftM2 Alts (v2t v) (mapM (\(x,y) -> liftM2 (,) (v2t x) (v2t y)) vvs)
VStrs vs -> liftM Strs (mapM v2t vs)
-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2)
-- VExtR v1 v2 -> ExtR (v2t v1) (v2t v2)
VError err -> return (Error err)
_ -> bug ("value2term "++show loc++" : "++show v0)
where
v2t = v2txs xs
v2txs = value2term' stop loc
v2t' x f = v2txs (x:xs) (bind f (gen xs))
var j
| j<length xs = Right (Vr (reverse xs !! j))
| otherwise = Left j
pushs xs e = foldr push e xs
push x (env,xs) = ((x,gen xs):env,x:xs)
gen xs = VGen (length xs) []
nfcase (p,f) = liftM ((,) p) (v2txs xs' (bind f env'))
where (env',xs') = pushs (pattVars p) ([],xs)
bind (Bind f) x = if stop
then VSort (identS "...") -- hmm
else f x
linPattVars p =
if null dups
then return pvs
else fail.render $ hang "Pattern is not linear:" 4 (ppPatt Unqualified 0 p)
where
allpvs = allPattVars p
pvs = nub allpvs
dups = allpvs \\ pvs
pattVars = nub . allPattVars
allPattVars p =
case p of
PV i -> [i]
PAs i p -> i:allPattVars p
_ -> collectPattOp allPattVars p
---
ix loc fn xs i =
if i<n
then xs !! i
else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
where n = length xs
infixl 1 #,<# --,@@
f # x = fmap f x
mf <# mx = ap mf mx
--m1 @@ m2 = (m1 =<<) . m2
both f (x,y) = (,) # f x <# f y
bugloc loc s = ppbug $ ppL loc s
bug msg = ppbug msg
ppbug doc = error $ render $ hang "Internal error in Compute.ConcreteNew:" 4 doc

4
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -27,10 +27,6 @@ instance Predef Int where
instance Predef Bool where
toValue = boolV
fromValue v = case v of
VCApp (mn,i) [] | mn == cPredef && i == cPTrue -> return True
VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False
_ -> verror "Bool" v
instance Predef String where
toValue = string

10
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -1,6 +1,6 @@
module GF.Compile.Compute.Value where
import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
import PGF.Internal(BindType)
import PGF2(BindType)
import GF.Infra.Ident(Ident)
import Text.Show.Functions()
import Data.Ix(Ix)
@@ -12,8 +12,8 @@ data Value
| VGen Int [Value] -- for lambda bound variables, possibly applied
| VMeta MetaId Env [Value]
-- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
| VAbs BindType Ident Binding -- used in Compute.Concrete
| VProd BindType Value Ident Binding -- used in Compute.Concrete
| VAbs BindType Ident Binding -- used in Compute.ConcreteNew
| VProd BindType Value Ident Binding -- used in Compute.ConcreteNew
| VInt Int
| VFloat Double
| VString String
@@ -47,10 +47,10 @@ type Env = [(Ident,Value)]
-- | Predefined functions
data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
| ToLower | IsUpper | Length | Plus | EqInt | LessInt
| ToLower | IsUpper | Length | Plus | EqInt | LessInt
{- | Show | Read | ToStr | MapStr | EqVal -}
| Error | Trace
-- Canonical values below:
| PBool | PFalse | PTrue | Int | Float | Ints | NonExist
| PBool | PFalse | PTrue | Int | Float | Ints | NonExist
| BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
deriving (Show,Eq,Ord,Ix,Bounded,Enum)

47
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -7,7 +7,7 @@ import GF.Text.Pretty
--import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
import GF.Infra.Option
import GF.Haskell as H
import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
| let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs,
let ModId name = concName cncmod
filename = showRawIdent name ++ ".hs" :: FilePath
filename = name ++ ".hs" :: FilePath
]
-- | Generate Haskell code for the given concrete module.
@@ -53,7 +53,7 @@ concrete2haskell opts
labels = S.difference (S.unions (map S.fromList recs)) common_labels
common_records = S.fromList [[label_s]]
common_labels = S.fromList [label_s]
label_s = LabelId (rawIdentS "s")
label_s = LabelId "s"
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where
@@ -69,7 +69,7 @@ concrete2haskell opts
where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats]
gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent
@@ -116,7 +116,7 @@ concrete2haskell opts
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt)
-- TupleType lts ->
-- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
@@ -126,7 +126,7 @@ concrete2haskell opts
linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
linDef (LinDef f xs rhs0) =
linDef (LinDef f xs rhs0) =
(cat,(linfunName cat,(lhs,rhs)))
where
lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
where
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
@@ -187,7 +187,7 @@ concrete2haskell opts
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs =
if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
-- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t =
case (ty,t) of
case (ty,t) of
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) |
RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
(RecordType rt,VarValue x)->
case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -334,17 +334,18 @@ coerce env ty t =
_ -> t
where
app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
to_rcon = ParamId . Unqual . to_rcon' . labels
patVars p = []
labels r = [l | RecordRow l _ <- r]
labels r = [l|RecordRow l _<-r]
proj = Var . identS . proj'
proj' (LabelId l) = "proj_" ++ showRawIdent l
proj' (LabelId l) = "proj_"++l
rcon = Var . rcon'
rcon' = identS . rcon_name
rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
to_rcon' = ("to_"++) . rcon_name
recordType ls =
@@ -399,17 +400,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
instance ToIdent PredefId where toIdent (PredefId s) = identC s
instance ToIdent CatId where toIdent (CatId s) = identC s
instance ToIdent C.FunId where toIdent (FunId s) = identC s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
instance ToIdent PredefId where toIdent (PredefId s) = identS s
instance ToIdent CatId where toIdent (CatId s) = identS s
instance ToIdent C.FunId where toIdent (FunId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
qIdentC = identS . unqual
qIdentS = identS . unqual
unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
unqual (Unqual n) = showRawIdent n
unqual (Qual (ModId m) n) = m++"_"++n
unqual (Unqual n) = n
instance ToIdent VarId where
toIdent Anonymous = identW
toIdent (VarId s) = identC s
toIdent (VarId s) = identS s

35
src/compiler/GF/Compile/ExampleBased.hs
View File

@@ -3,11 +3,7 @@ module GF.Compile.ExampleBased (
configureExBased
) where
import PGF
--import PGF.Probabilistic
--import PGF.Morphology
--import GF.Compile.ToAPI
import PGF2
import Data.List
parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
@@ -37,47 +33,38 @@ convertFile conf src file = do
(ex, end) = break (=='"') (tail exend)
in ((unwords (words cat),ex), tail end) -- quotes ignored
pgf = resource_pgf conf
morpho = resource_morpho conf
lang = language conf
convEx (cat,ex) = do
appn "("
let typ = maybe (error "no valid cat") id $ readType cat
ws <- case fst (parse_ pgf lang typ (Just 4) ex) of
ParseFailed _ -> do
let ws = morphoMissing morpho (words ex)
ws <- case parse lang typ ex of
ParseFailed _ _ -> do
appv ("WARNING: cannot parse example " ++ ex)
case ws of
[] -> return ()
_ -> appv (" missing words: " ++ unwords ws)
return ws
TypeError _ ->
return []
ParseIncomplete ->
return []
ParseOk ts ->
case rank ts of
case ts of
(t:tt) -> do
if null tt
then return ()
else appv ("WARNING: ambiguous example " ++ ex)
appn t
mapM_ (appn . (" --- " ++)) tt
appn (printExp conf (fst t))
mapM_ (appn . (" --- " ++) . printExp conf . fst) tt
appn ")"
return []
return ws
rank ts = [printExp conf t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts]
appf = appendFile file
appn s = appf s >> appf "\n"
appv s = appn ("--- " ++ s) >> putStrLn s
data ExConfiguration = ExConf {
resource_pgf :: PGF,
resource_morpho :: Morpho,
resource_pgf :: PGF,
verbose :: Bool,
language :: Language,
printExp :: Tree -> String
language :: Concr,
printExp :: Expr -> String
}
configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr
configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
configureExBased pgf concr pr = ExConf pgf False concr pr

25
src/compiler/GF/Compile/Export.hs
View File

@@ -1,14 +1,10 @@
module GF.Compile.Export where
import PGF
import PGF.Internal(ppPGF)
import PGF2
import GF.Compile.PGFtoHaskell
--import GF.Compile.PGFtoAbstract
import GF.Compile.PGFtoJava
import GF.Compile.PGFtoProlog
import GF.Compile.PGFtoJS
import GF.Compile.PGFtoJSON
import GF.Compile.PGFtoPython
import GF.Infra.Option
--import GF.Speech.CFG
import GF.Speech.PGFToCFG
@@ -22,6 +18,7 @@ import GF.Speech.SLF
import GF.Speech.PrRegExp
import Data.Maybe
import qualified Data.Map as Map
import System.FilePath
import GF.Text.Pretty
@@ -35,15 +32,12 @@ exportPGF :: Options
-> [(FilePath,String)] -- ^ List of recommended file names and contents.
exportPGF opts fmt pgf =
case fmt of
FmtPGFPretty -> multi "txt" (render . ppPGF)
FmtPGFPretty -> multi "txt" (showPGF)
FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
FmtCanonicalJson-> []
FmtJavaScript -> multi "js" pgf2js
FmtJSON -> multi "json" pgf2json
FmtPython -> multi "py" pgf2python
FmtHaskell -> multi "hs" (grammar2haskell opts name)
FmtJava -> multi "java" (grammar2java opts name)
FmtProlog -> multi "pl" grammar2prolog
FmtBNF -> single "bnf" bnfPrinter
FmtEBNF -> single "ebnf" (ebnfPrinter opts)
FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts)
@@ -57,20 +51,13 @@ exportPGF opts fmt pgf =
FmtRegExp -> single "rexp" regexpPrinter
FmtFA -> single "dot" slfGraphvizPrinter
where
name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
name = fromMaybe (abstractName pgf) (flag optName opts)
multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)]
-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]
-- | Get the name of the concrete syntax to generate output from.
-- FIXME: there should be an option to change this.
outputConcr :: PGF -> CId
outputConcr pgf = case languages pgf of
[] -> error "No concrete syntax."
cnc:_ -> cnc

27
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -1,10 +1,10 @@
{-# LANGUAGE CPP #-}
module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
import GF.Data.Operations
import PGF(CId,utf8CId)
import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import qualified Data.Map as Map
import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe)
@@ -63,7 +63,7 @@ compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty
case_instr t =
case t of
(Q (_,id)) -> CASE (i2i id)
(Q (_,id)) -> CASE (showIdent id)
(EInt n) -> CASE_LIT (LInt n)
(K s) -> CASE_LIT (LStr s)
(EFloat d) -> CASE_LIT (LFlt d)
@@ -105,7 +105,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
compileFun gr eval st vs (Q (m,id)) h0 bs args =
case lookupAbsDef gr m id of
Ok (_,Just _)
-> (h0,bs,eval st (GLOBAL (i2i id)) args)
-> (h0,bs,eval st (GLOBAL (showIdent id)) args)
_ -> let Ok ty = lookupFunType gr m id
(ctxt,_,_) = typeForm ty
c_arity = length ctxt
@@ -114,14 +114,14 @@ compileFun gr eval st vs (Q (m,id)) h0 bs args =
diff = c_arity-n_args
in if diff <= 0
then if n_args == 0
then (h0,bs,eval st (GLOBAL (i2i id)) [])
then (h0,bs,eval st (GLOBAL (showIdent id)) [])
else let h1 = h0 + 2 + n_args
in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
in (h1,bs,PUT_CONSTR (showIdent id):is1++eval st (HEAP h0) [])
else let h1 = h0 + 1 + n_args
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
b = CHECK_ARGS diff :
ALLOC (c_arity+2) :
PUT_CONSTR (i2i id) :
PUT_CONSTR (showIdent id) :
is2 ++
TUCK (ARG_VAR 0) diff :
EVAL (HEAP h0) (TailCall diff) :
@@ -167,16 +167,16 @@ compileFun gr eval st vs e _ _ _ = error (show e)
compileArg gr st vs (Q(m,id)) h0 bs =
case lookupAbsDef gr m id of
Ok (_,Just _) -> (h0,bs,GLOBAL (i2i id),[])
Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
_ -> let Ok ty = lookupFunType gr m id
(ctxt,_,_) = typeForm ty
c_arity = length ctxt
in if c_arity == 0
then (h0,bs,GLOBAL (i2i id),[])
then (h0,bs,GLOBAL (showIdent id),[])
else let is2 = [SET (ARG_VAR (i+1)) | i <- [0..c_arity-1]]
b = CHECK_ARGS c_arity :
ALLOC (c_arity+2) :
PUT_CONSTR (i2i id) :
PUT_CONSTR (showIdent id) :
is2 ++
TUCK (ARG_VAR 0) c_arity :
EVAL (HEAP h0) (TailCall c_arity) :
@@ -224,12 +224,12 @@ compileArg gr st vs e h0 bs =
diff = c_arity-n_args
in if diff <= 0
then let h2 = h1 + 2 + n_args
in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (i2i id) : is2))
in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent id) : is2))
else let h2 = h1 + 1 + n_args
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
b = CHECK_ARGS diff :
ALLOC (c_arity+2) :
PUT_CONSTR (i2i id) :
PUT_CONSTR (showIdent id) :
is2 ++
TUCK (ARG_VAR 0) diff :
EVAL (HEAP h0) (TailCall diff) :
@@ -298,9 +298,6 @@ freeVars xs (Vr x)
| not (elem x xs) = [x]
freeVars xs e = collectOp (freeVars xs) e
i2i :: Ident -> CId
i2i = utf8CId . ident2utf8
push_is :: Int -> Int -> [IVal] -> [IVal]
push_is i 0 is = is
push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is

71
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -13,8 +13,9 @@ module GF.Compile.GeneratePMCFG
(generatePMCFG, pgfCncCat, addPMCFG, resourceValues
) where
--import PGF.CId
import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
import qualified PGF2 as PGF2
import qualified PGF2.Internal as PGF2
import PGF2.Internal(Symbol(..),fidVar)
import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -25,7 +26,7 @@ import GF.Data.BacktrackM
import GF.Data.Operations
import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
@@ -41,7 +42,6 @@ import Control.Monad
import Control.Monad.Identity
--import Control.Exception
--import Debug.Trace(trace)
import qualified Control.Monad.Fail as Fail
----------------------------------------------------------------------
-- main conversion function
@@ -69,7 +69,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
@@ -82,7 +82,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
(goB b1 CNil [])
(pres,pargs)
pmcfg = getPMCFG pmcfgEnv1
stats = let PMCFG prods funs = pmcfg
(s,e) = bounds funs
!prods_cnt = length prods
@@ -93,7 +93,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
seqs1 `seq` stats `seq` return ()
when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
return (seqs1,CncFun mty mlin mprn (Just pmcfg))
where
(ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
@@ -103,11 +103,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (MN identW,cVar) typeStr
@@ -132,7 +132,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
let pmcfg = getPMCFG pmcfgEnv2
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
where
addLindef lins (newCat', newArgs') env0 =
let [newCat] = getFIds newCat'
@@ -158,12 +158,15 @@ convert opts gr cenv loc term ty@(_,val) pargs =
args = map Vr vars
vars = map (\(bt,x,t) -> x) context
pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
pgfCncCat gr lincat index =
pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
pgfCncCat gr id lincat index =
let ((_,size),schema) = computeCatRange gr lincat
in PGF.CncCat index (index+size-1)
(mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
(getStrPaths schema)))
in ( id
, index
, index+size-1
, map (renderStyle style{mode=OneLineMode} . ppPath)
(getStrPaths schema)
)
where
getStrPaths :: Schema Identity s c -> [Path]
getStrPaths = collect CNil []
@@ -197,9 +200,6 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar
-> ([ProtoFCat],[Symbol])
-> Branch b}
instance Fail.MonadFail CnvMonad where
fail = bug
instance Applicative CnvMonad where
pure = return
(<*>) = ap
@@ -243,7 +243,7 @@ choices nr path = do (args,_) <- get
| (value,index) <- values])
descend schema path rpath = bug $ "descend "++show (schema,path,rpath)
updateEnv path value gr c (args,seq) =
updateEnv path value gr c (args,seq) =
case updateNthM (restrictProtoFCat path value) nr args of
Just args -> c value (args,seq)
Nothing -> bug "conflict in updateEnv"
@@ -475,7 +475,7 @@ goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss
----------------------------------------------------------------------
-- SeqSet
type SeqSet = Map.Map Sequence SeqId
type SeqSet = Map.Map [Symbol] SeqId
addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
@@ -504,13 +504,11 @@ mapAccumL' f s (x:xs) = (s'',y:ys)
!(s'',ys) = mapAccumL' f s' xs
addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
addSequence seqs lst =
addSequence seqs seq =
case Map.lookup seq seqs of
Just id -> (seqs,id)
Nothing -> let !last_seq = Map.size seqs
in (Map.insert seq last_seq seqs, last_seq)
where
seq = mkArray lst
------------------------------------------------------------
@@ -606,7 +604,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
Just index -> return (CPar (m,[(v,index)]))
Nothing -> mzero
addConstraint CNil v (CStr _) = bug "restrictProtoFCat: string path"
update k0 f [] = return []
update k0 f (x@(k,Identity v):xs)
| k0 == k = do v <- f v
@@ -618,23 +616,6 @@ mkArray lst = listArray (0,length lst-1) lst
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
bug msg = ppbug msg
ppbug msg = error completeMsg
where
originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
completeMsg =
case render msg of -- the error message for pattern matching a runtime string
"descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
-> unlines [originalMsg -- add more helpful output
,""
,"1) Check that you are not trying to pattern match a /runtime string/."
," These are illegal:"
," lin Test foo = case foo.s of {"
," \"str\" => … } ; <- explicit matching argument of a lin"
," lin Test foo = opThatMatches foo <- calling an oper that pattern matches"
,""
,"2) Not about pattern matching? Submit a bug report and we update the error message."
," https://github.com/GrammaticalFramework/gf-core/issues"
]
_ -> originalMsg -- any other message: just print it as is
ppbug msg = error . render $ hang "Internal error in GeneratePMCFG:" 4 msg
ppU = ppTerm Unqualified

15
src/compiler/GF/Compile/GetGrammar.hs
View File

@@ -50,20 +50,13 @@ getSourceModule opts file0 =
Right (i,mi0) ->
do liftIO $ removeTemp tmp
let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
case (optCoding,optCoding') of
{-
(Nothing,Nothing) ->
unless (BS.all isAscii raw) $
ePutStrLn $ file0++":\n Warning: default encoding has changed from Latin-1 to UTF-8"
-}
(_,Just coding') ->
when (coding/=coding') $
case renameEncoding `fmap` flag optEncoding (mflags mi0) of
Just coding' ->
when (coding/=coding') $
raise $ "Encoding mismatch: "++coding++" /= "++coding'
where coding = maybe defaultEncoding renameEncoding optCoding
_ -> return ()
--liftIO $ transcodeModule' (i,mi) -- old lexer
return (i,mi) -- new lexer
return (i,mi)
getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
getBNFCRules opts fpath = do

146
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -6,35 +6,30 @@ module GF.Compile.GrammarToCanonical(
) where
import Data.List(nub,partition)
import qualified Data.Map as M
import Data.Maybe(fromMaybe)
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Text.Pretty
import GF.Grammar.Grammar as G
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(Options,optionsPGF)
import PGF.Internal(Literal(..))
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
import GF.Infra.Option(optionsPGF)
import PGF2.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>))
import qualified Debug.Trace as T
import Debug.Trace
-- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes
grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
grammar2canonical opts absname gr =
Grammar (abstract2canonical absname gr)
(map snd (concretes2canonical opts absname gr))
-- | Generate Canonical code for the named abstract syntax
abstract2canonical :: ModuleName -> G.Grammar -> Abstract
abstract2canonical absname gr =
Abstract (modId absname) (convFlags gr absname) cats funs
where
@@ -49,7 +44,6 @@ abstract2canonical absname gr =
convHypo (bt,name,t) =
case typeForm t of
([],(_,cat),[]) -> gId cat -- !!
tf -> error $ "abstract2canonical convHypo: " ++ show tf
convType t =
case typeForm t of
@@ -60,26 +54,25 @@ abstract2canonical absname gr =
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
-- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
let cncname = "canonical" </> render cnc <.> "gf"
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
Ok cncmod = lookupModule gr cnc
]
-- | Generate Canonical GF for the given concrete module.
concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical gr cenv absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs))
[lincat | (_,Left lincat) <- defs]
[lin | (_,Right lin) <- defs]
[lincat|(_,Left lincat)<-defs]
[lin|(_,Right lin)<-defs]
where
defs = concatMap (toCanonical gr absname cenv) .
defs = concatMap (toCanonical gr absname cenv) .
M.toList $
jments modinfo
@@ -92,7 +85,6 @@ concrete2canonical gr cenv absname cnc modinfo =
else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
toCanonical gr absname cenv (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -105,8 +97,7 @@ toCanonical gr absname cenv (name,jment) =
where
tts = tableTypes gr [e']
e' = cleanupRecordFields lincat $
unAbs (length params) $
e' = unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,x)|(b,x,_)<-ctx]
args = map snd params
@@ -117,12 +108,12 @@ toCanonical gr absname cenv (name,jment) =
_ -> []
where
nf loc = normalForm cenv (L loc name)
-- aId n = prefixIdent "A." (gId n)
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t
tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
tableTypes gr ts = S.unions (map tabtys ts)
where
tabtys t =
@@ -131,7 +122,6 @@ tableTypes gr ts = S.unions (map tabtys ts)
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t
paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -150,26 +140,11 @@ paramTypes gr t =
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
ignore = T.trace ("Ignore: " ++ show t) S.empty
ignore = trace ("Ignore: "++show t) S.empty
-- | Filter out record fields from definitions which don't appear in lincat.
cleanupRecordFields :: G.Type -> Term -> Term
cleanupRecordFields (RecType ls) (R as) =
let defnFields = M.fromList ls
in R
[ (lbl, (mty, t'))
| (lbl, (mty, t)) <- as
, M.member lbl defnFields
, let Just ty = M.lookup lbl defnFields
, let t' = cleanupRecordFields ty t
]
cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
cleanupRecordFields _ t = t
convert :: G.Grammar -> Term -> LinValue
convert gr = convert' gr []
convert' :: G.Grammar -> [Ident] -> Term -> LinValue
convert' gr vs = ppT
where
ppT0 = convert' gr vs
@@ -187,20 +162,20 @@ convert' gr vs = ppT
S t p -> selection (ppT t) (ppT p)
C t1 t2 -> concatValue (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a)
R r -> RecordValue (fields (sortRec r))
R r -> RecordValue (fields r)
P t l -> projection (ppT t) (lblId l)
Vr x -> VarValue (gId x)
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> LiteralValue (IntConstant n)
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
QC (m,n) -> ParamConstant (Param (gQId m n) [])
Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
K s -> LiteralValue (StrConstant s)
Empty -> LiteralValue (StrConstant "")
FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' ppT: " ++ show t
_ -> error $ "convert' "++show t
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
@@ -213,12 +188,12 @@ convert' gr vs = ppT
Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gQId cPredef n) -- hmm
where
p = PredefValue . PredefId . rawIdentS
p = PredefValue . PredefId
ppP p =
case p of
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
PR r -> RecordPattern (fields r) {-
PW -> WildPattern
PV x -> VarP x
@@ -227,7 +202,6 @@ convert' gr vs = ppT
PFloat x -> Lit (show x)
PT _ p -> ppP p
PAs x p -> AsP x (ppP p) -}
_ -> error $ "convert' ppP: " ++ show p
where
fields = map field . filter (not.isLockLabel.fst)
field (l,p) = RecordRow (lblId l) (ppP p)
@@ -244,12 +218,12 @@ convert' gr vs = ppT
pre Empty = [""] -- Empty == K ""
pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p
pre t = error $ "convert' alts pre: " ++ show t
pre t = error $ "pre "++show t
pat (PString s) = [s]
pat (PAlt p1 p2) = pat p1++pat p2
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
pat p = error $ "convert' alts pat: "++show p
pat p = error $ "pat "++show p
fields = map field . filter (not.isLockLabel.fst)
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -262,7 +236,6 @@ convert' gr vs = ppT
ParamConstant (Param p (ps++[a]))
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
concatValue :: LinValue -> LinValue -> LinValue
concatValue v1 v2 =
case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2
@@ -270,24 +243,21 @@ concatValue v1 v2 =
_ -> ConcatValue v1 v2
-- | Smart constructor for projections
projection :: LinValue -> LabelId -> LinValue
projection r l = fromMaybe (Projection r l) (proj r l)
projection r l = maybe (Projection r l) id (proj r l)
proj :: LinValue -> LabelId -> Maybe LinValue
proj r l =
case r of
RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
[v] -> Just v
_ -> Nothing
_ -> Nothing
-- | Smart constructor for selections
selection :: LinValue -> LinValue -> LinValue
selection t v =
-- Note: impossible cases can become possible after grammar transformation
case t of
TableValue tt r ->
case nub [rv | TableRow _ rv <- keep] of
case nub [rv|TableRow _ rv<-keep] of
[rv] -> rv
_ -> Selection (TableValue tt r') v
where
@@ -306,16 +276,13 @@ selection t v =
(keep,discard) = partition (mightMatchRow v) r
_ -> Selection t v
impossible :: LinValue -> LinValue
impossible = CommentedValue "impossible"
mightMatchRow :: LinValue -> TableRow rhs -> Bool
mightMatchRow v (TableRow p _) =
case p of
WildPattern -> True
_ -> mightMatch v p
mightMatch :: LinValue -> LinPattern -> Bool
mightMatch v p =
case v of
ConcatValue _ _ -> False
@@ -327,18 +294,16 @@ mightMatch v p =
RecordValue rv ->
case p of
RecordPattern rp ->
and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
_ -> False
_ -> True
patVars :: Patt -> [Ident]
patVars p =
case p of
PV x -> [x]
PAs x p -> x:patVars p
_ -> collectPattOp patVars p
convType :: Term -> LinType
convType = ppT
where
ppT t =
@@ -350,9 +315,9 @@ convType = ppT
Sort k -> convSort k
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> ParamType (ParamTypeId (gQId m n))
Q (m,n) -> ParamType (ParamTypeId (gQId m n))
_ -> error $ "convType ppT: " ++ show t
QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
_ -> error $ "Missing case in convType for: "++show t
convFields = map convField . filter (not.isLockLabel.fst)
convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -361,20 +326,15 @@ convType = ppT
"Float" -> FloatType
"Int" -> IntType
"Str" -> StrType
_ -> error $ "convType convSort: " ++ show k
_ -> error ("convSort "++show k)
toParamType :: Term -> ParamType
toParamType t = case convType t of
ParamType pt -> pt
_ -> error $ "toParamType: " ++ show t
_ -> error ("toParamType "++show t)
toParamId :: Term -> ParamId
toParamId t = case toParamType t of
ParamTypeId p -> p
paramType :: G.Grammar
-> (ModuleName, Ident)
-> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
paramType gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
@@ -382,7 +342,7 @@ paramType gr q@(_,n) =
((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)]
)
where name = gQId m n
where name = (gQId m n)
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.empty,S.empty),[]) {-
@@ -390,46 +350,36 @@ paramType gr q@(_,n) =
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[ParamAliasDef (gQId m n) (convType t)])
[ParamAliasDef ((gQId m n)) (convType t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
param m (n,ctx,_) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
argTypes1 (n,ctx,_) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
lblId :: Label -> C.LabelId
lblId (LIdent ri) = LabelId ri
lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
lblId = LabelId . render -- hmm
modId (MN m) = ModId (showIdent m)
modId :: ModuleName -> C.ModId
modId (MN m) = ModId (ident2raw m)
class FromIdent i where
gId :: Ident -> i
class FromIdent i where gId :: Ident -> i
instance FromIdent VarId where
gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
instance FromIdent C.FunId where gId = C.FunId . ident2raw
instance FromIdent CatId where gId = CatId . ident2raw
instance FromIdent C.FunId where gId = C.FunId . showIdent
instance FromIdent CatId where gId = CatId . showIdent
instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . unqual
class FromIdent i => QualIdent i where
gQId :: ModuleName -> Ident -> i
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
qual :: ModuleName -> Ident -> QualId
qual m n = Qual (modId m) (ident2raw n)
qual m n = Qual (modId m) (showIdent n)
unqual n = Unqual (showIdent n)
unqual :: Ident -> QualId
unqual n = Unqual (ident2raw n)
convFlags :: G.Grammar -> ModuleName -> Flags
convFlags gr mn =
Flags [(rawIdentS n,convLit v) |
Flags [(n,convLit v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where
convLit l =

399
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -1,17 +1,14 @@
{-# LANGUAGE BangPatterns, FlexibleContexts #-}
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts, MagicHash #-}
module GF.Compile.GrammarToPGF (grammar2PGF) where
--import GF.Compile.Export
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import GF.Compile.OptimizePGF
import PGF(CId,mkCId,utf8CId)
import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
import PGF.Internal(updateProductionIndices)
import qualified PGF.Internal as C
import qualified PGF.Internal as D
import PGF2 hiding (mkType)
import PGF2.Internal
import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.Grammar hiding (Production)
import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM
@@ -22,111 +19,141 @@ import GF.Infra.UseIO (IOE)
import GF.Data.Operations
import Data.List
import Data.Char
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Array.IArray
import Data.Maybe(fromMaybe)
import GHC.Prim
import GHC.Base(getTag)
mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
mkCanon2pgf opts gr am = do
(an,abs) <- mkAbstr am
cncs <- mapM mkConcr (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts gr am probs = do
cnc_infos <- getConcreteInfos gr am
return $
build (let gflags = if flag optSplitPGF opts
then [("split", LStr "true")]
else []
(an,abs) = mkAbstr am probs
cncs = map (mkConcr opts abs) cnc_infos
in newPGF gflags an abs cncs)
where
cenv = resourceValues opts gr
aflags = err (const noOptions) mflags (lookupModule gr am)
mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map PGF2.Fun Double -> (AbsName, B s AbstrInfo)
mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
where
aflags = err (const noOptions) mflags (lookupModule gr am)
adefs =
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
flags = optionsPGF aflags
funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) |
toLogProb = realToFrac . negate . log
cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
let arity = mkArity ma mdef ty]
let arity = mkArity ma mdef ty,
let bcode = mkDef gr arity mdef,
let f' = i2i f]
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
[(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
let (_,(_,cat),_) = GM.typeForm ty,
let f' = i2i f]
where
pad :: [(a,Maybe Double)] -> [(a,Double)]
pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
where
deflt = case length [f | (f,Nothing) <- pfs] of
0 -> 0
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
((m,c),AbsCat (Just (L _ cont))) <- adefs]
catfuns cat =
[(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
mkConcr cm = do
mkConcr opts abs (cm,ex_seqs,cdefs) =
let cflags = err (const noOptions) mflags (lookupModule gr cm)
ciCmp | flag optCaseSensitive cflags = compare
| otherwise = C.compareCaseInsensitve
| otherwise = compareCaseInsensitive
(ex_seqs,cdefs) <- addMissingPMCFGs
Map.empty
([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
Look.allOrigInfos gr cm)
flags = optionsPGF aflags
let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
seqs = (mkArray . C.sortNubBy ciCmp . concat) $
(Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
seqs = (mkSetArray . Set.fromList . concat) $
(elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
!(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
= genCncFuns gr am cm ex_seqs_arr ciCmp seqs cdefs fid_cnt1 cnccats
= genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
printnames = genPrintNames cdefs
return (mi2i cm, D.Concr flags
printnames
cncfuns
lindefs
linrefs
seqs
productions
IntMap.empty
Map.empty
cnccats
IntMap.empty
fid_cnt2)
startCat = (fromMaybe "S" (flag optStartCat aflags))
(lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
(if flag optOptimizePGF opts then optimizePGF startCat else id)
(lindefs,linrefs,productions,cncfuns,elems seqs,cnccats)
in (mi2i cm, newConcr abs
flags
printnames
lindefs'
linrefs'
productions'
cncfuns'
sequences'
cnccats'
fid_cnt2)
getConcreteInfos gr am = mapM flatten (allConcretes gr am)
where
flatten cm = do
(seqs,infos) <- addMissingPMCFGs cm Map.empty
(lit_infos ++ Look.allOrigInfos gr cm)
return (cm,mkMapArray seqs :: Array SeqId [Symbol],infos)
lit_infos = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]]
-- if some module was compiled with -no-pmcfg, then
-- we have to create the PMCFG code just before linking
addMissingPMCFGs seqs [] = return (seqs,[])
addMissingPMCFGs seqs (((m,id), info):is) = do
(seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
(seqs,is ) <- addMissingPMCFGs seqs is
return (seqs, ((m,id), info) : is)
addMissingPMCFGs cm seqs [] = return (seqs,[])
addMissingPMCFGs cm seqs (((m,id), info):is) = do
(seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
(seqs,infos) <- addMissingPMCFGs cm seqs is
return (seqs, ((m,id), info) : infos)
i2i :: Ident -> CId
i2i = utf8CId . ident2utf8
i2i :: Ident -> String
i2i = showIdent
mi2i :: ModuleName -> CId
mi2i :: ModuleName -> String
mi2i (MN i) = i2i i
mkType :: [Ident] -> A.Type -> C.Type
mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF2.Type
mkType scope t =
case GM.typeForm t of
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
in dTyp hyps' (i2i cat) (map (mkExp scope') args)
mkExp :: [Ident] -> A.Term -> C.Expr
mkExp scope t =
mkExp :: (?builder :: Builder s) => [Ident] -> A.Term -> B s Expr
mkExp scope t =
case t of
Q (_,c) -> C.EFun (i2i c)
QC (_,c) -> C.EFun (i2i c)
Q (_,c) -> eFun (i2i c)
QC (_,c) -> eFun (i2i c)
Vr x -> case lookup x (zip scope [0..]) of
Just i -> C.EVar i
Nothing -> C.EMeta 0
Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
EInt i -> C.ELit (C.LInt (fromIntegral i))
EFloat f -> C.ELit (C.LFlt f)
K s -> C.ELit (C.LStr s)
Meta i -> C.EMeta i
_ -> C.EMeta 0
Just i -> eVar i
Nothing -> eMeta 0
Abs b x t-> eAbs b (i2i x) (mkExp (x:scope) t)
App t1 t2-> eApp (mkExp scope t1) (mkExp scope t2)
EInt i -> eLit (LInt (fromIntegral i))
EFloat f -> eLit (LFlt f)
K s -> eLit (LStr s)
Meta i -> eMeta i
_ -> eMeta 0
{-
mkPatt scope p =
case p of
A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
@@ -141,67 +168,64 @@ mkPatt scope p =
A.PImplArg p-> let (scope',p') = mkPatt scope p
in (scope',C.PImplArg p')
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
-}
mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF2.Hypo])
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
in if x == identW
then ( scope,(bt,i2i x,ty'))
else (x:scope,(bt,i2i x,ty'))) scope hyps
then ( scope,hypo bt (i2i x) ty')
else (x:scope,hypo bt (i2i x) ty')) scope hyps
mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
,generateByteCode gr arity eqs
)
mkDef gr arity Nothing = Nothing
mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
mkDef gr arity Nothing = []
mkArity (Just a) _ ty = a -- known arity, i.e. defined function
mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom
mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor
in length ctxt
genCncCats gr am cm cdefs =
let (index,cats) = mkCncCats 0 cdefs
in (index, Map.fromList cats)
genCncCats gr am cm cdefs = mkCncCats 0 cdefs
where
mkCncCats index [] = (index,[])
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs)
| id == cInt =
let cc = pgfCncCat gr lincat fidInt
let cc = pgfCncCat gr (i2i id) lincat fidInt
(index',cats) = mkCncCats index cdefs
in (index', (i2i id,cc) : cats)
in (index', cc : cats)
| id == cFloat =
let cc = pgfCncCat gr lincat fidFloat
let cc = pgfCncCat gr (i2i id) lincat fidFloat
(index',cats) = mkCncCats index cdefs
in (index', (i2i id,cc) : cats)
in (index', cc : cats)
| id == cString =
let cc = pgfCncCat gr lincat fidString
let cc = pgfCncCat gr (i2i id) lincat fidString
(index',cats) = mkCncCats index cdefs
in (index', (i2i id,cc) : cats)
in (index', cc : cats)
| otherwise =
let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
(index',cats) = mkCncCats (e+1) cdefs
in (index', (i2i id,cc) : cats)
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
let cc@(_, _s, e, _) = pgfCncCat gr (i2i id) lincat index
(index',cats) = mkCncCats (e+1) cdefs
in (index', cc : cats)
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
genCncFuns :: Grammar
-> ModuleName
-> ModuleName
-> Array SeqId Sequence
-> (Sequence -> Sequence -> Ordering)
-> Array SeqId Sequence
-> Array SeqId [Symbol]
-> ([Symbol] -> [Symbol] -> Ordering)
-> Array SeqId [Symbol]
-> [(QIdent, Info)]
-> FId
-> Map.Map CId D.CncCat
-> Map.Map PGF2.Cat (Int,Int)
-> (FId,
IntMap.IntMap (Set.Set D.Production),
IntMap.IntMap [FunId],
IntMap.IntMap [FunId],
Array FunId D.CncFun)
genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
[(FId, [Production])],
[(FId, [FunId])],
[(FId, [FunId])],
[(PGF2.Fun,[SeqId])])
genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty
(fid_cnt2,funs_cnt2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
(fid_cnt2,funs_cnt2,funs2,prods0) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
prods = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
in (fid_cnt2,prods,IntMap.toList lindefs,IntMap.toList linrefs,reverse funs2)
where
mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs =
mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs =
(fid_cnt,funs_cnt,funs,lindefs,linrefs)
mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
@@ -210,17 +234,16 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
linrefs' = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods =
(fid_cnt,funs_cnt,funs,prods)
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
let ---Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id)
ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
let ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
!funs_cnt' = let (s_funid, e_funid) = bounds funs0
in funs_cnt+(e_funid-s_funid+1)
!(fid_cnt',crc',prods')
!(fid_cnt',crc',prods')
= foldl' (toProd lindefs ty_C funs_cnt)
(fid_cnt,crc,prods) prods0
funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
@@ -228,23 +251,23 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods =
mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
set0 = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
toProd lindefs (ctxt_C,res_C,_) offs st (A.Production fid0 funid0 args0) =
let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
set0 = Set.fromList (map (PApply (offs+funid0)) (sequence args))
fid = mkFId res_C fid0
!prods' = case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.union set0 set) prods
Nothing -> IntMap.insert fid set0 prods
in (fid_cnt,crc,prods')
where
mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
case fid0s of
[fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
[fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
fid0s -> case Map.lookup fids crc of
Just fid -> (st,map (flip C.PArg fid) ctxt)
Just fid -> (st,map (flip PArg fid) ctxt)
Nothing -> let !crc' = Map.insert fids fid_cnt crc
!prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
!prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
where
(hargs_C,arg_C) = GM.catSkeleton ty
ctxt = mapM (mkCtxt lindefs) hargs_C
@@ -252,14 +275,14 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
mkLinDefId id = prefixIdent "lindef " id
toLinDef res offs lindefs (Production fid0 funid0 args) =
toLinDef res offs lindefs (A.Production fid0 funid0 args) =
if args == [[fidVar]]
then IntMap.insertWith (++) fid [offs+funid0] lindefs
else lindefs
where
fid = mkFId res fid0
toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
if fid0 == fidVar
then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
else linrefs
@@ -267,20 +290,20 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
fids = map (mkFId res) fargs
mkFId (_,cat) fid0 =
case Map.lookup (i2i cat) cnccats of
Just (C.CncCat s e _) -> s+fid0
Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
case Map.lookup (i2i cat) cnccat_ranges of
Just (s,e) -> s+fid0
Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
mkCtxt lindefs (_,cat) =
case Map.lookup (i2i cat) cnccats of
Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
Nothing -> error "GrammarToPGF.mkCtxt failed"
case Map.lookup (i2i cat) cnccat_ranges of
Just (s,e) -> [(fid,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
Nothing -> error "GrammarToPGF.mkCtxt failed"
toCncFun offs (m,id) funs (funid0,lins0) =
let mseqs = case lookupModule gr m of
Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
_ -> ex_seqs
in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs
in (i2i id, map (newIndex mseqs) (elems lins0)):funs
where
newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
@@ -293,8 +316,9 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
where
k = (i+j) `div` 2
genPrintNames cdefs =
Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
[(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
where
prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
@@ -306,3 +330,118 @@ genPrintNames cdefs =
mkArray lst = listArray (0,length lst-1) lst
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
-- The following is a version of Data.List.sortBy which together
-- with the sorting also eliminates duplicate values
sortNubBy cmp = mergeAll . sequences
where
sequences (a:b:xs) =
case cmp a b of
GT -> descending b [a] xs
EQ -> sequences (b:xs)
LT -> ascending b (a:) xs
sequences xs = [xs]
descending a as [] = [a:as]
descending a as (b:bs) =
case cmp a b of
GT -> descending b (a:as) bs
EQ -> descending a as bs
LT -> (a:as) : sequences (b:bs)
ascending a as [] = let !x = as [a]
in [x]
ascending a as (b:bs) =
case cmp a b of
GT -> let !x = as [a]
in x : sequences (b:bs)
EQ -> ascending a as bs
LT -> ascending b (\ys -> as (a:ys)) bs
mergeAll [x] = x
mergeAll xs = mergeAll (mergePairs xs)
mergePairs (a:b:xs) = let !x = merge a b
in x : mergePairs xs
mergePairs xs = xs
merge as@(a:as') bs@(b:bs') =
case cmp a b of
GT -> b:merge as bs'
EQ -> a:merge as' bs'
LT -> a:merge as' bs
merge [] bs = bs
merge as [] = as
-- The following function does case-insensitive comparison of sequences.
-- This is used to allow case-insensitive parsing, while
-- the linearizer still has access to the original cases.
compareCaseInsensitive [] [] = EQ
compareCaseInsensitive [] _ = LT
compareCaseInsensitive _ [] = GT
compareCaseInsensitive (x:xs) (y:ys) =
case compareSym x y of
EQ -> compareCaseInsensitive xs ys
x -> x
where
compareSym s1 s2 =
case s1 of
SymCat d1 r1
-> case s2 of
SymCat d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> LT
SymLit d1 r1
-> case s2 of
SymCat {} -> GT
SymLit d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> LT
SymVar d1 r1
-> if tagToEnum# (getTag s2 ># 2#)
then LT
else case s2 of
SymVar d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> GT
SymKS t1
-> if tagToEnum# (getTag s2 ># 3#)
then LT
else case s2 of
SymKS t2 -> t1 `compareToken` t2
_ -> GT
SymKP a1 b1
-> if tagToEnum# (getTag s2 ># 4#)
then LT
else case s2 of
SymKP a2 b2
-> case compare a1 a2 of
EQ -> b1 `compare` b2
x -> x
_ -> GT
_ -> let t1 = getTag s1
t2 = getTag s2
in if tagToEnum# (t1 <# t2)
then LT
else if tagToEnum# (t1 ==# t2)
then EQ
else GT
compareToken [] [] = EQ
compareToken [] _ = LT
compareToken _ [] = GT
compareToken (x:xs) (y:ys)
| x == y = compareToken xs ys
| otherwise = case compare (toLower x) (toLower y) of
EQ -> case compareToken xs ys of
EQ -> compare x y
x -> x
x -> x

16
src/compiler/GF/Compile/Optimize.hs
View File

@@ -6,7 +6,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/16 13:56:13 $
-- > CVS $Date: 2005/09/16 13:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.18 $
--
@@ -21,7 +21,7 @@ import GF.Grammar.Printer
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
import GF.Data.Operations
import GF.Infra.Option
@@ -90,7 +90,7 @@ evalInfo opts resenv sgr m c info = do
let ppr' = fmap (evalPrintname resenv c) ppr
return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
{-
ResOper pty pde
ResOper pty pde
| not new && OptExpand `Set.member` optim -> do
pde' <- case pde of
Just (L loc de) -> do de <- computeConcrete gr de
@@ -171,13 +171,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
_ -> Bad (render ("linearization type field cannot be" <+> typ))
mkLinReference :: SourceGrammar -> Type -> Err Term
mkLinReference gr typ =
liftM (Abs Explicit varStr) $
mkLinReference gr typ =
liftM (Abs Explicit varStr) $
case mkDefField typ (Vr varStr) of
Bad "no string" -> return Empty
x -> x
where
mkDefField ty trm =
mkDefField ty trm =
case ty of
Table pty ty -> do ps <- allParamValues gr pty
case ps of
@@ -203,7 +203,7 @@ factor param c i t =
T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
_ -> composSafeOp (factor param c i) t
where
factors ty pvs0
factors ty pvs0
| not param = V ty (map snd pvs0)
factors ty [] = V ty []
factors ty pvs0@[(p,v)] = V ty [v]
@@ -224,7 +224,7 @@ factor param c i t =
replace :: Term -> Term -> Term -> Term
replace old new trm =
case trm of
-- these are the important cases, since they can correspond to patterns
-- these are the important cases, since they can correspond to patterns
QC _ | trm == old -> new
App _ _ | trm == old -> new
R _ | trm == old -> new

189
src/compiler/GF/Compile/OptimizePGF.hs Normal file
View File

@@ -0,0 +1,189 @@
{-# LANGUAGE BangPatterns #-}
module GF.Compile.OptimizePGF(optimizePGF) where
import PGF2(Cat,Fun)
import PGF2.Internal
import Data.Array.ST
import Data.Array.Unboxed
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntSet as IntSet
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Control.Monad.ST
type ConcrData = ([(FId,[FunId])], -- ^ Lindefs
[(FId,[FunId])], -- ^ Linrefs
[(FId,[Production])], -- ^ Productions
[(Fun,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
[[Symbol]], -- ^ Sequences (must be sorted)
[(Cat,FId,FId,[String])]) -- ^ Concrete categories
optimizePGF :: Cat -> ConcrData -> ConcrData
optimizePGF startCat = topDownFilter startCat . bottomUpFilter
catString = "String"
catInt = "Int"
catFloat = "Float"
catVar = "__gfVar"
topDownFilter :: Cat -> ConcrData -> ConcrData
topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
let env0 = (Map.empty,Map.empty)
(env1,lindefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
env0
lindefs
(env2,linrefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fidVar [PArg [] fid]) env funids in (env',(fid,funids')))
env1
linrefs
(env3,prods') = List.mapAccumL (\env (fid,set) -> let (env',set') = List.mapAccumL (optimizeProd fid) env set in (env',(fid,set')))
env2
prods
cnccats' = map filterCatLabels cnccats
(sequences',cncfuns') = env3
in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray sequences',cnccats')
where
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (Fun, [SeqId])
sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
prods_map = IntMap.fromList prods
fid2catMap = IntMap.fromList ((fidVar,catVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
fid <- [start..end]])
fid2cat fid =
case IntMap.lookup fid fid2catMap of
Just cat -> cat
Nothing -> case [fid | Just set <- [IntMap.lookup fid prods_map], PCoerce fid <- set] of
(fid:_) -> fid2cat fid
_ -> error "unknown forest id"
starts =
[(startCat,lbl) | (cat,_,_,lbls) <- cnccats, cat==startCat, lbl <- [0..length lbls-1]]
allRelations =
Map.unionsWith Set.union
[rel fid prod | (fid,set) <- prods, prod <- set]
where
rel fid (PApply funid args) = Map.fromList [((fid2cat fid,lbl),deps args seqid) | (lbl,seqid) <- zip [0..] lin]
where
(_,lin) = cncfuns_array ! funid
rel fid _ = Map.empty
deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- seq]
where
seq = sequences_array ! seqid
-- here we create a mapping from a category to an array of indices.
-- An element of the array is equal to -1 if the corresponding index
-- is not going to be used in the optimized grammar, or the new index
-- if it will be used
closure :: Map.Map Cat [Int]
closure = runST $ do
set <- initSet
addLitCat catString set
addLitCat catInt set
addLitCat catFloat set
addLitCat catVar set
closureSet set starts
doneSet set
where
initSet :: ST s (Map.Map Cat (STUArray s Int Int))
initSet =
fmap Map.fromList $ sequence
[fmap ((,) cat) (newArray (0,length lbls-1) (-1))
| (cat,_,_,lbls) <- cnccats]
addLitCat cat set =
case Map.lookup cat set of
Just indices -> writeArray indices 0 0
Nothing -> return ()
closureSet set [] = return ()
closureSet set (x@(cat,index):xs) =
case Map.lookup cat set of
Just indices -> do v <- readArray indices index
writeArray indices index 0
if v < 0
then case Map.lookup x allRelations of
Just ys -> closureSet set (Set.toList ys++xs)
Nothing -> closureSet set xs
else closureSet set xs
Nothing -> error "unknown cat"
doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int])
doneSet set =
fmap Map.fromAscList $ mapM done (Map.toAscList set)
where
done (cat,indices) = do
indices <- fmap (reindex 0) (getElems indices)
return (cat,indices)
reindex k [] = []
reindex k (v:vs)
| v < 0 = v : reindex k vs
| otherwise = k : reindex (k+1) vs
optimizeProd res env (PApply funid args) =
let (env',funid') = optimizeFun res args env funid
in (env', PApply funid' args)
optimizeProd res env prod = (env,prod)
optimizeFun res args (seqs,funs) funid =
let (seqs',lin') = List.mapAccumL addUnique seqs [map updateSymbol (sequences_array ! seqid) |
(idx,seqid) <- zip (indicesOf res) lin, idx >= 0]
(funs',funid') = addUnique funs (fun, lin')
in ((seqs',funs'), funid')
where
(fun,lin) = cncfuns_array ! funid
indicesOf fid
| fid < 0 = [0]
| otherwise =
case Map.lookup (fid2cat fid) closure of
Just indices -> indices
Nothing -> error "unknown category"
addUnique seqs seq =
case Map.lookup seq seqs of
Just seqid -> (seqs,seqid)
Nothing -> let seqid = Map.size seqs
in (Map.insert seq seqid seqs, seqid)
updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid !! d)
updateSymbol s = s
filterCatLabels (cat,start,end,lbls) =
case Map.lookup cat closure of
Just indices -> let lbls' = [lbl | (idx,lbl) <- zip indices lbls, idx >= 0]
in (cat,start,end,lbls')
Nothing -> error ("unknown category")
mkSetArray map = sortSnd (Map.toList map)
where
sortSnd = List.map fst . List.sortBy (\(_,i) (_,j) -> compare i j)
bottomUpFilter :: ConcrData -> ConcrData
bottomUpFilter (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
(lindefs,linrefs,filterProductions IntMap.empty IntSet.empty prods,cncfuns,sequences,cnccats)
filterProductions prods0 hoc0 prods
| prods0 == prods1 = IntMap.toList prods0
| otherwise = filterProductions prods1 hoc1 prods
where
(prods1,hoc1) = foldl foldProdSet (IntMap.empty,IntSet.empty) prods
foldProdSet (!prods,!hoc) (fid,set)
| null set1 = (prods,hoc)
| otherwise = (IntMap.insert fid set1 prods,hoc1)
where
set1 = filter filterRule set
hoc1 = foldl accumHOC hoc set1
filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
filterRule (PCoerce fid) = isLive fid
filterRule _ = True
isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
accumHOC hoc _ = hoc

196
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
@@ -16,71 +16,61 @@
module GF.Compile.PGFtoHaskell (grammar2haskell) where
import PGF(showCId)
import PGF.Internal
import PGF2
import PGF2.Internal
import GF.Data.Operations
import GF.Infra.Option
import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
import Data.List
import Data.Maybe(mapMaybe)
import qualified Data.Map as Map
type Prefix = String -> String
type DerivingClause = String
-- | the main function
grammar2haskell :: Options
-> String -- ^ Module name.
-> PGF
-> String
grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
[types, gfinstances gId lexical gr'] ++ compos
grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos
where gr' = hSkeleton gr
gadt = haskellOption opts HaskellGADT
dataExt = haskellOption opts HaskellData
pgf2 = haskellOption opts HaskellPGF2
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
| otherwise = ("G"++) . rmForbiddenChars
-- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~")
pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
| dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"]
gId | haskellOption opts HaskellNoPrefix = id
| otherwise = ("G"++)
pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"]
| otherwise = []
derivingClause
| dataExt = "deriving (Show,Data)"
| otherwise = "deriving Show"
extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
| dataExt = ["import Data.Data"]
| otherwise = []
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
| otherwise = ["import PGF hiding (Tree)"]
types | gadt = datatypesGADT gId lexical gr'
| otherwise = datatypes gId derivingClause lexical gr'
| otherwise = datatypes gId lexical gr'
compos | gadt = prCompos gId lexical gr' ++ composClass
| otherwise = []
haskPreamble :: Bool -> String -> String -> [String] -> [String]
haskPreamble gadt name derivingClause imports =
haskPreamble gadt name =
[
"module " ++ name ++ " where",
""
] ++ imports ++ [
"",
] ++
(if gadt then [
"import Control.Monad.Identity",
"import Data.Monoid"
] else []) ++
[
"import PGF hiding (Tree)",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
"",
"",
"class Gf a where",
" gf :: a -> Expr",
" fg :: Expr -> a",
"",
predefInst gadt derivingClause "GString" "String" "unStr" "mkStr",
predefInst gadt "GString" "String" "unStr" "mkStr",
"",
predefInst gadt derivingClause "GInt" "Int" "unInt" "mkInt",
predefInst gadt "GInt" "Int" "unInt" "mkInt",
"",
predefInst gadt derivingClause "GFloat" "Double" "unFloat" "mkFloat",
predefInst gadt "GFloat" "Double" "unFloat" "mkFloat",
"",
"----------------------------------------------------",
"-- below this line machine-generated",
@@ -88,12 +78,11 @@ haskPreamble gadt name derivingClause imports =
""
]
predefInst :: Bool -> String -> String -> String -> String -> String -> String
predefInst gadt derivingClause gtyp typ destr consr =
predefInst gadt gtyp typ destr consr =
(if gadt
then []
else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
)
then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n")
)
++
"instance Gf" +++ gtyp +++ "where" ++++
" gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
@@ -106,24 +95,24 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype _ _ _ ("Cn",_) = "" ---
hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+++ derivingClause
hDatatype gId derivingClause lexical (cat,rules) =
hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype _ _ ("Cn",_) = "" ---
hDatatype gId _ (cat,[]) = "data" +++ gId cat
hDatatype gId _ (cat,rules) | isListCat (cat,rules) =
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+++ "deriving Show"
hDatatype gId lexical (cat,rules) =
"data" +++ gId cat +++ "=" ++
(if length rules == 1 then "" else "\n ") +++
foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
" " +++ derivingClause
" deriving Show"
where
constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
@@ -135,17 +124,16 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
lexicalConstructor :: OIdent -> String
lexicalConstructor cat = "Lex" ++ cat
predefTypeSkel :: HSkeleton
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
-- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypesGADT gId lexical (_,skel) = unlines $
datatypesGADT gId lexical (_,skel) = unlines $
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
[
"",
[
"",
"data Tree :: * -> * where"
] ++
] ++
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
[
" GString :: String -> Tree GString_",
@@ -169,23 +157,23 @@ hCatTypeGADT gId (cat,rules)
"data"+++gId cat++"_"]
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hDatatypeGADT gId lexical (cat, rules)
hDatatypeGADT gId lexical (cat, rules)
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise =
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
| (f,args) <- nonLexicalRules (lexical cat) rules ]
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
where t = "Tree" +++ gId cat ++ "_"
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hEqGADT gId lexical (cat, rules)
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
| otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
where
patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
(x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
listr c = (c,["foo"]) -- foo just for length = 1
listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -194,26 +182,25 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
prCompos gId lexical (_,catrules) =
["instance Compos Tree where",
" compos r a f t = case t of"]
++
++
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
(f,xs) <- rs, not (null xs)]
++
(f,xs) <- rs, not (null xs)]
++
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
++
++
[" _ -> r t"]
where
prComposCons f xs = let vs = mkVars (length xs) in
prComposCons f xs = let vs = mkVars (length xs) in
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
prRec f (v,c)
prRec f (v,c)
| isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
| otherwise = "`a`" +++ "f" +++ v
isList f = gId "List" `isPrefixOf` f
isList f = (gId "List") `isPrefixOf` f
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance gId _ m (cat,[]) = unlines [
"instance Show" +++ gId cat,
@@ -222,15 +209,15 @@ hInstance gId _ m (cat,[]) = unlines [
" gf _ = undefined",
" fg _ = undefined"
]
hInstance gId lexical m (cat,rules)
hInstance gId lexical m (cat,rules)
| isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++
" gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
" gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
" gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
-- no show for GADTs
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
| otherwise =
"instance Gf" +++ gId cat +++ "where\n" ++
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -239,26 +226,23 @@ hInstance gId lexical m (cat,rules)
ec = elemCat cat
baseVars = mkVars (baseSize (cat,rules))
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
(if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
"=" +++ mkRHS f xx'
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
mkVars :: Int -> [String]
mkVars = mkSVars "x"
mkSVars :: String -> Int -> [String]
mkSVars s n = [s ++ show i | i <- [1..n]]
----fInstance m ("Cn",_) = "" ---
fInstance _ _ m (cat,[]) = ""
fInstance gId lexical m (cat,rules) =
" fg t =" ++++
(if isList
(if isList
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
where
isList = isListCat (cat,rules)
@@ -266,32 +250,34 @@ fInstance gId lexical m (cat,rules) =
" Just (i," ++
"[" ++ prTList "," xx' ++ "])" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
where
xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
mkRHS f vars
| isList =
if "Base" `isPrefixOf` f
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
| otherwise =
gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
mkRHS f vars
| isList =
if "Base" `isPrefixOf` f
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
| otherwise =
gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr =
(showCId (absname gr),
let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns]
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
hSkeleton gr =
(abstractName gr,
let fs =
[(c, [(f, cs) | (f, cs,_) <- fs]) |
fs@((_, _,c):_) <- fns]
in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
)
where
cts = Map.keys (cats (abstract gr))
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
cts = categories gr
fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
valtyps (_,_,x) (_,_,y) = compare x y
valtypg (_,_,x) (_,_,y) = x == y
jty f = case functionType gr f of
Just ty -> let (hypos,valcat,_) = unType ty
in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
Nothing -> Nothing
{-
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =
@@ -301,10 +287,9 @@ updateSkeleton cat skel rule =
-}
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where
c = elemCat cat
fs = map fst rules
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where c = elemCat cat
fs = map fst rules
-- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent
@@ -321,7 +306,7 @@ baseSize (_,rules) = length bs
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
composClass :: [String]
composClass =
composClass =
[
"",
"class Compos t where",
@@ -348,3 +333,4 @@ composClass =
"",
"newtype C b a = C { unC :: b }"
]

105
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -1,105 +0,0 @@
module GF.Compile.PGFtoJS (pgf2js) where
import PGF(showCId)
import PGF.Internal as M
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS
--import GF.Data.ErrM
--import GF.Infra.Option
--import Control.Monad (mplus)
--import Data.Array.Unboxed (UArray)
import qualified Data.Array.IArray as Array
--import Data.Maybe (fromMaybe)
import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2js :: PGF -> String
pgf2js pgf =
JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where
n = showCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = showCId $ M.lookStartCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start as
js_concrete = JS.EObj $ map concrete2js cs
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
absdef2js (f,(typ,_,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
lit2js (LStr s) = JS.EStr s
lit2js (LInt n) = JS.EInt n
lit2js (LFlt d) = JS.EDbl d
concrete2js :: (CId,Concr) -> JS.Property
concrete2js (c,cnc) =
JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ cflags cnc,
JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)],
JS.EArray $ (map ffun2js (Array.elems (cncfuns cnc))),
JS.EArray $ (map seq2js (Array.elems (sequences cnc))),
JS.EObj $ map cats (Map.assocs (cnccats cnc)),
JS.EInt (totalCats cnc)])
where
l = JS.IdentPropName (JS.Ident (showCId c))
{-
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
-}
cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
{-
mkStr :: String -> JS.Expr
mkStr s = new "Str" [JS.EStr s]
mkSeq :: [JS.Expr] -> JS.Expr
mkSeq [x] = x
mkSeq xs = new "Seq" xs
argIdent :: Integer -> JS.Ident
argIdent n = JS.Ident ("x" ++ show n)
-}
children :: JS.Ident
children = JS.Ident "cs"
frule2js :: Production -> JS.Expr
frule2js (PApply funid args) = new "Apply" [JS.EInt funid, JS.EArray (map farg2js args)]
frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg]
farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))]
seq2js :: Array.Array DotPos Symbol -> JS.Expr
seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
sym2js :: Symbol -> JS.Expr
sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l]
sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l]
sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l]
sym2js (SymKS t) = new "SymKS" [JS.EStr t]
sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map sym2js ts), JS.EArray (map alt2js alts)]
sym2js SymBIND = new "SymKS" [JS.EStr "&+"]
sym2js SymSOFT_BIND = new "SymKS" [JS.EStr "&+"]
sym2js SymSOFT_SPACE = new "SymKS" [JS.EStr "&+"]
sym2js SymCAPIT = new "SymKS" [JS.EStr "&|"]
sym2js SymALL_CAPIT = new "SymKS" [JS.EStr "&|"]
sym2js SymNE = new "SymNE" []
alt2js (ps,ts) = new "Alt" [JS.EArray (map sym2js ps), JS.EArray (map JS.EStr ts)]
new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs
mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]

184
src/compiler/GF/Compile/PGFtoJSON.hs
View File

@@ -1,156 +1,110 @@
module GF.Compile.PGFtoJSON (pgf2json) where
import PGF (showCId)
import qualified PGF.Internal as M
import PGF.Internal (
Abstr,
CId,
CncCat(..),
CncFun(..),
Concr,
DotPos,
Equation(..),
Literal(..),
PArg(..),
PGF,
Production(..),
Symbol(..),
Type,
absname,
abstract,
cflags,
cnccats,
cncfuns,
concretes,
funs,
productions,
sequences,
totalCats
)
import qualified Text.JSON as JSON
import Text.JSON (JSValue(..))
import qualified Data.Array.IArray as Array
import Data.Map (Map)
import qualified Data.Set as Set
import PGF2
import PGF2.Internal
import Text.JSON
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2json :: PGF -> String
pgf2json pgf =
JSON.encode $ JSON.makeObj
[ ("abstract", json_abstract)
, ("concretes", json_concretes)
]
where
n = showCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = showCId $ M.lookStartCat pgf
json_abstract = abstract2json n start as
json_concretes = JSON.makeObj $ map concrete2json cs
abstract2json :: String -> String -> Abstr -> JSValue
abstract2json name start ds =
JSON.makeObj
[ ("name", mkJSStr name)
, ("startcat", mkJSStr start)
, ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
encode $ makeObj
[ ("abstract", abstract2json pgf)
, ("concretes", makeObj $ map concrete2json
(Map.toList (languages pgf)))
]
absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
abstract2json :: PGF -> JSValue
abstract2json pgf =
makeObj
[ ("name", showJSON (abstractName pgf))
, ("startcat", showJSON (showType [] (startCat pgf)))
, ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
]
absdef2json :: PGF -> Fun -> (String,JSValue)
absdef2json pgf f = (f,sig)
where
(args,cat) = M.catSkeleton typ
sig = JSON.makeObj
[ ("args", JSArray $ map (mkJSStr.showCId) args)
, ("cat", mkJSStr $ showCId cat)
Just (hypos,cat,_) = fmap unType (functionType pgf f)
sig = makeObj
[ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
, ("cat", showJSON cat)
]
lit2json :: Literal -> JSValue
lit2json (LStr s) = mkJSStr s
lit2json (LInt n) = mkJSInt n
lit2json (LFlt d) = JSRational True (toRational d)
lit2json (LStr s) = showJSON s
lit2json (LInt n) = showJSON n
lit2json (LFlt d) = showJSON d
concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (showCId c,obj)
concrete2json :: (ConcName,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (c,obj)
where
obj = JSON.makeObj
[ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
, ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
, ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
, ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
, ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
, ("totalfids", mkJSInt (totalCats cnc))
obj = makeObj
[ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
, ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
, ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
, ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
, ("categories", makeObj $ map cat2json (concrCategories cnc))
, ("totalfids", showJSON (concrTotalCats cnc))
]
cats2json :: (CId, CncCat) -> (String,JSValue)
cats2json (c,CncCat start end _) = (showCId c, ixs)
cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
cat2json (cat,start,end,_) = (cat, ixs)
where
ixs = JSON.makeObj
[ ("start", mkJSInt start)
, ("end", mkJSInt end)
ixs = makeObj
[ ("start", showJSON start)
, ("end", showJSON end)
]
frule2json :: Production -> JSValue
frule2json (PApply fid args) =
JSON.makeObj
[ ("type", mkJSStr "Apply")
, ("fid", mkJSInt fid)
, ("args", JSArray (map farg2json args))
makeObj
[ ("type", showJSON "Apply")
, ("fid", showJSON fid)
, ("args", showJSON (map farg2json args))
]
frule2json (PCoerce arg) =
JSON.makeObj
[ ("type", mkJSStr "Coerce")
, ("arg", mkJSInt arg)
makeObj
[ ("type", showJSON "Coerce")
, ("arg", showJSON arg)
]
farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
JSON.makeObj
[ ("type", mkJSStr "PArg")
, ("hypos", JSArray $ map (mkJSInt . snd) hypos)
, ("fid", mkJSInt fid)
makeObj
[ ("type", showJSON "PArg")
, ("hypos", JSArray $ map (showJSON . snd) hypos)
, ("fid", showJSON fid)
]
ffun2json :: CncFun -> JSValue
ffun2json (CncFun f lins) =
JSON.makeObj
[ ("name", mkJSStr $ showCId f)
, ("lins", JSArray (map mkJSInt (Array.elems lins)))
ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
ffun2json funid (fun,seqids) =
makeObj
[ ("name", showJSON fun)
, ("lins", showJSON seqids)
]
seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
seq2json :: SeqId -> [Symbol] -> JSValue
seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
sym2json :: Symbol -> JSValue
sym2json (SymCat n l) = new "SymCat" [mkJSInt n, mkJSInt l]
sym2json (SymLit n l) = new "SymLit" [mkJSInt n, mkJSInt l]
sym2json (SymVar n l) = new "SymVar" [mkJSInt n, mkJSInt l]
sym2json (SymKS t) = new "SymKS" [mkJSStr t]
sym2json (SymCat n l) = new "SymCat" [showJSON n, showJSON l]
sym2json (SymLit n l) = new "SymLit" [showJSON n, showJSON l]
sym2json (SymVar n l) = new "SymVar" [showJSON n, showJSON l]
sym2json (SymKS t) = new "SymKS" [showJSON t]
sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)]
sym2json SymBIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_BIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [mkJSStr "&+"]
sym2json SymCAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymALL_CAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymBIND = new "SymKS" [showJSON "&+"]
sym2json SymSOFT_BIND = new "SymKS" [showJSON "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [showJSON "&+"]
sym2json SymCAPIT = new "SymKS" [showJSON "&|"]
sym2json SymALL_CAPIT = new "SymKS" [showJSON "&|"]
sym2json SymNE = new "SymNE" []
alt2json :: ([Symbol],[String]) -> JSValue
alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
new :: String -> [JSValue] -> JSValue
new f xs =
JSON.makeObj
[ ("type", mkJSStr f)
, ("args", JSArray xs)
makeObj
[ ("type", showJSON f)
, ("args", showJSON xs)
]
-- | Make JSON value from string
mkJSStr :: String -> JSValue
mkJSStr = JSString . JSON.toJSString
-- | Make JSON value from integer
mkJSInt :: Integral a => a -> JSValue
mkJSInt = JSRational False . toRational

5
src/compiler/GF/Compile/PGFtoJava.hs
View File

@@ -1,6 +1,6 @@
module GF.Compile.PGFtoJava (grammar2java) where
import PGF
import PGF2
import Data.Maybe(maybe)
import Data.List(intercalate)
import GF.Infra.Option
@@ -24,9 +24,8 @@ javaPreamble name =
]
javaMethod gr fun =
" public static Expr "++name++"("++arg_decls++") { return new Expr("++show name++args++"); }"
" public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }"
where
name = showCId fun
arity = maybe 0 getArrity (functionType gr fun)
vars = ['e':show i | i <- [1..arity]]

262
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -1,262 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGFtoProlog
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Prolog module
-----------------------------------------------------------------------------
module GF.Compile.PGFtoProlog (grammar2prolog) where
import PGF(mkCId,wildCId,showCId)
import PGF.Internal
--import PGF.Macros
import GF.Data.Operations
import qualified Data.Array.IArray as Array
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
import Data.List (isPrefixOf, mapAccumL)
grammar2prolog :: PGF -> String
grammar2prolog pgf
= ("%% This file was automatically generated by GF" +++++
":- style_check(-singleton)." +++++
plFacts wildCId "abstract" 1 "(?AbstractName)"
[[plp name]] ++++
plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)"
[[plp name, plp cncname] |
cncname <- Map.keys (concretes pgf)] ++++
plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags"
[[plp f, plp v] |
(f, v) <- Map.assocs (gflags pgf)] ++++
plAbstract name (abstract pgf) ++++
unlines (map plConcrete (Map.assocs (concretes pgf)))
)
where name = absname pgf
----------------------------------------------------------------------
-- abstract syntax
plAbstract :: CId -> Abstr -> String
plAbstract name abs
= (plHeader "Abstract syntax" ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (aflags abs)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat args, plHypos hypos'] |
(cat, (hypos,_,_)) <- Map.assocs (cats abs),
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
let args = reverse [EFun x | (_,x) <- subst]] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] |
(fun, (typ, _, _, _)) <- Map.assocs (funs abs),
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
plFacts name "def" 2 "(?Fun, ?Expr)"
[[plp fun, plp expr] |
(fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs]
)
where plType cat args = plTerm (plp cat) (map plp args)
plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
----------------------------------------------------------------------
-- concrete syntax
plConcrete :: (CId, Concr) -> String
plConcrete (name, cnc)
= (plHeader ("Concrete syntax: " ++ plp name) ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (cflags cnc)] ++++
plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
[[plp f, plp n] |
(f, n) <- Map.assocs (printnames cnc)] ++++
plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
[[plCat cat, plFun fun] |
(cat, funs) <- IntMap.assocs (lindefs cnc),
fun <- funs] ++++
plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
[[plCat cat, fun, plTerm "c" (map plCat args)] |
(cat, set) <- IntMap.toList (productions cnc),
(fun, args) <- map plProduction (Set.toList set)] ++++
plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
[[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
(fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
plFacts name "seq" 2 "(?Seq, ?[Term])"
[[plSeq seq, plp (Array.elems symbols)] |
(seq, symbols) <- Array.assocs (sequences cnc)] ++++
plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])"
[[plp cat, plList (map plCat [start..end])] |
(cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
)
where plProduction (PCoerce arg) = ("-", [arg])
plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
----------------------------------------------------------------------
-- prolog-printing pgf datatypes
instance PLPrint Type where
plp (DTyp hypos cat args)
| null hypos = result
| otherwise = plOper " -> " plHypos result
where result = plTerm (plp cat) (map plp args)
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
instance PLPrint Expr where
plp (EFun x) = plp x
plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
plp (EApp e e') = plOper " * " (plp e) (plp e')
plp (ELit lit) = plp lit
plp (EMeta n) = "Meta_" ++ show n
instance PLPrint Patt where
plp (PVar x) = plp x
plp (PApp f ps) = plOper " * " (plp f) (plp ps)
plp (PLit lit) = plp lit
instance PLPrint Equation where
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
instance PLPrint CId where
plp cid | isLogicalVariable str || cid == wildCId = plVar str
| otherwise = plAtom str
where str = showCId cid
instance PLPrint Literal where
plp (LStr s) = plp s
plp (LInt n) = plp (show n)
plp (LFlt f) = plp (show f)
instance PLPrint Symbol where
plp (SymCat n l) = plOper ":" (show n) (show l)
plp (SymLit n l) = plTerm "lit" [show n, show l]
plp (SymVar n l) = plTerm "var" [show n, show l]
plp (SymKS t) = plAtom t
plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)]
where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts))
class PLPrint a where
plp :: a -> String
plps :: [a] -> String
plps = plList . map plp
instance PLPrint Char where
plp c = plAtom [c]
plps s = plAtom s
instance PLPrint a => PLPrint [a] where
plp = plps
----------------------------------------------------------------------
-- other prolog-printing functions
plCat :: Int -> String
plCat n = plAtom ('c' : show n)
plFun :: Int -> String
plFun n = plAtom ('f' : show n)
plSeq :: Int -> String
plSeq n = plAtom ('s' : show n)
plHeader :: String -> String
plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
plFacts :: CId -> String -> Int -> String -> [[String]] -> String
plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
mod' = if mod == wildCId then "" else plp mod ++ ": "
plTerm :: String -> [String] -> String
plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
plList :: [String] -> String
plList xs = prBracket (prTList "," xs)
plOper :: String -> String -> String -> String
plOper op a b = prParenth (a ++ op ++ b)
plVar :: String -> String
plVar = varPrefix . concatMap changeNonAlphaNum
where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
| otherwise = "_" ++ var
changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
| otherwise = "_" ++ show (ord c) ++ "_"
plAtom :: String -> String
plAtom "" = "''"
plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
|| c == '\'' && cs /= "" && last cs == '\'' = atom
| otherwise = "'" ++ changeQuote atom ++ "'"
where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
changeQuote (c:cs) = c : changeQuote cs
changeQuote "" = ""
isAlphaNumUnderscore :: Char -> Bool
isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
----------------------------------------------------------------------
-- prolog variables
createLogicalVariable :: Int -> CId
createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
isLogicalVariable :: String -> Bool
isLogicalVariable = isPrefixOf logicalVariablePrefix
logicalVariablePrefix :: String
logicalVariablePrefix = "X"
----------------------------------------------------------------------
-- alpha convert variables to (unique) logical variables
-- * this is needed if we want to translate variables to Prolog variables
-- * used for abstract syntax, not concrete
-- * not (yet?) used for variables bound in pattern equations
type ConvertEnv = (Int, [(CId,CId)])
emptyEnv :: ConvertEnv
emptyEnv = (0, [])
class AlphaConvert a where
alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
instance AlphaConvert a => AlphaConvert [a] where
alphaConvert env [] = (env, [])
alphaConvert env (a:as) = (env'', a':as')
where (env', a') = alphaConvert env a
(env'', as') = alphaConvert env' as
instance AlphaConvert Type where
alphaConvert env@(_,subst) (DTyp hypos cat args)
= ((ctr,subst), DTyp hypos' cat args')
where (env', hypos') = mapAccumL alphaConvertHypo env hypos
((ctr,_), args') = alphaConvert env' args
alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
where ((ctr,subst), typ') = alphaConvert env typ
x' = createLogicalVariable ctr
instance AlphaConvert Expr where
alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
x' = createLogicalVariable ctr
alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
where (env', e1') = alphaConvert env e1
(env'', e2') = alphaConvert env' e2
alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
alphaConvert env expr = (env, expr)
-- pattern variables are not alpha converted
-- (but they probably should be...)
instance AlphaConvert Equation where
alphaConvert env@(_,subst) (Equ patterns result)
= ((ctr,subst), Equ patterns result')
where ((ctr,_), result') = alphaConvert env result

122
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -1,122 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGFtoPython
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Python module
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module GF.Compile.PGFtoPython (pgf2python) where
import PGF(showCId)
import PGF.Internal as M
import GF.Data.Operations
import qualified Data.Array.IArray as Array
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
--import Data.List (intersperse)
pgf2python :: PGF -> String
pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
"# This file was automatically generated by GF" +++++
showCId name +++ "=" +++
pyDict 1 pyStr id [
("flags", pyDict 2 pyCId pyLiteral (Map.assocs (gflags pgf))),
("abstract", pyDict 2 pyStr id [
("name", pyCId name),
("start", pyCId start),
("flags", pyDict 3 pyCId pyLiteral (Map.assocs (aflags abs))),
("funs", pyDict 3 pyCId pyAbsdef (Map.assocs (funs abs)))
]),
("concretes", pyDict 2 pyCId pyConcrete (Map.assocs cncs))
] ++ "\n")
where
name = absname pgf
start = M.lookStartCat pgf
abs = abstract pgf
cncs = concretes pgf
pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (args, cat) = M.catSkeleton typ
pyLiteral :: Literal -> String
pyLiteral (LStr s) = pyStr s
pyLiteral (LInt n) = show n
pyLiteral (LFlt d) = show d
pyConcrete :: Concr -> String
pyConcrete cnc = pyDict 3 pyStr id [
("flags", pyDict 0 pyCId pyLiteral (Map.assocs (cflags cnc))),
("printnames", pyDict 4 pyCId pyStr (Map.assocs (printnames cnc))),
("lindefs", pyDict 4 pyCat (pyList 0 pyFun) (IntMap.assocs (lindefs cnc))),
("productions", pyDict 4 pyCat pyProds (IntMap.assocs (productions cnc))),
("cncfuns", pyDict 4 pyFun pyCncFun (Array.assocs (cncfuns cnc))),
("sequences", pyDict 4 pySeq pySymbols (Array.assocs (sequences cnc))),
("cnccats", pyDict 4 pyCId pyCncCat (Map.assocs (cnccats cnc))),
("size", show (totalCats cnc))
]
where pyProds prods = pyList 5 pyProduction (Set.toList prods)
pyCncCat (CncCat start end _) = pyList 0 pyCat [start..end]
pyCncFun (CncFun f lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyCId f]
pySymbols syms = pyList 0 pySymbol (Array.elems syms)
pyProduction :: Production -> String
pyProduction (PCoerce arg) = pyTuple 0 id [pyStr "", pyList 0 pyCat [arg]]
pyProduction (PApply funid args) = pyTuple 0 id [pyFun funid, pyList 0 pyPArg args]
where pyPArg (PArg [] fid) = pyCat fid
pyPArg (PArg hypos fid) = pyTuple 0 pyCat (fid : map snd hypos)
pySymbol :: Symbol -> String
pySymbol (SymCat n l) = pyTuple 0 show [n, l]
pySymbol (SymLit n l) = pyDict 0 pyStr id [("lit", pyTuple 0 show [n, l])]
pySymbol (SymVar n l) = pyDict 0 pyStr id [("var", pyTuple 0 show [n, l])]
pySymbol (SymKS t) = pyStr t
pySymbol (SymKP ts alts) = pyDict 0 pyStr id [("pre", pyList 0 pySymbol ts), ("alts", pyList 0 alt2py alts)]
where alt2py (ps,ts) = pyTuple 0 (pyList 0 pyStr) [map pySymbol ps, ts]
pySymbol SymBIND = pyStr "&+"
pySymbol SymSOFT_BIND = pyStr "&+"
pySymbol SymSOFT_SPACE = pyStr "&+"
pySymbol SymCAPIT = pyStr "&|"
pySymbol SymALL_CAPIT = pyStr "&|"
pySymbol SymNE = pyDict 0 pyStr id [("nonExist", pyTuple 0 id [])]
----------------------------------------------------------------------
-- python helpers
pyDict :: Int -> (k -> String) -> (v -> String) -> [(k, v)] -> String
pyDict n pk pv [] = "{}"
pyDict n pk pv kvlist = prCurly (pyIndent n ++ prTList ("," ++ pyIndent n) (map pyKV kvlist) ++ pyIndent n)
where pyKV (k, v) = pk k ++ ":" ++ pv v
pyList :: Int -> (v -> String) -> [v] -> String
pyList n pv [] = "[]"
pyList n pv xs = prBracket (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
pyTuple :: Int -> (v -> String) -> [v] -> String
pyTuple n pv [] = "()"
pyTuple n pv [x] = prParenth (pyIndent n ++ pv x ++ "," ++ pyIndent n)
pyTuple n pv xs = prParenth (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
pyCat :: Int -> String
pyCat n = pyStr ('C' : show n)
pyFun :: Int -> String
pyFun n = pyStr ('F' : show n)
pySeq :: Int -> String
pySeq n = pyStr ('S' : show n)
pyStr :: String -> String
pyStr s = 'u' : prQuotedString s
pyCId :: CId -> String
pyCId = pyStr . showCId
pyIndent :: Int -> String
pyIndent n | n > 0 = "\n" ++ replicate n ' '
| otherwise = ""

62
src/compiler/GF/Compile/Rename.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
@@ -23,9 +23,9 @@
-----------------------------------------------------------------------------
module GF.Compile.Rename (
renameSourceTerm,
renameModule
) where
renameSourceTerm,
renameModule
) where
import GF.Infra.Ident
import GF.Infra.CheckM
@@ -39,7 +39,6 @@ import GF.Data.Operations
import Control.Monad
import Data.List (nub,(\\))
import qualified Data.List as L
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import GF.Text.Pretty
@@ -68,7 +67,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)
-- Fails immediately on error, makes it possible to try other possibilities
renameIdentTerm' :: Status -> Term -> Check Term
renameIdentTerm' env@(act,imps) t0 =
renameIdentTerm' env@(act,imps) t0 =
case t0 of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
@@ -85,8 +84,8 @@ renameIdentTerm' env@(act,imps) t0 =
_ -> return t0
where
opens = [st | (OSimple _,st) <- imps]
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OQualif _ m, st) <- imps] ++
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OQualif _ m, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -94,7 +93,7 @@ renameIdentTerm' env@(act,imps) t0 =
| isPredefCat c = return (Q (cPredefAbs,c))
| otherwise = checkError s
ident alt c =
ident alt c =
case Map.lookup c act of
Just f -> return (f c)
_ -> case mapMaybe (Map.lookup c) opens of
@@ -106,31 +105,12 @@ renameIdentTerm' env@(act,imps) t0 =
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
"given" <+> fsep (punctuate ',' (map fst qualifs)))
return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
where
-- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
-- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
notFromCommonModule :: Term -> Bool
notFromCommonModule term =
let t = render $ ppTerm Qualified 0 term :: String
in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
["CommonX", "ConstructX", "ExtendFunctor"
,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
-- If one of the terms comes from the common modules,
-- we choose the other one, because that's defined in the grammar.
bestTerm :: [Term] -> Term
bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
bestTerm ts@(t:_) =
let notCommon = [t | t <- ts, notFromCommonModule t]
in case notCommon of
[] -> t -- All terms are from common modules, return first of original list
(u:_) -> u -- ≥1 terms are not from common modules, return first of those
return t
info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
info2status mq c i = case i of
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
ResValue _ -> maybe Con (curry QC) mq
ResValue _ _ -> maybe Con (curry QC) mq
ResParam _ _ -> maybe Con (curry QC) mq
AnyInd True m -> maybe Con (const (curry QC m)) mq
AnyInd False m -> maybe Cn (const (curry Q m)) mq
@@ -157,7 +137,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: ModuleName -> ModuleInfo -> StatusMap
self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
renameInfo cwd status (m,mi) i info =
case info of
@@ -168,9 +148,9 @@ renameInfo cwd status (m,mi) i info =
ResParam (Just pp) m -> do
pp' <- renLoc (mapM (renParam status)) pp
return (ResParam (Just pp') m)
ResValue t -> do
t <- renLoc (renameTerm status []) t
return (ResValue t)
ResValue ty offset -> do
t <- renLoc (renameTerm status []) ty
return (ResValue ty offset)
CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
_ -> return info
@@ -198,9 +178,9 @@ renameInfo cwd status (m,mi) i info =
return (ps',t')
renParam :: Status -> Param -> Check Param
renParam env (c,co) = do
renParam env (c,co,i) = do
co' <- renameContext env co
return (c,co')
return (c,co',i)
renameTerm :: Status -> [Ident] -> Term -> Check Term
renameTerm env vars = ren vars where
@@ -208,7 +188,7 @@ renameTerm env vars = ren vars where
Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
Vr x
Vr x
| elem x vs -> return trm
| otherwise -> renid trm
Cn _ -> renid trm
@@ -219,7 +199,7 @@ renameTerm env vars = ren vars where
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
_ -> return i
liftM (T i') $ mapM (renCase vs) cs
liftM (T i') $ mapM (renCase vs) cs
Let (x,(m,a)) b -> do
m' <- case m of
@@ -229,7 +209,7 @@ renameTerm env vars = ren vars where
b' <- ren (x:vs) b
return $ Let (x,(m',a')) b'
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
-- record projection from variable or constant $r$ or qualified expression with module $r$
| elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second.
@@ -256,7 +236,7 @@ renamePattern :: Status -> Patt -> Check (Patt,[Ident])
renamePattern env patt =
do r@(p',vs) <- renp patt
let dupl = vs \\ nub vs
unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear. All variable names on the left-hand side must be distinct.") 4
unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear:") 4
patt)
return r
where
@@ -331,7 +311,7 @@ renamePattern env patt =
renameContext :: Status -> Context -> Check Context
renameContext b = renc [] where
renc vs cont = case cont of
(bt,x,t) : xts
(bt,x,t) : xts
| isWildIdent x -> do
t' <- ren vs t
xts' <- renc vs xts

2
src/compiler/GF/Compile/Tags.hs
View File

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++
maybe (list (loc "def")) mb_eqs
getLocations (ResParam mb_params _) = maybe (loc "param") mb_params
getLocations (ResValue mb_type) = ltype "param-value" mb_type
getLocations (ResValue mb_type _) = ltype "param-value" mb_type
getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++
maybe (loc "oper-def") mb_def
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++

31
src/compiler/GF/Compile/ToAPI.hs
View File

@@ -2,8 +2,7 @@ module GF.Compile.ToAPI
(stringToAPI,exprToAPI)
where
import PGF.Internal
import PGF(showCId)
import PGF2
import Data.Maybe
--import System.IO
--import Control.Monad
@@ -47,12 +46,12 @@ exprToFunc :: Expr -> APIfunc
exprToFunc expr =
case unApp expr of
Just (cid,l) ->
case Map.lookup (showCId cid) syntaxFuncs of
case Map.lookup cid syntaxFuncs of
Just sig -> mkAPI True (fst sig,expr)
_ -> case l of
[] -> BasicFunc (showCId cid)
[] -> BasicFunc cid
_ -> let es = map exprToFunc l
in AppFunc (showCId cid) es
in AppFunc cid es
_ -> BasicFunc (showExpr [] expr)
@@ -69,8 +68,8 @@ mkAPI opt (ty,expr) =
where
rephraseSentence ty expr =
case unApp expr of
Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then
let newCat = drop 3 (showCId cid)
Just (cid,es) -> if isPrefixOf "Use" cid then
let newCat = drop 3 cid
afClause = mkAPI True (newCat, es !! 2)
afPol = mkAPI True ("Pol",es !! 1)
lTense = mkAPI True ("Temp", head es)
@@ -98,9 +97,9 @@ mkAPI opt (ty,expr) =
computeAPI :: (String,Expr) -> APIfunc
computeAPI (ty,expr) =
case (unApp expr) of
Just (cid,[]) -> getSimpCat (showCId cid) ty
Just (cid,[]) -> getSimpCat cid ty
Just (cid,es) ->
let p = specFunction (showCId cid) es
let p = specFunction cid es
in if isJust p then fromJust p
else case Map.lookup (show cid) syntaxFuncs of
Nothing -> exprToFunc expr
@@ -147,23 +146,23 @@ optimize expr = optimizeNP expr
optimizeNP expr =
case unApp expr of
Just (cid,es) ->
if showCId cid == "MassNP" then let afs = nounAsCN (head es)
in AppFunc "mkNP" [afs]
else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
ns = nounAsCN (head $ tail es)
in AppFunc "mkNP" (quants ++ [ns])
if cid == "MassNP" then let afs = nounAsCN (head es)
in AppFunc "mkNP" [afs]
else if cid == "DetCN" then let quants = quantAsDet (head es)
ns = nounAsCN (head $ tail es)
in AppFunc "mkNP" (quants ++ [ns])
else mkAPI False ("NP",expr)
_ -> error $ "incorrect expression " ++ (showExpr [] expr)
where
nounAsCN expr =
case unApp expr of
Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es)
Just (cid,es) -> if cid == "UseN" then (mkAPI False) ("N",head es)
else (mkAPI False) ("CN",expr)
_ -> error $ "incorrect expression "++ (showExpr [] expr)
quantAsDet expr =
case unApp expr of
Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
Just (cid,es) -> if cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
else [mkAPI False ("Det",expr)]
_ -> error $ "incorrect expression "++ (showExpr [] expr)

16
src/compiler/GF/Compile/TypeCheck/Abstract.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
@@ -13,11 +13,11 @@
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
checkContext,
checkTyp,
checkDef,
checkConstrs,
) where
checkContext,
checkTyp,
checkDef,
checkConstrs,
) where
import GF.Data.Operations
@@ -33,8 +33,8 @@ import GF.Text.Pretty
--import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context
initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- interface to TC type checker

365
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -1,7 +1,6 @@
{-# LANGUAGE PatternGuards #-}
module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
module GF.Compile.TypeCheck.Concrete( {-checkLType, inferLType, computeLType, ppType-} ) where
{-
import GF.Infra.CheckM
import GF.Data.Operations
@@ -23,16 +22,10 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
| isPredefConstant ty -> return ty ---- shouldn't be needed
Q (m,ident) -> checkIn ("module" <+> m) $ do
Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
ty' <- lookupResDef gr (m,ident)
if ty' == ty then return ty else comp g ty' --- is this necessary to test?
AdHocOverload ts -> do
over <- getOverload gr g (Just typeType) t
case over of
Just (tr,_) -> return tr
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
Vr ident -> checkLookup ident g -- never needed to compute!
App f a -> do
@@ -69,6 +62,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr
_ | isPredefConstant ty -> return ty
_ -> composOp (comp g) ty
@@ -79,26 +73,26 @@ inferLType gr g trm = case trm of
Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
Just ty -> return ty
Nothing -> checkError ("unknown in Predef:" <+> ident)
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
Q ident -> checks [
termWith trm $ lookupResType gr ident >>= computeLType gr g
,
lookupResDef gr ident >>= inferLType gr g
,
checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
]
QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
Just ty -> return ty
Nothing -> checkError ("unknown in Predef:" <+> ident)
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
QC ident -> checks [
termWith trm $ lookupResType gr ident >>= computeLType gr g
,
lookupResDef gr ident >>= inferLType gr g
,
checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
]
Vr ident -> termWith trm $ checkLookup ident g
@@ -106,12 +100,7 @@ inferLType gr g trm = case trm of
Typed e t -> do
t' <- computeLType gr g t
checkLType gr g e t'
AdHocOverload ts -> do
over <- getOverload gr g Nothing trm
case over of
Just trty -> return trty
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
return (e,t')
App f a -> do
over <- getOverload gr g Nothing trm
@@ -121,17 +110,13 @@ inferLType gr g trm = case trm of
(f',fty) <- inferLType gr g f
fty' <- computeLType gr g fty
case fty' of
Prod bt z arg val -> do
Prod bt z arg val -> do
a' <- justCheck g a arg
ty <- if isWildIdent z
ty <- if isWildIdent z
then return val
else substituteLType [(bt,z,a')] val
return (App f' a',ty)
_ ->
let term = ppTerm Unqualified 0 f
funName = pp . head . words .render $ term
in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
"\n ** Maybe you gave too many arguments to" <+> funName <+> "\n")
return (App f' a',ty)
_ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty)
S f x -> do
(f', fty) <- inferLType gr g f
@@ -139,7 +124,7 @@ inferLType gr g trm = case trm of
Table arg val -> do
x'<- justCheck g x arg
return (S f' x', val)
_ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
_ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
P t i -> do
(t',ty) <- inferLType gr g t --- ??
@@ -147,16 +132,16 @@ inferLType gr g trm = case trm of
let tr2 = P t' i
termWith tr2 $ case ty' of
RecType ts -> case lookup i ts of
Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
Just x -> return x
_ -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
" instead of the inferred:" <+> ppTerm Unqualified 0 ty')
_ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$
text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
R r -> do
let (ls,fs) = unzip r
fsts <- mapM inferM fs
let ts = [ty | (Just ty,_) <- fsts]
checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
return $ (R (zip ls fsts), RecType (zip ls ts))
T (TTyped arg) pts -> do
@@ -167,10 +152,10 @@ inferLType gr g trm = case trm of
checkLType gr g trm (Table arg val)
T ti pts -> do -- tries to guess: good in oper type inference
let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
case pts' of
[] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
_ -> do
case pts' of
[] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm)
---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
_ -> do
(arg,val) <- checks $ map (inferCase Nothing) pts'
checkLType gr g trm (Table arg val)
V arg pts -> do
@@ -181,9 +166,9 @@ inferLType gr g trm = case trm of
K s -> do
if elem ' ' s
then do
let ss = foldr C Empty (map K (words s))
let ss = foldr C Empty (map K (words s))
----- removed irritating warning AR 24/5/2008
----- checkWarn ("token \"" ++ s ++
----- checkWarn ("token \"" ++ s ++
----- "\" converted to token list" ++ prt ss)
return (ss, typeStr)
else return (trm, typeStr)
@@ -194,56 +179,50 @@ inferLType gr g trm = case trm of
Empty -> return (trm, typeStr)
C s1 s2 ->
C s1 s2 ->
check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
Glue s1 s2 ->
Glue s1 s2 ->
check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn c : ts) | c == cConflict -> do
checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
inferLType gr g (head ts)
Strs ts -> do
ts' <- mapM (\t -> justCheck g t typeStr) ts
ts' <- mapM (\t -> justCheck g t typeStr) ts
return (Strs ts', typeStrs)
Alts t aa -> do
t' <- justCheck g t typeStr
aa' <- flip mapM aa (\ (c,v) -> do
c' <- justCheck g c typeStr
c' <- justCheck g c typeStr
v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
return (c',v'))
return (Alts t' aa', typeStr)
RecType r -> do
let (ls,ts) = unzip r
ts' <- mapM (flip (justCheck g) typeType) ts
ts' <- mapM (flip (justCheck g) typeType) ts
return (RecType (zip ls ts'), typeType)
ExtR r s -> do
--- over <- getOverload gr g Nothing r
--- let r1 = maybe r fst over
let r1 = r ---
(r',rT) <- inferLType gr g r1
(r',rT) <- inferLType gr g r
rT' <- computeLType gr g rT
(s',sT) <- inferLType gr g s
sT' <- computeLType gr g sT
let trm' = ExtR r' s'
---- trm' <- plusRecord r' s'
case (rT', sT') of
(RecType rs, RecType ss) -> do
let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
rt <- plusRecType rT' sT'
checkLType gr g trm' rt ---- return (trm', rt)
_ | rT' == typeType && sT' == typeType -> do
return (trm', typeType)
_ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
_ | rT' == typeType && sT' == typeType -> return (trm', typeType)
_ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
Sort _ ->
Sort _ ->
termWith trm $ return typeType
Prod bt x a b -> do
@@ -252,7 +231,7 @@ inferLType gr g trm = case trm of
return (Prod bt x a' b', typeType)
Table p t -> do
p' <- justCheck g p typeType --- check p partype!
p' <- justCheck g p typeType --- check p partype!
t' <- justCheck g t typeType
return $ (Table p' t', typeType)
@@ -271,9 +250,9 @@ inferLType gr g trm = case trm of
ELin c trm -> do
(trm',ty) <- inferLType gr g trm
ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
return $ (ELin c trm', ty')
return $ (ELin c trm', ty')
_ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
_ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
where
isPredef m = elem m [cPredef,cPredefAbs]
@@ -320,6 +299,7 @@ inferLType gr g trm = case trm of
PChars _ -> return $ typeStr
_ -> inferLType gr g (patt2term p) >>= return . snd
-- type inference: Nothing, type checking: Just t
-- the latter permits matching with value type
getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
@@ -330,28 +310,15 @@ getOverload gr g mt ot = case appForm ot of
v <- matchOverload f typs ttys
return $ Just v
_ -> return Nothing
(AdHocOverload cs@(f:_), ts) -> do --- the function name f is only used in error messages
let typs = concatMap collectOverloads cs
ttys <- mapM (inferLType gr g) ts
v <- matchOverload f typs ttys
return $ Just v
_ -> return Nothing
where
collectOverloads tr@(Q c) = case lookupOverload gr c of
Ok typs -> typs
_ -> case lookupResType gr c of
Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
_ -> []
collectOverloads _ = [] --- constructors QC
matchOverload f typs ttys = do
let (tts,tys) = unzip ttys
let vfs = lookupOverloadInstance tys typs
let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
let showTypes ty = hsep (map ppType ty)
let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
-- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
@@ -362,57 +329,50 @@ getOverload gr g mt ot = case appForm ot of
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
([(_,val,fun)],_) -> return (mkApp fun tts, val)
([],[(pre,val,fun)]) -> do
checkWarn $ "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
"for" $$
checkWarn $ text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
text "for" $$
nest 2 (showTypes tys) $$
"using" $$
text "using" $$
nest 2 (showTypes pre)
return (mkApp fun tts, val)
([],[]) -> do
checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
maybe empty (\x -> "with value type" <+> ppType x) mt $$
"for argument list" $$
checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
text "for" $$
nest 2 stysError $$
"among alternatives" $$
nest 2 (vcat stypsError)
text "among" $$
nest 2 (vcat stypsError) $$
maybe empty (\x -> text "with value type" <+> ppType x) mt
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do
return (mkApp fun tts, val)
([],[(val,fun)]) -> do
checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
return (mkApp fun tts, val)
----- unsafely exclude irritating warning AR 24/5/2008
----- checkWarn $ "overloading of" +++ prt f +++
----- checkWarn $ "overloading of" +++ prt f +++
----- "resolved by excluding partial applications:" ++++
----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
--- now forgiving ambiguity with a warning AR 1/2/2014
-- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
-- But it also gives a chance to ambiguous overloadings that were banned before.
(nps1,nps2) -> do
checkWarn $ "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
---- "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
"resolved by selecting the first of the alternatives" $$
nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
[] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
h:_ -> return h
_ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
text "for" <+> hsep (map ppType tys) $$
text "with alternatives" $$
nest 2 (vcat [ppType ty | (_,ty,_) <- if null vfs1 then vfs2 else vfs2])
matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
unlocked v = case v of
RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
RecType fs -> RecType $ filter (not . isLockLabel . fst) fs
_ -> v
---- TODO: accept subtypes
---- TODO: use a trie
lookupOverloadInstance tys typs =
[((pre,mkFunType rest val, t),isExact) |
lookupOverloadInstance tys typs =
[((pre,mkFunType rest val, t),isExact) |
let lt = length tys,
(ty,(val,t)) <- typs, length ty >= lt,
let (pre,rest) = splitAt lt ty,
let (pre,rest) = splitAt lt ty,
let isExact = pre == tys,
isExact || map unlocked pre == map unlocked tys
]
@@ -425,21 +385,20 @@ getOverload gr g mt ot = case appForm ot of
checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
checkLType gr g trm typ0 = do
typ <- computeLType gr g typ0
case trm of
Abs bt x c -> do
case typ of
Prod bt' z a b -> do
Prod bt' z a b -> do
(c',b') <- if isWildIdent z
then checkLType gr ((bt,x,a):g) c b
else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b
checkLType gr ((bt,x,a):g) c b'
return $ (Abs bt x c', Prod bt' z a b')
_ -> checkError $ "function type expected instead of" <+> ppType typ $$
"\n ** Double-check that the type signature of the operation" $$
"matches the number of arguments given to it.\n"
return $ (Abs bt x c', Prod bt' x a b')
_ -> checkError $ text "function type expected instead of" <+> ppType typ
App f a -> do
over <- getOverload gr g (Just typ) trm
@@ -449,12 +408,6 @@ checkLType gr g trm typ0 = do
(trm',ty') <- inferLType gr g trm
termWith trm' $ checkEqLType gr g typ ty' trm'
AdHocOverload ts -> do
over <- getOverload gr g Nothing trm
case over of
Just trty -> return trty
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
Q _ -> do
over <- getOverload gr g (Just typ) trm
case over of
@@ -464,21 +417,21 @@ checkLType gr g trm typ0 = do
termWith trm' $ checkEqLType gr g typ ty' trm'
T _ [] ->
checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
T _ cs -> case typ of
Table arg val -> do
checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ)
T _ cs -> case typ of
Table arg val -> do
case allParamValues gr arg of
Ok vs -> do
let ps0 = map fst cs
ps <- testOvershadow ps0 vs
if null ps
then return ()
else checkWarn ("patterns never reached:" $$
if null ps
then return ()
else checkWarn (text "patterns never reached:" $$
nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
_ -> return () -- happens with variable types
cs' <- mapM (checkCase arg val) cs
return (T (TTyped arg) cs', typ)
_ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
_ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ)
V arg0 vs ->
case typ of
Table arg1 val ->
@@ -486,54 +439,51 @@ checkLType gr g trm typ0 = do
vs1 <- allParamValues gr arg1
if length vs1 == length vs
then return ()
else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
else checkError $ text "wrong number of values in table" <+> ppTerm Unqualified 0 trm
vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
return (V arg' vs',typ)
R r -> case typ of --- why needed? because inference may be too difficult
RecType rr -> do
--let (ls,_) = unzip rr -- labels of expected type
let (ls,_) = unzip rr -- labels of expected type
fsts <- mapM (checkM r) rr -- check that they are found in the record
return $ (R fsts, typ) -- normalize record
_ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
_ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
ExtR r s -> case typ of
_ | typ == typeType -> do
trm' <- computeLType gr g trm
case trm' of
RecType _ -> termWith trm' $ return typeType
ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
RecType _ -> termWith trm $ return typeType
ExtR (Vr _) (RecType _) -> termWith trm $ return typeType
-- ext t = t ** ...
_ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
_ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
RecType rr -> do
(r',ty,s') <- checks [
do (r',ty) <- inferLType gr g r
return (r',ty,s)
,
do (s',ty) <- inferLType gr g s
return (s',ty,r)
]
ll2 <- case s of
R ss -> return $ map fst ss
_ -> do
(s',typ2) <- inferLType gr g s
case typ2 of
RecType ss -> return $ map fst ss
_ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
let ll1 = [l | (l,_) <- rr, notElem l ll2]
--- over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020
--- let r1 = maybe r fst over
let r1 = r ---
(r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1])
(s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2])
let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
return (rec, typ)
case ty of
RecType rr1 -> do
let (rr0,rr2) = recParts rr rr1
r2 <- justCheck g r' rr0
s2 <- justCheck g s' rr2
return $ (ExtR r2 s2, typ)
_ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$
text "but found" <+> ppTerm Unqualified 0 ty)
ExtR ty ex -> do
r' <- justCheck g r ty
s' <- justCheck g s ex
return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
_ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
_ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
FV vs -> do
ttys <- mapM (flip (checkLType gr g) typ) vs
@@ -548,7 +498,7 @@ checkLType gr g trm typ0 = do
(arg',val) <- checkLType gr g arg p
checkEqLType gr g typ t trm
return (S tab' arg', t)
_ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
_ -> checkError (text "table type expected for applied table instead of" <+> ppType ty')
, do
(arg',ty) <- inferLType gr g arg
ty' <- computeLType gr g ty
@@ -557,8 +507,7 @@ checkLType gr g trm typ0 = do
]
Let (x,(mty,def)) body -> case mty of
Just ty -> do
(ty0,_) <- checkLType gr g ty typeType
(def',ty') <- checkLType gr g def ty0
(def',ty') <- checkLType gr g def ty
body' <- justCheck ((Explicit,x,ty'):g) body typ
return (Let (x,(Just ty',def')) body', typ)
_ -> do
@@ -574,10 +523,10 @@ checkLType gr g trm typ0 = do
termWith trm' $ checkEqLType gr g typ ty' trm'
where
justCheck g ty te = checkLType gr g ty te >>= return . fst
{-
recParts rr t = (RecType rr1,RecType rr2) where
(rr1,rr2) = partition (flip elem (map fst t) . fst) rr
-}
recParts rr t = (RecType rr1,RecType rr2) where
(rr1,rr2) = partition (flip elem (map fst t) . fst) rr
checkM rms (l,ty) = case lookup l rms of
Just (Just ty0,t) -> do
checkEqLType gr g ty ty0 t
@@ -586,12 +535,12 @@ checkLType gr g trm typ0 = do
Just (_,t) -> do
(t',ty') <- checkLType gr g t ty
return (l,(Just ty',t'))
_ -> checkError $
if isLockLabel l
_ -> checkError $
if isLockLabel l
then let cat = drop 5 (showIdent (label2ident l))
in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
"; try wrapping it with lin" <+> cat
else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <>
text "; try wrapping it with lin" <+> text cat
else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
checkCase arg val (p,t) = do
cont <- pattContext gr g arg p
@@ -604,7 +553,7 @@ pattContext env g typ p = case p of
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- lookupResType env (q,c)
let (cont,v) = typeFormCnc t
checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps)
checkEqLType env g typ v (patt2term p)
mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
@@ -615,7 +564,7 @@ pattContext env g typ p = case p of
let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
----- checkWarn $ prt p ++++ show pts ----- debug
mapM (uncurry (pattContext env g)) pts >>= return . concat
_ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
_ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
PT t p' -> do
checkEqLType env g typ t (patt2term p')
pattContext env g typ p'
@@ -628,10 +577,10 @@ pattContext env g typ p = case p of
g1 <- pattContext env g typ p'
g2 <- pattContext env g typ q
let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
checkCond
("incompatible bindings of" <+>
fsep pts <+>
"in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
checkCond
(text "incompatible bindings of" <+>
fsep (map ppIdent pts) <+>
text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
return g1 -- must be g1 == g2
PSeq p q -> do
g1 <- pattContext env g typ p
@@ -641,11 +590,11 @@ pattContext env g typ p = case p of
PNeg p' -> noBind typ p'
_ -> return [] ---- check types!
where
where
noBind typ p' = do
co <- pattContext env g typ p'
if not (null co)
then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
>> return []
else return []
@@ -654,31 +603,9 @@ checkEqLType gr g t u trm = do
(b,t',u',s) <- checkIfEqLType gr g t u trm
case b of
True -> return t'
False ->
let inferredType = ppTerm Qualified 0 u
expectedType = ppTerm Qualified 0 t
term = ppTerm Unqualified 0 trm
funName = pp . head . words .render $ term
helpfulMsg =
case (arrows inferredType, arrows expectedType) of
(0,0) -> pp "" -- None of the types is a function
_ -> "\n **" <+>
if expectedType `isLessApplied` inferredType
then "Maybe you gave too few arguments to" <+> funName
else pp "Double-check that type signature and number of arguments match."
in checkError $ s <+> "type of" <+> term $$
"expected:" <+> expectedType $$ -- ppqType t u $$
"inferred:" <+> inferredType $$ -- ppqType u t
helpfulMsg
where
-- count the number of arrows in the prettyprinted term
arrows :: Doc -> Int
arrows = length . filter (=="->") . words . render
-- If prettyprinted type t has fewer arrows then prettyprinted type u,
-- then t is "less applied", and we can print out more helpful error msg.
isLessApplied :: Doc -> Doc -> Bool
isLessApplied t u = arrows t < arrows u
False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$
text "expected:" <+> ppType t $$
text "inferred:" <+> ppType u
checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
checkIfEqLType gr g t u trm = do
@@ -690,62 +617,60 @@ checkIfEqLType gr g t u trm = do
--- better: use a flag to forgive? (AR 31/1/2006)
_ -> case missingLock [] t' u' of
Ok lo -> do
checkWarn $ "missing lock field" <+> fsep lo
checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo)
return (True,t',u',[])
Bad s -> return (False,t',u',s)
where
-- check that u is a subtype of t
-- t is a subtype of u
--- quick hack version of TC.eqVal
alpha g t u = case (t,u) of
alpha g t u = case (t,u) of
-- error (the empty type!) is subtype of any other type
(_,u) | u == typeError -> True
-- contravariance
(Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
(Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
-- record subtyping
(RecType rs, RecType ts) -> all (\ (l,a) ->
any (\ (k,b) -> l == k && alpha g a b) ts) rs
(RecType rs, RecType ts) -> all (\ (l,a) ->
any (\ (k,b) -> alpha g a b && l == k) ts) rs
(ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
(ExtR r s, t) -> alpha g r t || alpha g s t
-- the following say that Ints n is a subset of Int and of Ints m >= n
-- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
(t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
(t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n
| Just _ <- isTypeInts t, u == typeInt -> True ---- check size!
| t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
---- this should be made in Rename
(Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
(Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
|| m == n --- for Predef
(QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
(QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
(QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
(Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
-- contravariance
(Table a b, Table c d) -> alpha g c a && alpha g b d
(Table a b, Table c d) -> alpha g a c && alpha g b d
(Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g
_ -> t == u
_ -> t == u
--- the following should be one-way coercions only. AR 4/1/2001
|| elem t sTypes && elem u sTypes
|| (t == typeType && u == typePType)
|| (u == typeType && t == typePType)
|| (t == typeType && u == typePType)
|| (u == typeType && t == typePType)
missingLock g t u = case (t,u) of
(RecType rs, RecType ts) ->
let
ls = [l | (l,a) <- rs,
missingLock g t u = case (t,u) of
(RecType rs, RecType ts) ->
let
ls = [l | (l,a) <- rs,
not (any (\ (k,b) -> alpha g a b && l == k) ts)]
(locks,others) = partition isLockLabel ls
in case others of
_:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
_:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others)))
_ -> return locks
-- contravariance
(Prod _ x a b, Prod _ y c d) -> do
@@ -771,7 +696,7 @@ termWith t ct = do
return (t,ty)
-- | compositional check\/infer of binary operations
check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
Term -> Term -> Type -> Check (Term,Type)
check2 chk con a b t = do
a' <- chk a
@@ -783,18 +708,14 @@ ppType :: Type -> Doc
ppType ty =
case ty of
RecType fs -> case filter isLockLabel $ map fst fs of
[lock] -> pp (drop 5 (showIdent (label2ident lock)))
[lock] -> text (drop 5 (showIdent (label2ident lock)))
_ -> ppTerm Unqualified 0 ty
Prod _ x a b -> ppType a <+> "->" <+> ppType b
Prod _ x a b -> ppType a <+> text "->" <+> ppType b
_ -> ppTerm Unqualified 0 ty
{-
ppqType :: Type -> Type -> Doc
ppqType t u = case (ppType t, ppType u) of
(pt,pu) | render pt == render pu -> ppTerm Qualified 0 t
(pt,_) -> pt
-}
checkLookup :: Ident -> Context -> Check Type
checkLookup x g =
case [ty | (b,y,ty) <- g, x == y] of
[] -> checkError ("unknown variable" <+> x)
[] -> checkError (text "unknown variable" <+> ppIdent x)
(ty:_) -> return ty
-}

76
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where
-- The code here is based on the paper:
@@ -10,7 +9,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.Lockfield
import GF.Compile.Compute.Concrete
import GF.Compile.Compute.ConcreteNew
import GF.Compile.Compute.Predef(predef,predefName)
import GF.Infra.CheckM
import GF.Data.Operations
@@ -20,7 +19,6 @@ import GF.Text.Pretty
import Data.List (nub, (\\), tails)
import qualified Data.IntMap as IntMap
import Data.Maybe(fromMaybe,isNothing)
import qualified Control.Monad.Fail as Fail
checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
checkLType ge t ty = runTcM $ do
@@ -133,7 +131,7 @@ tcRho ge scope t@(RecType rs) (Just ty) = do
[] -> unifyVar ge scope i env vs vtypePType
_ -> return ()
ty -> do ty <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) ty
tcError ("The record type" <+> ppTerm Unqualified 0 t $$
tcError ("The record type" <+> ppTerm Unqualified 0 t $$
"cannot be of type" <+> ppTerm Unqualified 0 ty)
(rs,mb_ty) <- tcRecTypeFields ge scope rs (Just ty')
return (f (RecType rs),ty)
@@ -187,7 +185,7 @@ tcRho ge scope (R rs) (Just ty) = do
case ty' of
(VRecType ltys) -> do lttys <- checkRecFields ge scope rs ltys
rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
return ((f . R) rs,
return ((f . R) rs,
VRecType [(l, ty) | (l,t,ty) <- lttys]
)
ty -> do lttys <- inferRecFields ge scope rs
@@ -277,11 +275,11 @@ tcApp ge scope (App fun arg) = -- APP2
varg <- liftErr (eval ge (scopeEnv scope) arg)
return (App fun arg, res_ty varg)
tcApp ge scope (Q id) = -- VAR (global)
mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
do ty <- liftErr (eval ge [] ty)
return (t,ty)
tcApp ge scope (QC id) = -- VAR (global)
mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
do ty <- liftErr (eval ge [] ty)
return (t,ty)
tcApp ge scope t =
@@ -350,7 +348,7 @@ tcPatt ge scope (PM q) ty0 = do
Bad err -> tcError (pp err)
tcPatt ge scope p ty = unimplemented ("tcPatt "++show p)
inferRecFields ge scope rs =
inferRecFields ge scope rs =
mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs
checkRecFields ge scope [] ltys
@@ -368,7 +366,7 @@ checkRecFields ge scope ((l,t):lts) ltys =
where
takeIt l1 [] = (Nothing, [])
takeIt l1 (lty@(l2,ty):ltys)
| l1 == l2 = (Just ty,ltys)
| l1 == l2 = (Just ty,ltys)
| otherwise = let (mb_ty,ltys') = takeIt l1 ltys
in (mb_ty,lty:ltys')
@@ -390,13 +388,13 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
| s == cPType -> return mb_ty
VMeta _ _ _ -> return mb_ty
_ -> do sort <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) sort
tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
"cannot be of type" <+> ppTerm Unqualified 0 sort)
(rs,mb_ty) <- tcRecTypeFields ge scope rs mb_ty
return ((l,ty):rs,mb_ty)
-- | Invariant: if the third argument is (Just rho),
-- then rho is in weak-prenex form
-- then rho is in weak-prenex form
instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1
instSigma ge scope t ty1 (Just ty2) = do -- INST2
@@ -444,11 +442,11 @@ subsCheckRho ge scope t (VApp p1 _) (VApp p2 _) -- Rule
| predefName p1 == cInts && predefName p2 == cInt = return t
subsCheckRho ge scope t (VApp p1 [VInt i]) (VApp p2 [VInt j]) -- Rule INT2
| predefName p1 == cInts && predefName p2 == cInts =
if i <= j
if i <= j
then return t
else tcError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do -- Rule REC
let mkAccess scope t =
let mkAccess scope t =
case t of
ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
(scope,mkProj2,mkWrap2) <- mkAccess scope t2
@@ -557,7 +555,7 @@ unify ge scope v (VMeta i env vs) = unifyVar ge scope i env vs v
unify ge scope v1 v2 = do
t1 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v1
t2 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v2
tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
ppTerm Unqualified 0 t2))
-- | Invariant: tv1 is a flexible type variable
@@ -568,9 +566,9 @@ unifyVar ge scope i env vs ty2 = do -- Check whether i is bound
Bound ty1 -> do v <- liftErr (eval ge env ty1)
unify ge scope (vapply (geLoc ge) v vs) ty2
Unbound scope' _ -> case value2term (geLoc ge) (scopeVars scope') ty2 of
-- Left i -> let (v,_) = reverse scope !! i
-- in tcError ("Variable" <+> pp v <+> "has escaped")
ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
Left i -> let (v,_) = reverse scope !! i
in tcError ("Variable" <+> pp v <+> "has escaped")
Right ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
if i `elem` ms2
then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
nest 2 (ppTerm Unqualified 0 ty2'))
@@ -609,7 +607,7 @@ quantify ge scope t tvs ty0 = do
ty <- tc_value2term (geLoc ge) (scopeVars scope) ty0
let used_bndrs = nub (bndrs ty) -- Avoid quantified type variables in use
new_bndrs = take (length tvs) (allBinders \\ used_bndrs)
mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
ty <- zonkTerm ty -- of doing the substitution
vty <- liftErr (eval ge [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs))
return (foldr (Abs Implicit) t new_bndrs,vty)
@@ -619,7 +617,7 @@ quantify ge scope t tvs ty0 = do
bndrs (Prod _ x t1 t2) = [x] ++ bndrs t1 ++ bndrs t2
bndrs _ = []
allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,...
allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,...
allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
[ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
@@ -631,8 +629,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
type Scope = [(Ident,Value)]
type Sigma = Value
type Rho = Value -- No top-level ForAll
type Tau = Value -- No ForAlls anywhere
type Rho = Value -- No top-level ForAll
type Tau = Value -- No ForAlls anywhere
data MetaValue
= Unbound Scope Sigma
@@ -648,16 +646,8 @@ instance Monad TcM where
f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of
TcOk x ms msgs -> unTcM (g x) ms msgs
TcFail msgs -> TcFail msgs)
#if !(MIN_VERSION_base(4,13,0))
-- Monad(fail) will be removed in GHC 8.8+
fail = Fail.fail
#endif
instance Fail.MonadFail TcM where
fail = tcError . pp
instance Applicative TcM where
pure = return
(<*>) = ap
@@ -688,12 +678,12 @@ runTcM f = case unTcM f IntMap.empty [] of
TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg
newMeta :: Scope -> Sigma -> TcM MetaId
newMeta scope ty = TcM (\ms msgs ->
newMeta scope ty = TcM (\ms msgs ->
let i = IntMap.size ms
in TcOk i (IntMap.insert i (Unbound scope ty) ms) msgs)
getMeta :: MetaId -> TcM MetaValue
getMeta i = TcM (\ms msgs ->
getMeta i = TcM (\ms msgs ->
case IntMap.lookup i ms of
Just mv -> TcOk mv ms msgs
Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
@@ -702,7 +692,7 @@ setMeta :: MetaId -> MetaValue -> TcM ()
setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)
newVar :: Scope -> Ident
newVar scope = head [x | i <- [1..],
newVar scope = head [x | i <- [1..],
let x = identS ('v':show i),
isFree scope x]
where
@@ -721,11 +711,11 @@ getMetaVars loc sc_tys = do
return (foldr go [] tys)
where
-- Get the MetaIds from a term; no duplicates in result
go (Vr tv) acc = acc
go (Vr tv) acc = acc
go (App x y) acc = go x (go y acc)
go (Meta i) acc
| i `elem` acc = acc
| otherwise = i : acc
| i `elem` acc = acc
| otherwise = i : acc
go (Q _) acc = acc
go (QC _) acc = acc
go (Sort _) acc = acc
@@ -741,10 +731,10 @@ getFreeVars loc sc_tys = do
tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys
return (foldr (go []) [] tys)
where
go bound (Vr tv) acc
| tv `elem` bound = acc
| tv `elem` acc = acc
| otherwise = tv : acc
go bound (Vr tv) acc
| tv `elem` bound = acc
| tv `elem` acc = acc
| otherwise = tv : acc
go bound (App x y) acc = go bound x (go bound y acc)
go bound (Meta _) acc = acc
go bound (Q _) acc = acc
@@ -765,13 +755,13 @@ zonkTerm (Meta i) = do
zonkTerm t = composOp zonkTerm t
tc_value2term loc xs v =
return $ value2term loc xs v
-- Old value2term error message:
-- Left i -> tcError ("Variable #" <+> pp i <+> "has escaped")
case value2term loc xs v of
Left i -> tcError ("Variable #" <+> pp i <+> "has escaped")
Right t -> return t
data TcA x a
data TcA x a
= TcSingle (MetaStore -> [Message] -> TcResult a)
| TcMany [x] (MetaStore -> [Message] -> [(a,MetaStore,[Message])])

8
src/compiler/GF/Compile/TypeCheck/Primitives.hs
View File

@@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type
typPredefined f = case Map.lookup f primitives of
Just (ResOper (Just (L _ ty)) _) -> Just ty
Just (ResParam _ _) -> Just typePType
Just (ResValue (L _ ty)) -> Just ty
Just (ResValue (L _ ty) _) -> Just ty
_ -> Nothing
primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
, (cInts , fun [typeInt] typePType)
, (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue (noLoc typePBool))
, (cPFalse , ResValue (noLoc typePBool))
, (cPBool , ResParam (Just (noLoc [(cPTrue,[],0),(cPFalse,[],1)])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue (noLoc typePBool) 0)
, (cPFalse , ResValue (noLoc typePBool) 1)
, (cError , fun [typeStr] typeError) -- non-can. of empty set
, (cLength , fun [typeTok] typeInt)
, (cDrop , fun [typeInt,typeTok] typeTok)

761
src/compiler/GF/Compile/TypeCheck/RConcrete.hs Normal file
View File

@@ -0,0 +1,761 @@
{-# LANGUAGE PatternGuards #-}
module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where
import GF.Infra.CheckM
import GF.Data.Operations
import GF.Grammar
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.PatternMatch
import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
import GF.Compile.TypeCheck.Primitives
import Data.List
import Control.Monad
import GF.Text.Pretty
computeLType :: SourceGrammar -> Context -> Type -> Check Type
computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
where
comp g ty = case ty of
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
| isPredefConstant ty -> return ty ---- shouldn't be needed
Q (m,ident) -> checkIn ("module" <+> m) $ do
ty' <- lookupResDef gr (m,ident)
if ty' == ty then return ty else comp g ty' --- is this necessary to test?
AdHocOverload ts -> do
over <- getOverload gr g (Just typeType) t
case over of
Just (tr,_) -> return tr
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
Vr ident -> checkLookup ident g -- never needed to compute!
App f a -> do
f' <- comp g f
a' <- comp g a
case f' of
Abs b x t -> comp ((b,x,a'):g) t
_ -> return $ App f' a'
Prod bt x a b -> do
a' <- comp g a
b' <- comp ((bt,x,Vr x) : g) b
return $ Prod bt x a' b'
Abs bt x b -> do
b' <- comp ((bt,x,Vr x):g) b
return $ Abs bt x b'
Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b
ExtR r s -> do
r' <- comp g r
s' <- comp g s
case (r',s') of
(RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
_ -> return $ ExtR r' s'
RecType fs -> do
let fs' = sortRec fs
liftM RecType $ mapPairsM (comp g) fs'
ELincat c t -> do
t' <- comp g t
lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr
_ | isPredefConstant ty -> return ty
_ -> composOp (comp g) ty
-- the underlying algorithms
inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
inferLType gr g trm = case trm of
Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
Just ty -> return ty
Nothing -> checkError ("unknown in Predef:" <+> ident)
Q ident -> checks [
termWith trm $ lookupResType gr ident >>= computeLType gr g
,
lookupResDef gr ident >>= inferLType gr g
,
checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
]
QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
Just ty -> return ty
Nothing -> checkError ("unknown in Predef:" <+> ident)
QC ident -> checks [
termWith trm $ lookupResType gr ident >>= computeLType gr g
,
lookupResDef gr ident >>= inferLType gr g
,
checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
]
Vr ident -> termWith trm $ checkLookup ident g
Typed e t -> do
t' <- computeLType gr g t
checkLType gr g e t'
AdHocOverload ts -> do
over <- getOverload gr g Nothing trm
case over of
Just trty -> return trty
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
App f a -> do
over <- getOverload gr g Nothing trm
case over of
Just trty -> return trty
_ -> do
(f',fty) <- inferLType gr g f
fty' <- computeLType gr g fty
case fty' of
Prod bt z arg val -> do
a' <- justCheck g a arg
ty <- if isWildIdent z
then return val
else substituteLType [(bt,z,a')] val
return (App f' a',ty)
_ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
S f x -> do
(f', fty) <- inferLType gr g f
case fty of
Table arg val -> do
x'<- justCheck g x arg
return (S f' x', val)
_ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
P t i -> do
(t',ty) <- inferLType gr g t --- ??
ty' <- computeLType gr g ty
let tr2 = P t' i
termWith tr2 $ case ty' of
RecType ts -> case lookup i ts of
Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
Just x -> return x
_ -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
" instead of the inferred:" <+> ppTerm Unqualified 0 ty')
R r -> do
let (ls,fs) = unzip r
fsts <- mapM inferM fs
let ts = [ty | (Just ty,_) <- fsts]
checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
return $ (R (zip ls fsts), RecType (zip ls ts))
T (TTyped arg) pts -> do
(_,val) <- checks $ map (inferCase (Just arg)) pts
checkLType gr g trm (Table arg val)
T (TComp arg) pts -> do
(_,val) <- checks $ map (inferCase (Just arg)) pts
checkLType gr g trm (Table arg val)
T ti pts -> do -- tries to guess: good in oper type inference
let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
case pts' of
[] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
_ -> do
(arg,val) <- checks $ map (inferCase Nothing) pts'
checkLType gr g trm (Table arg val)
V arg pts -> do
(_,val) <- checks $ map (inferLType gr g) pts
-- return (trm, Table arg val) -- old, caused issue 68
checkLType gr g trm (Table arg val)
K s -> do
if elem ' ' s
then do
let ss = foldr C Empty (map K (words s))
----- removed irritating warning AR 24/5/2008
----- checkWarn ("token \"" ++ s ++
----- "\" converted to token list" ++ prt ss)
return (ss, typeStr)
else return (trm, typeStr)
EInt i -> return (trm, typeInt)
EFloat i -> return (trm, typeFloat)
Empty -> return (trm, typeStr)
C s1 s2 ->
check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
Glue s1 s2 ->
check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn c : ts) | c == cConflict -> do
checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
inferLType gr g (head ts)
Strs ts -> do
ts' <- mapM (\t -> justCheck g t typeStr) ts
return (Strs ts', typeStrs)
Alts t aa -> do
t' <- justCheck g t typeStr
aa' <- flip mapM aa (\ (c,v) -> do
c' <- justCheck g c typeStr
v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
return (c',v'))
return (Alts t' aa', typeStr)
RecType r -> do
let (ls,ts) = unzip r
ts' <- mapM (flip (justCheck g) typeType) ts
return (RecType (zip ls ts'), typeType)
ExtR r s -> do
(r',rT) <- inferLType gr g r
rT' <- computeLType gr g rT
(s',sT) <- inferLType gr g s
sT' <- computeLType gr g sT
let trm' = ExtR r' s'
case (rT', sT') of
(RecType rs, RecType ss) -> do
let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
checkLType gr g trm' rt ---- return (trm', rt)
_ | rT' == typeType && sT' == typeType -> do
return (trm', typeType)
_ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
Sort _ ->
termWith trm $ return typeType
Prod bt x a b -> do
a' <- justCheck g a typeType
b' <- justCheck ((bt,x,a'):g) b typeType
return (Prod bt x a' b', typeType)
Table p t -> do
p' <- justCheck g p typeType --- check p partype!
t' <- justCheck g t typeType
return $ (Table p' t', typeType)
FV vs -> do
(_,ty) <- checks $ map (inferLType gr g) vs
--- checkIfComplexVariantType trm ty
checkLType gr g trm ty
EPattType ty -> do
ty' <- justCheck g ty typeType
return (EPattType ty',typeType)
EPatt p -> do
ty <- inferPatt p
return (trm, EPattType ty)
ELin c trm -> do
(trm',ty) <- inferLType gr g trm
ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
return $ (ELin c trm', ty')
_ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
where
isPredef m = elem m [cPredef,cPredefAbs]
justCheck g ty te = checkLType gr g ty te >>= return . fst
-- for record fields, which may be typed
inferM (mty, t) = do
(t', ty') <- case mty of
Just ty -> checkLType gr g t ty
_ -> inferLType gr g t
return (Just ty',t')
inferCase mty (patt,term) = do
arg <- maybe (inferPatt patt) return mty
cont <- pattContext gr g arg patt
(_,val) <- inferLType gr (reverse cont ++ g) term
return (arg,val)
isConstPatt p = case p of
PC _ ps -> True --- all isConstPatt ps
PP _ ps -> True --- all isConstPatt ps
PR ps -> all (isConstPatt . snd) ps
PT _ p -> isConstPatt p
PString _ -> True
PInt _ -> True
PFloat _ -> True
PChar -> True
PChars _ -> True
PSeq p q -> isConstPatt p && isConstPatt q
PAlt p q -> isConstPatt p && isConstPatt q
PRep p -> isConstPatt p
PNeg p -> isConstPatt p
PAs _ p -> isConstPatt p
_ -> False
inferPatt p = case p of
PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
PAs _ p -> inferPatt p
PNeg p -> inferPatt p
PAlt p q -> checks [inferPatt p, inferPatt q]
PSeq _ _ -> return $ typeStr
PRep _ -> return $ typeStr
PChar -> return $ typeStr
PChars _ -> return $ typeStr
_ -> inferLType gr g (patt2term p) >>= return . snd
-- type inference: Nothing, type checking: Just t
-- the latter permits matching with value type
getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
getOverload gr g mt ot = case appForm ot of
(f@(Q c), ts) -> case lookupOverload gr c of
Ok typs -> do
ttys <- mapM (inferLType gr g) ts
v <- matchOverload f typs ttys
return $ Just v
_ -> return Nothing
(AdHocOverload cs@(f:_), ts) -> do --- the function name f is only used in error messages
let typs = concatMap collectOverloads cs
ttys <- mapM (inferLType gr g) ts
v <- matchOverload f typs ttys
return $ Just v
_ -> return Nothing
where
collectOverloads tr@(Q c) = case lookupOverload gr c of
Ok typs -> typs
_ -> case lookupResType gr c of
Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
_ -> []
collectOverloads _ = [] --- constructors QC
matchOverload f typs ttys = do
let (tts,tys) = unzip ttys
let vfs = lookupOverloadInstance tys typs
let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
let showTypes ty = hsep (map ppType ty)
let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
-- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
let (stysError,stypsError) = if elem (render stys) (map render styps)
then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs])
else (stys,styps)
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
([(_,val,fun)],_) -> return (mkApp fun tts, val)
([],[(pre,val,fun)]) -> do
checkWarn $ "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
"for" $$
nest 2 (showTypes tys) $$
"using" $$
nest 2 (showTypes pre)
return (mkApp fun tts, val)
([],[]) -> do
checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
maybe empty (\x -> "with value type" <+> ppType x) mt $$
"for argument list" $$
nest 2 stysError $$
"among alternatives" $$
nest 2 (vcat stypsError)
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do
return (mkApp fun tts, val)
([],[(val,fun)]) -> do
checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
return (mkApp fun tts, val)
----- unsafely exclude irritating warning AR 24/5/2008
----- checkWarn $ "overloading of" +++ prt f +++
----- "resolved by excluding partial applications:" ++++
----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
--- now forgiving ambiguity with a warning AR 1/2/2014
-- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
-- But it also gives a chance to ambiguous overloadings that were banned before.
(nps1,nps2) -> do
checkWarn $ "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
---- "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
"resolved by selecting the first of the alternatives" $$
nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
[] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
h:_ -> return h
matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
unlocked v = case v of
RecType fs -> RecType $ filter (not . isLockLabel . fst) fs
_ -> v
---- TODO: accept subtypes
---- TODO: use a trie
lookupOverloadInstance tys typs =
[((pre,mkFunType rest val, t),isExact) |
let lt = length tys,
(ty,(val,t)) <- typs, length ty >= lt,
let (pre,rest) = splitAt lt ty,
let isExact = pre == tys,
isExact || map unlocked pre == map unlocked tys
]
noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
noProd ty = case ty of
Prod _ _ _ _ -> False
_ -> True
checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
checkLType gr g trm typ0 = do
typ <- computeLType gr g typ0
case trm of
Abs bt x c -> do
case typ of
Prod bt' z a b -> do
(c',b') <- if isWildIdent z
then checkLType gr ((bt,x,a):g) c b
else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
checkLType gr ((bt,x,a):g) c b'
return $ (Abs bt x c', Prod bt' z a b')
_ -> checkError $ "function type expected instead of" <+> ppType typ
App f a -> do
over <- getOverload gr g (Just typ) trm
case over of
Just trty -> return trty
_ -> do
(trm',ty') <- inferLType gr g trm
termWith trm' $ checkEqLType gr g typ ty' trm'
AdHocOverload ts -> do
over <- getOverload gr g Nothing trm
case over of
Just trty -> return trty
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
Q _ -> do
over <- getOverload gr g (Just typ) trm
case over of
Just trty -> return trty
_ -> do
(trm',ty') <- inferLType gr g trm
termWith trm' $ checkEqLType gr g typ ty' trm'
T _ [] ->
checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
T _ cs -> case typ of
Table arg val -> do
case allParamValues gr arg of
Ok vs -> do
let ps0 = map fst cs
ps <- testOvershadow ps0 vs
if null ps
then return ()
else checkWarn ("patterns never reached:" $$
nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
_ -> return () -- happens with variable types
cs' <- mapM (checkCase arg val) cs
return (T (TTyped arg) cs', typ)
_ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
V arg0 vs ->
case typ of
Table arg1 val ->
do arg' <- checkEqLType gr g arg0 arg1 trm
vs1 <- allParamValues gr arg1
if length vs1 == length vs
then return ()
else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
return (V arg' vs',typ)
R r -> case typ of --- why needed? because inference may be too difficult
RecType rr -> do
--let (ls,_) = unzip rr -- labels of expected type
fsts <- mapM (checkM r) rr -- check that they are found in the record
return $ (R fsts, typ) -- normalize record
_ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
ExtR r s -> case typ of
_ | typ == typeType -> do
trm' <- computeLType gr g trm
case trm' of
RecType _ -> termWith trm' $ return typeType
ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
-- ext t = t ** ...
_ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
RecType rr -> do
ll2 <- case s of
R ss -> return $ map fst ss
_ -> do
(s',typ2) <- inferLType gr g s
case typ2 of
RecType ss -> return $ map fst ss
_ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
let ll1 = [l | (l,_) <- rr, notElem l ll2]
(r',_) <- checkLType gr g r (RecType [field | field@(l,_) <- rr, elem l ll1])
(s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2])
let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
return (rec, typ)
ExtR ty ex -> do
r' <- justCheck g r ty
s' <- justCheck g s ex
return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
_ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
FV vs -> do
ttys <- mapM (flip (checkLType gr g) typ) vs
--- checkIfComplexVariantType trm typ
return (FV (map fst ttys), typ) --- typ' ?
S tab arg -> checks [ do
(tab',ty) <- inferLType gr g tab
ty' <- computeLType gr g ty
case ty' of
Table p t -> do
(arg',val) <- checkLType gr g arg p
checkEqLType gr g typ t trm
return (S tab' arg', t)
_ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
, do
(arg',ty) <- inferLType gr g arg
ty' <- computeLType gr g ty
(tab',_) <- checkLType gr g tab (Table ty' typ)
return (S tab' arg', typ)
]
Let (x,(mty,def)) body -> case mty of
Just ty -> do
(ty0,_) <- checkLType gr g ty typeType
(def',ty') <- checkLType gr g def ty0
body' <- justCheck ((Explicit,x,ty'):g) body typ
return (Let (x,(Just ty',def')) body', typ)
_ -> do
(def',ty) <- inferLType gr g def -- tries to infer type of local constant
checkLType gr g (Let (x,(Just ty,def')) body) typ
ELin c tr -> do
tr1 <- unlockRecord c tr
checkLType gr g tr1 typ
_ -> do
(trm',ty') <- inferLType gr g trm
termWith trm' $ checkEqLType gr g typ ty' trm'
where
justCheck g ty te = checkLType gr g ty te >>= return . fst
{-
recParts rr t = (RecType rr1,RecType rr2) where
(rr1,rr2) = partition (flip elem (map fst t) . fst) rr
-}
checkM rms (l,ty) = case lookup l rms of
Just (Just ty0,t) -> do
checkEqLType gr g ty ty0 t
(t',ty') <- checkLType gr g t ty
return (l,(Just ty',t'))
Just (_,t) -> do
(t',ty') <- checkLType gr g t ty
return (l,(Just ty',t'))
_ -> checkError $
if isLockLabel l
then let cat = drop 5 (showIdent (label2ident l))
in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
"; try wrapping it with lin" <+> cat
else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
checkCase arg val (p,t) = do
cont <- pattContext gr g arg p
t' <- justCheck (reverse cont ++ g) t val
return (p,t')
pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
pattContext env g typ p = case p of
PV x -> return [(Explicit,x,typ)]
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- lookupResType env (q,c)
let (cont,v) = typeFormCnc t
checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps)
checkEqLType env g typ v (patt2term p)
mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
PR r -> do
typ' <- computeLType env g typ
case typ' of
RecType t -> do
let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
----- checkWarn $ prt p ++++ show pts ----- debug
mapM (uncurry (pattContext env g)) pts >>= return . concat
_ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
PT t p' -> do
checkEqLType env g typ t (patt2term p')
pattContext env g typ p'
PAs x p -> do
g' <- pattContext env g typ p
return ((Explicit,x,typ):g')
PAlt p' q -> do
g1 <- pattContext env g typ p'
g2 <- pattContext env g typ q
let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
checkCond
("incompatible bindings of" <+>
fsep pts <+>
"in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
return g1 -- must be g1 == g2
PSeq p q -> do
g1 <- pattContext env g typ p
g2 <- pattContext env g typ q
return $ g1 ++ g2
PRep p' -> noBind typeStr p'
PNeg p' -> noBind typ p'
_ -> return [] ---- check types!
where
noBind typ p' = do
co <- pattContext env g typ p'
if not (null co)
then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
>> return []
else return []
checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
checkEqLType gr g t u trm = do
(b,t',u',s) <- checkIfEqLType gr g t u trm
case b of
True -> return t'
False -> checkError $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$
"expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
"inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
checkIfEqLType gr g t u trm = do
t' <- computeLType gr g t
u' <- computeLType gr g u
case t' == u' || alpha [] t' u' of
True -> return (True,t',u',[])
-- forgive missing lock fields by only generating a warning.
--- better: use a flag to forgive? (AR 31/1/2006)
_ -> case missingLock [] t' u' of
Ok lo -> do
checkWarn $ "missing lock field" <+> fsep lo
return (True,t',u',[])
Bad s -> return (False,t',u',s)
where
-- check that u is a subtype of t
--- quick hack version of TC.eqVal
alpha g t u = case (t,u) of
-- error (the empty type!) is subtype of any other type
(_,u) | u == typeError -> True
-- contravariance
(Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
-- record subtyping
(RecType rs, RecType ts) -> all (\ (l,a) ->
any (\ (k,b) -> l == k && alpha g a b) ts) rs
(ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
(ExtR r s, t) -> alpha g r t || alpha g s t
-- the following say that Ints n is a subset of Int and of Ints m >= n
-- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
(t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
| Just _ <- isTypeInts t, u == typeInt -> True ---- check size!
| t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
---- this should be made in Rename
(Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
|| m == n --- for Predef
(QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
-- contravariance
(Table a b, Table c d) -> alpha g c a && alpha g b d
(Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g
_ -> t == u
--- the following should be one-way coercions only. AR 4/1/2001
|| elem t sTypes && elem u sTypes
|| (t == typeType && u == typePType)
|| (u == typeType && t == typePType)
missingLock g t u = case (t,u) of
(RecType rs, RecType ts) ->
let
ls = [l | (l,a) <- rs,
not (any (\ (k,b) -> alpha g a b && l == k) ts)]
(locks,others) = partition isLockLabel ls
in case others of
_:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
_ -> return locks
-- contravariance
(Prod _ x a b, Prod _ y c d) -> do
ls1 <- missingLock g c a
ls2 <- missingLock g b d
return $ ls1 ++ ls2
_ -> Bad ""
sTypes = [typeStr, typeTok, typeString]
-- auxiliaries
-- | light-weight substitution for dep. types
substituteLType :: Context -> Type -> Check Type
substituteLType g t = case t of
Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
_ -> composOp (substituteLType g) t
termWith :: Term -> Check Type -> Check (Term, Type)
termWith t ct = do
ty <- ct
return (t,ty)
-- | compositional check\/infer of binary operations
check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
Term -> Term -> Type -> Check (Term,Type)
check2 chk con a b t = do
a' <- chk a
b' <- chk b
return (con a' b', t)
-- printing a type with a lock field lock_C as C
ppType :: Type -> Doc
ppType ty =
case ty of
RecType fs -> case filter isLockLabel $ map fst fs of
[lock] -> pp (drop 5 (showIdent (label2ident lock)))
_ -> ppTerm Unqualified 0 ty
Prod _ x a b -> ppType a <+> "->" <+> ppType b
_ -> ppTerm Unqualified 0 ty
{-
ppqType :: Type -> Type -> Doc
ppqType t u = case (ppType t, ppType u) of
(pt,pu) | render pt == render pu -> ppTerm Qualified 0 t
(pt,_) -> pt
-}
checkLookup :: Ident -> Context -> Check Type
checkLookup x g =
case [ty | (b,y,ty) <- g, x == y] of
[] -> checkError ("unknown variable" <+> x)
(ty:_) -> return ty

88
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -5,22 +5,21 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.11 $
--
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck.TC (
AExp(..),
Theory,
checkExp,
inferExp,
checkBranch,
eqVal,
whnf
) where
module GF.Compile.TypeCheck.TC (AExp(..),
Theory,
checkExp,
inferExp,
checkBranch,
eqVal,
whnf
) where
import GF.Data.Operations
import GF.Grammar
@@ -32,17 +31,17 @@ import Data.Maybe
import GF.Text.Pretty
data AExp =
AVr Ident Val
AVr Ident Val
| ACn QIdent Val
| AType
| AInt Int
| AType
| AInt Int
| AFloat Double
| AStr String
| AMeta MetaId Val
| ALet (Ident,(Val,AExp)) AExp
| AApp AExp AExp Val
| AAbs Ident Val AExp
| AProd Ident AExp AExp
| AApp AExp AExp Val
| AAbs Ident Val AExp
| AProd Ident AExp AExp
-- -- | AEqs [([Exp],AExp)] --- not used
| ARecType [ALabelling]
| AR [AAssign]
@@ -51,7 +50,7 @@ data AExp =
| AData Val
deriving (Eq,Show)
type ALabelling = (Label, AExp)
type ALabelling = (Label, AExp)
type AAssign = (Label, (Val, AExp))
type Theory = QIdent -> Err Val
@@ -72,7 +71,7 @@ whnf :: Val -> Err Val
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
case v of
VApp u w -> do
u' <- whnf u
u' <- whnf u
w' <- whnf w
app u' w'
VClos env e -> eval env e
@@ -82,9 +81,9 @@ app :: Val -> Val -> Err Val
app u v = case u of
VClos env (Abs _ x e) -> eval ((x,v):env) e
_ -> return $ VApp u v
eval :: Env -> Term -> Err Val
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
Q c -> return $ VCn c
@@ -96,23 +95,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
_ -> return $ VClos env e
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
do
w1 <- whnf u1
w2 <- whnf u2
w2 <- whnf u2
let v = VGen k
case (w1,w2) of
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
(VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
(VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
liftM2 (++)
liftM2 (++)
(eqVal k (VClos env1 a1) (VClos env2 a2))
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
--- thus ignore qualifications; valid because inheritance cannot
--- be qualified. Simplifies annotation. AR 17/3/2005
--- be qualified. Simplifies annotation. AR 17/3/2005
_ -> return [(w1,w2) | w1 /= w2]
-- invariant: constraints are in whnf
@@ -128,10 +127,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do
Abs _ x t -> case typ of
VClos env (Prod _ y a b) -> do
a' <- whnf $ VClos env a ---
(t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs)
a' <- whnf $ VClos env a ---
(t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs)
_ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
Let (x, (mb_typ, e1)) e2 -> do
@@ -151,7 +150,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
return (AProd x a' b', csa ++ csb)
R xs ->
R xs ->
case typ of
VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
[] -> return ()
@@ -175,7 +174,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
(e',w,cs1) <- inferExp th tenv e
cs2 <- eqVal k w typ
return (e',cs1 ++ cs2)
inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -201,13 +200,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
(e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
App f t -> do
(f',w,csf) <- inferExp th tenv f
(f',w,csf) <- inferExp th tenv f
typ <- whnf w
case typ of
VClos env (Prod _ x a b) -> do
(a',csa) <- checkExp th tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
@@ -233,9 +232,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
return ((lbl,(val,aexp)),cs)
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
chB tenv' ps' ty
where
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
chB tenv' ps' ty
where
(ps',_,rho2,k') = ps2ts k ps
tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -246,11 +245,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
typ <- whnf ty
case typ of
VClos env (Prod _ y a b) -> do
a' <- whnf $ VClos env a
a' <- whnf $ VClos env a
(p', sigma, binds, cs1) <- checkP tenv p y a'
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
[] -> do
(e,cs) <- checkExp th tenv t ty
@@ -260,15 +259,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
return (VClos sigma t, sigma, delta, cs)
ps2ts k = foldr p2t ([],0,[],k)
ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
PW -> (Meta i : ps, i+1,g,k)
PW -> (Meta i : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PAs x p -> p2t p (ps,i,g,k)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
PImplArg p -> p2t p (ps,i,g,k)
PTilde t -> (t : ps, i, g, k)
@@ -308,8 +307,8 @@ checkPatt th tenv exp val = do
case typ of
VClos env (Prod _ x a b) -> do
(a',_,csa) <- checkExpP tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
@@ -322,3 +321,4 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
mkAnnot a ti = do
(v,cs) <- ti
return (a v, v, cs)

82
src/compiler/GF/Compile/Update.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
@@ -27,21 +27,20 @@ import Data.List
import qualified Data.Map as Map
import Control.Monad
import GF.Text.Pretty
import qualified Control.Monad.Fail as Fail
-- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
buildAnyTree m = go Map.empty
where
go map [] = return map
go map ((c,j):is) =
go map ((c,j):is) = do
case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of
Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render ("conflicting information in module"<+>m $$
nest 4 (ppJudgement Qualified (c,i)) $$
"and" $+$
nest 4 (ppJudgement Qualified (c,j)))
Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render ("conflicting information in module"<+>m $$
nest 4 (ppJudgement Qualified (c,i)) $$
"and" $+$
nest 4 (ppJudgement Qualified (c,j)))
Nothing -> go (Map.insert c j map) is
extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -51,14 +50,14 @@ extendModule cwd gr (name,m)
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = checkInModule cwd m NoLoc empty $ do
m' <- foldM extOne m (mextend m)
m' <- foldM extOne m (mextend m)
return (name,m')
where
extOne mo (n,cond) = do
m0 <- lookupModule gr n
-- test that the module types match, and find out if the old is complete
unless (sameMType (mtype m) (mtype mo))
unless (sameMType (mtype m) (mtype mo))
(checkError ("illegal extension type to module" <+> name))
let isCompl = isCompleteModule m0
@@ -67,7 +66,7 @@ extendModule cwd gr (name,m)
js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
-- if incomplete, throw away extension information
return $
return $
if isCompl
then mo {jments = js1}
else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -75,7 +74,7 @@ extendModule cwd gr (name,m)
,jments = js1
}
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -88,8 +87,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- add the information given in interface into an instance module
Nothing -> do
unless (null is || mstatus mi == MSIncomplete)
(checkError ("module" <+> i <+>
unless (null is || mstatus mi == MSIncomplete)
(checkError ("module" <+> i <+>
"has open interfaces and must therefore be declared incomplete"))
case mt of
MTInstance (i0,mincl) -> do
@@ -110,10 +109,9 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- add the instance opens to an incomplete module "with" instances
Just (ext,incl,ops) -> do
let (infs,insts) = unzip ops
let stat' = if all (flip elem infs) is
then MSComplete
else MSIncomplete
unless (stat' == MSComplete || stat == MSIncomplete)
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
unless (stat' == MSComplete || stat == MSIncomplete)
(checkError ("module" <+> i <+> "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
let ops1 = nub $
@@ -141,24 +139,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName ->
Map.Map Ident Info -> Check (Map.Map Ident Info)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
Ok k -> return $ Map.insert c k new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j)
(name,i) <- case i of
Ok k -> return $ Map.insert c k new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j)
(name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i)
checkError ("cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$
"in module" <+> name <+> "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$
"in module" <+> base)
checkError ("cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$
"in module" <+> name <+> "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$
"in module" <+> base)
Nothing-> if isCompl
then return $ Map.insert c (indirInfo name i) new
else return $ Map.insert c i new
@@ -166,11 +164,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
i = globalizeLoc (msrc mi) i0
indirInfo :: ModuleName -> Info -> Info
indirInfo n info = AnyInd b n' where
indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResValue _ _ -> (True,n)
ResParam _ _ -> (True,n)
AbsFun _ _ Nothing _ -> (True,n)
AbsFun _ _ Nothing _ -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
@@ -179,7 +177,7 @@ globalizeLoc fpath i =
AbsCat mc -> AbsCat (fmap gl mc)
AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
ResParam mt mv -> ResParam (fmap gl mt) mv
ResValue t -> ResValue (gl t)
ResValue t offset -> ResValue (gl t) offset
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -194,24 +192,24 @@ globalizeLoc fpath i =
unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) ->
(AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifyMaybeL mc1 mc2)
(AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
(AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
(ResValue (L l1 t1), ResValue (L l2 t2))
| t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
| t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) ->
(ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
(AnyInd b1 m1, AnyInd b2 m2) -> do

20
src/compiler/GF/CompileInParallel.hs
View File

@@ -1,6 +1,6 @@
-- | Parallel grammar compilation
module GF.CompileInParallel(parallelBatchCompile) where
import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import Prelude hiding (catch)
import Control.Monad(join,ap,when,unless)
import Control.Applicative
import GF.Infra.Concurrency
@@ -20,8 +20,6 @@ import GF.Infra.Ident(moduleNameS)
import GF.Text.Pretty
import GF.System.Console(TermColors(..),getTermColors)
import qualified Data.ByteString.Lazy as BS
-- Control.Monad.Fail import will become redundant in GHC 8.8+
import qualified Control.Monad.Fail as Fail
-- | Compile the given grammar files and everything they depend on,
-- like 'batchCompile'. This function compiles modules in parallel.
@@ -36,11 +34,8 @@ import qualified Control.Monad.Fail as Fail
parallelBatchCompile jobs opts rootfiles0 =
do setJobs jobs
rootfiles <- mapM canonical rootfiles0
lib_dirs1 <- getLibraryDirectory opts
lib_dirs2 <- mapM canonical lib_dirs1
let lib_dir = head lib_dirs2
when (length lib_dirs2 >1) $ ePutStrLn ("GF_LIB_PATH defines more than one directory; using the first, " ++ show lib_dir)
filepaths <- mapM (getPathFromFile [lib_dir] opts) rootfiles
lib_dir <- canonical =<< getLibraryDirectory opts
filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
let groups = groupFiles lib_dir filepaths
n = length groups
when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
@@ -85,7 +80,7 @@ batchCompile1 lib_dir (opts,filepaths) =
let rel = relativeTo lib_dir cwd
prelude_dir = lib_dir</>"prelude"
gfoDir = flag optGFODir opts
maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
maybe done (D.createDirectoryIfMissing True) gfoDir
{-
liftIO $ writeFile (maybe "" id gfoDir</>"paths")
(unlines . map (unwords . map rel) . nub $ map snd filepaths)
@@ -243,14 +238,14 @@ instance (Functor m,Monad m) => Applicative (CollectOutput m) where
(<*>) = ap
instance Monad m => Monad (CollectOutput m) where
return x = CO (return (return (),x))
return x = CO (return (done,x))
CO m >>= f = CO $ do (o1,x) <- m
let CO m2 = f x
(o2,y) <- m2
return (o1>>o2,y)
instance MonadIO m => MonadIO (CollectOutput m) where
liftIO io = CO $ do x <- liftIO io
return (return (),x)
return (done,x)
instance Output m => Output (CollectOutput m) where
ePutStr s = CO (return (ePutStr s,()))
@@ -258,9 +253,6 @@ instance Output m => Output (CollectOutput m) where
putStrLnE s = CO (return (putStrLnE s,()))
putStrE s = CO (return (putStrE s,()))
instance Fail.MonadFail m => Fail.MonadFail (CollectOutput m) where
fail = CO . fail
instance ErrorMonad m => ErrorMonad (CollectOutput m) where
raise e = CO (raise e)
handle (CO m) h = CO $ handle m (unCO . h)

13
src/compiler/GF/CompileOne.hs
View File

@@ -21,7 +21,7 @@ import GF.Grammar.Binary(decodeModule,encodeModule)
import GF.Infra.Option
import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE)
import GF.Infra.CheckM(runCheck')
import GF.Data.Operations(ErrorMonad,liftErr,(+++))
import GF.Data.Operations(ErrorMonad,liftErr,(+++),done)
import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
import System.FilePath(makeRelative)
@@ -30,13 +30,12 @@ import qualified Data.Map as Map
import GF.Text.Pretty(render,(<+>),($$)) --Doc,
import GF.System.Console(TermColors(..),getTermColors)
import Control.Monad((<=<))
import qualified Control.Monad.Fail as Fail
type OneOutput = (Maybe FullPath,CompiledModule)
type CompiledModule = Module
compileOne, reuseGFO, useTheSource ::
(Output m,ErrorMonad m,MonadIO m, Fail.MonadFail m) =>
(Output m,ErrorMonad m,MonadIO m) =>
Options -> Grammar -> FullPath -> m OneOutput
-- | Compile a given source file (or just load a .gfo file),
@@ -67,7 +66,7 @@ reuseGFO opts srcgr file =
if flag optTagsOnly opts
then writeTags opts srcgr (gf2gftags opts file) sm1
else return ()
else done
return (Just file,sm)
@@ -138,7 +137,7 @@ compileSourceModule opts cwd mb_gfFile gr =
idump opts pass (dump out)
return (ret out)
maybeM f = maybe (return ()) f
maybeM f = maybe done f
--writeGFO :: Options -> InitPath -> FilePath -> SourceModule -> IOE ()
@@ -159,12 +158,12 @@ writeGFO opts cwd file mo =
--intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return ()
| otherwise = done
idump opts pass = intermOut opts (Dump pass) . ppModule Internal
warnOut opts warnings
| null warnings = return ()
| null warnings = done
| otherwise = do t <- getTermColors
ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
where

52
src/compiler/GF/Compiler.hs
View File

@@ -1,8 +1,7 @@
module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
import PGF
import PGF.Internal(concretes,optimizePGF,unionPGF)
import PGF.Internal(putSplitAbs,encodeFile,runPut)
import PGF2
import PGF2.Internal(unionPGF,writePGF,writeConcr)
import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export
@@ -92,7 +91,7 @@ compileSourceFiles opts fs =
-- in the 'Options') from the output of 'parallelBatchCompile'.
-- If a @.pgf@ file by the same name already exists and it is newer than the
-- source grammar files (as indicated by the 'UTCTime' argument), it is not
-- recreated. Calls 'writePGF' and 'writeOutputs'.
-- recreated. Calls 'writeGrammar' and 'writeOutputs'.
linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
do let abs = render (srcAbsName gr cnc)
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -102,10 +101,8 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
if t_pgf >= Just t_src
then putIfVerb opts $ pgfFile ++ " is up-to-date."
else do pgfs <- mapM (link opts) cnc_grs
let pgf0 = foldl1 unionPGF pgfs
probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf0
let pgf = setProbabilities probs pgf0
writePGF opts pgf
let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
writeGrammar opts pgf
writeOutputs opts pgf
compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -115,12 +112,11 @@ compileCFFiles opts fs = do
startCat <- case rules of
(Rule cat _ _ : _) -> return cat
_ -> fail "empty CFG"
let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
unless (flag optStopAfterPhase opts == Compile) $
do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
writePGF opts pgf'
writeOutputs opts pgf'
do writeGrammar opts pgf
writeOutputs opts pgf
unionPGFFiles :: Options -> [FilePath] -> IOE ()
unionPGFFiles opts fs =
@@ -138,14 +134,11 @@ unionPGFFiles opts fs =
doIt =
do pgfs <- mapM readPGFVerbose fs
let pgf0 = foldl1 unionPGF pgfs
pgf1 = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf1)
let pgf = setProbabilities probs pgf1
pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
if pgfFile `elem` fs
then putStrLnE $ "Refusing to overwrite " ++ pgfFile
else writePGF opts pgf
else writeGrammar opts pgf
writeOutputs opts pgf
readPGFVerbose f =
@@ -162,21 +155,20 @@ writeOutputs opts pgf = do
-- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
-- 'link') to a @.pgf@ file.
-- A split PGF file is output if the @-split-pgf@ option is used.
writePGF :: Options -> PGF -> IOE ()
writePGF opts pgf =
if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
writeGrammar :: Options -> PGF -> IOE ()
writeGrammar opts pgf =
if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
where
writeNormalPGF =
do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
writing opts outfile $ encodeFile outfile pgf
writing opts outfile (writePGF outfile pgf)
writeSplitPGF =
do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
--encodeFile_ outfile (putSplitAbs pgf)
forM_ (Map.toList (concretes pgf)) $ \cnc -> do
let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
writing opts outfile $ encodeFile outfile cnc
writing opts outfile $ writePGF outfile pgf
forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
let outfile = outputPath opts (concrname <.> "pgf_c")
writing opts outfile (writeConcr outfile concr)
writeOutput :: Options -> FilePath-> String -> IOE ()
@@ -186,7 +178,7 @@ writeOutput opts file str = writing opts path $ writeUTF8File path str
-- * Useful helper functions
grammarName :: Options -> PGF -> String
grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
grammarName opts pgf = grammarName' opts (abstractName pgf)
grammarName' opts abs = fromMaybe abs (flag optName opts)
outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)

34
src/compiler/GF/Data/BacktrackM.hs
View File

@@ -13,27 +13,25 @@
-----------------------------------------------------------------------------
{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module GF.Data.BacktrackM (
-- * the backtracking state monad
BacktrackM,
-- * monad specific utilities
member,
cut,
-- * running the monad
foldBM, runBM,
foldSolutions, solutions,
foldFinalStates, finalStates,
-- * reexport the 'MonadState' class
module Control.Monad.State.Class,
) where
BacktrackM,
-- * monad specific utilities
member,
cut,
-- * running the monad
foldBM, runBM,
foldSolutions, solutions,
foldFinalStates, finalStates,
-- * reexport the 'MonadState' class
module Control.Monad.State.Class,
) where
import Data.List
import Control.Applicative
import Control.Monad
import Control.Monad.State.Class
import qualified Control.Monad.Fail as Fail
----------------------------------------------------------------------
-- Combining endomorphisms and continuations
@@ -70,13 +68,7 @@ instance Applicative (BacktrackM s) where
instance Monad (BacktrackM s) where
return a = BM (\c s b -> c a s b)
BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
where unBM (BM m) = m
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
#endif
instance Fail.MonadFail (BacktrackM s) where
where unBM (BM m) = m
fail _ = mzero
instance Functor (BacktrackM s) where

13
src/compiler/GF/Data/ErrM.hs
View File

@@ -12,12 +12,10 @@
-- hack for BNFC generated files. AR 21/9/2003
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module GF.Data.ErrM where
import Control.Monad (MonadPlus(..),ap)
import Control.Applicative
import qualified Control.Monad.Fail as Fail
-- | Like 'Maybe' type with error msgs
data Err a = Ok a | Bad String
@@ -35,19 +33,10 @@ fromErr a = err (const a) id
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
#if !(MIN_VERSION_base(4,13,0))
-- Monad(fail) will be removed in GHC 8.8+
fail = Fail.fail
#endif
instance Fail.MonadFail Err where
fail = Bad
-- | added 2\/10\/2003 by PEB
instance Functor Err where
fmap f (Ok a) = Ok (f a)

20
src/compiler/GF/Data/Graph.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
@@ -34,7 +34,7 @@ import Data.Set (Set)
import qualified Data.Set as Set
data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
deriving (Eq,Show)
deriving (Eq,Show)
type Node n a = (n,a)
type Edge n b = (n,n,b)
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
-- | Add a node to the graph.
newNode :: a -- ^ Node label
-> Graph n a b
-> Graph n a b
-> (Graph n a b,n) -- ^ Node graph and name of new node
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
-- lazy version:
-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
insertEdgeWith :: Eq n =>
insertEdgeWith :: Eq n =>
(b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
where h [] = [e]
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
-- | Remove a set of nodes and all edges to and from those nodes.
removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
removeNodes xs (Graph c ns es) = Graph c ns' es'
where
where
keepNode n = not (Set.member n xs)
ns' = [ x | x@(n,_) <- ns, keepNode n ]
es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
-- | Get a map of node names to info about each node.
nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
where
where
inc = groupEdgesBy edgeTo g
out = groupEdgesBy edgeFrom g
fn m n = fromMaybe [] (Map.lookup n m)
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
-- | Add the nodes from the second graph to the first graph.
-- The nodes in the second graph will be renamed using the name
-- The nodes in the second graph will be renamed using the name
-- supply in the first graph.
-- This function is more efficient when the second graph
-- is smaller than the first.
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
-> (Graph n a b, m -> n) -- ^ The new graph and a function translating
-- the old names of nodes in the second graph
-- to names in the new graph.
mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
where
where
(xs,c') = splitAt (length (nodes g2)) c
newNames = Map.fromList (zip (map fst (nodes g2)) xs)
newName n = fromJust $ Map.lookup n newNames
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
-> Graph n a b -> Graph m a b
renameNodes newName c (Graph _ ns es) = Graph c ns' es'
where ns' = map' (\ (n,x) -> (newName n,x)) ns
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
-- | A strict 'map'
map' :: (a -> b) -> [a] -> [b]

28
src/compiler/GF/Data/Graphviz.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
@@ -13,14 +13,14 @@
-----------------------------------------------------------------------------
module GF.Data.Graphviz (
Graph(..), GraphType(..),
Node(..), Edge(..),
Attr,
addSubGraphs,
setName,
setAttr,
prGraphviz
) where
Graph(..), GraphType(..),
Node(..), Edge(..),
Attr,
addSubGraphs,
setName,
setAttr,
prGraphviz
) where
import Data.Char
@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
prSubGraph :: Graph -> String
prSubGraph g@(Graph _ i _ _ _ _) =
prSubGraph g@(Graph _ i _ _ _ _) =
"subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
prGraph :: Graph -> String
prGraph (Graph t id at ns es ss) =
prGraph (Graph t id at ns es ss) =
unlines $ map (++";") (map prAttr at
++ map prNode ns
++ map (prEdge t) es
++ map prNode ns
++ map (prEdge t) es
++ map prSubGraph ss)
graphtype :: GraphType -> String
@@ -96,7 +96,7 @@ edgeop Undirected = "--"
prAttrList :: [Attr] -> String
prAttrList [] = ""
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
prAttr :: Attr -> String
prAttr (n,v) = esc n ++ " = " ++ esc v

99
src/compiler/GF/Data/Operations.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 16:12:41 $
-- > CVS $Date: 2005/11/11 16:12:41 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.22 $
--
@@ -15,34 +15,35 @@
-----------------------------------------------------------------------------
module GF.Data.Operations (
-- ** The Error monad
Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
-- ** The Error monad
Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
-- ** Error monad class
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
liftErr,
-- ** Error monad class
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
liftErr,
-- ** Checking
checkUnique, unifyMaybeBy, unifyMaybe,
-- ** Checking
checkUnique, unifyMaybeBy, unifyMaybe,
-- ** Monadic operations on lists and pairs
mapPairListM, mapPairsM, pairM,
-- ** Printing
indent, (+++), (++-), (++++), (+++-), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** Monadic operations on lists and pairs
mapPairsM, pairM,
-- ** Topological sorting
topoTest, topoTest2,
-- ** Printing
indent, (+++), (++-), (++++), (+++-), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** Topological sorting
topoTest, topoTest2,
-- ** Misc
readIntArg,
iterFix, chunks,
) where
-- ** Misc
ifNull,
combinations, done, readIntArg, --singleton,
iterFix, chunks,
) where
import Data.Char (isSpace, toUpper, isSpace, isDigit)
import Data.List (nub, partition, (\\))
@@ -53,13 +54,15 @@ import Control.Monad (liftM,liftM2) --,ap
import GF.Data.ErrM
import GF.Data.Relation
import qualified Control.Monad.Fail as Fail
infixr 5 +++
infixr 5 ++-
infixr 5 ++++
infixr 5 +++++
ifNull :: b -> ([a] -> b) -> [a] -> b
ifNull b f xs = if null xs then b else f xs
-- the Error monad
-- | Add msg s to 'Maybe' failures
@@ -67,7 +70,7 @@ maybeErr :: ErrorMonad m => String -> Maybe a -> m a
maybeErr s = maybe (raise s) return
testErr :: ErrorMonad m => Bool -> String -> m ()
testErr cond msg = if cond then return () else raise msg
testErr cond msg = if cond then done else raise msg
errIn :: ErrorMonad m => String -> m a -> m a
errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
@@ -75,6 +78,9 @@ errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
@@ -89,10 +95,10 @@ checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
overloaded s = length (filter (==s) ss) > 1
-- | this is what happens when matching two values in the same module
unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a)
unifyMaybe :: (Eq a, Monad m) => Maybe a -> Maybe a -> m (Maybe a)
unifyMaybe = unifyMaybeBy id
unifyMaybeBy :: (Eq b, Fail.MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
unifyMaybeBy :: (Eq b, Monad m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
unifyMaybeBy f (Just p1) (Just p2)
| f p1==f p2 = return (Just p1)
| otherwise = fail ""
@@ -107,7 +113,7 @@ indent i s = replicate i ' ' ++ s
(+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
a +++ b = a ++ " " ++ b
a ++- "" = a
a ++- "" = a
a ++- b = a +++ b
a ++++ b = a ++ "\n" ++ b
@@ -145,20 +151,20 @@ prCurly s = "{" ++ s ++ "}"
prBracket s = "[" ++ s ++ "]"
prArgList, prSemicList, prCurlyList :: [String] -> String
prArgList = prParenth . prTList ","
prArgList = prParenth . prTList ","
prSemicList = prTList " ; "
prCurlyList = prCurly . prSemicList
restoreEscapes :: String -> String
restoreEscapes s =
case s of
restoreEscapes s =
case s of
[] -> []
'"' : t -> '\\' : '"' : restoreEscapes t
'\\': t -> '\\' : '\\' : restoreEscapes t
c : t -> c : restoreEscapes t
numberedParagraphs :: [[String]] -> [String]
numberedParagraphs t = case t of
numberedParagraphs t = case t of
[] -> []
p:[] -> p
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
@@ -187,6 +193,21 @@ wrapLines n s@(c:cs) =
l = length w
_ -> s -- give up!!
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-- | 'combinations' is the same as 'sequence'!!!
-- peb 30\/5-04
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu]
{-
-- | 'singleton' is the same as 'return'!!!
singleton :: a -> [a]
singleton = (:[])
-}
-- | Topological sorting with test of cyclicity
topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
topoTest = topologicalSort . mkRel'
@@ -204,12 +225,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
([],[]) -> Just []
([],_) -> Nothing
(ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
where leaves = map fst ns
where leaves = map fst ns
-- | Fix point iterator (for computing e.g. transitive closures or reachability)
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
iterFix more start = iter start start
iterFix more start = iter start start
where
iter old new = if (null new')
then old
@@ -226,6 +247,10 @@ chunks sep ws = case span (/= sep) ws of
readIntArg :: String -> Int
readIntArg n = if (not (null n) && all isDigit n) then read n else 0
-- | @return ()@
done :: Monad m => m ()
done = return ()
class (Functor m,Monad m) => ErrorMonad m where
raise :: String -> m a
handle :: m a -> (String -> m a) -> m a
@@ -241,7 +266,7 @@ liftErr e = err raise return e
{-
instance ErrorMonad (STM s) where
raise msg = STM (\s -> raise msg)
handle (STM f) g = STM (\s -> (f s)
handle (STM f) g = STM (\s -> (f s)
`handle` (\e -> let STM g' = (g e) in
g' s))

18
src/compiler/GF/Data/Relation.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $
--
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-> Rel a -> Rel a
-> Rel a -> Rel a
reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-- | Uses 'domain'
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-- | Keep the related pairs for which the predicate is true.
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
-- | Remove keys that map to no elements.
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
in (r', Map.keysSet r'')
-- | Get the equivalence classes from an equivalence relation.
-- | Get the equivalence classes from an equivalence relation.
equivalenceClasses :: Ord a => Rel a -> [Set a]
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
where equivalenceClasses_ [] _ = []
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
where ys = allRelated r x
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
where ys = allRelated r x
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
isTransitive :: Ord a => Rel a -> Bool
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
y <- Set.toList ys, z <- Set.toList (allRelated r y)]
isReflexive :: Ord a => Rel a -> Bool
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
Nothing -> (r', Set.empty, Set.empty)
-- remove element from all incoming and outgoing sets
-- of other elements
Just (is,os) ->
Just (is,os) ->
let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is
r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
in (r''', is, os)
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
incoming x r = maybe Set.empty fst $ Map.lookup x r
--outgoing :: Ord a => a -> Rel' a -> Set a
--outgoing x r = maybe Set.empty snd $ Map.lookup x r
--outgoing x r = maybe Set.empty snd $ Map.lookup x r

10
src/compiler/GF/Data/Utilities.hs
View File

@@ -4,7 +4,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
@@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n
lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
| otherwise = lookupList a ps
| otherwise = lookupList a ps
split :: [a] -> ([a], [a])
split (x : y : as) = (x:xs, y:ys)
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
foldMerge :: (a -> a -> a) -> a -> [a] -> a
foldMerge merge zero = fm
where fm [] = zero
fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
select :: [a] -> [(a, [a])]
select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs
-- | Sorts and then groups elements given an ordering of the
-- | Sorts and then groups elements given an ordering of the
-- elements.
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
sortGroupBy f = groupBy (compareEq f) . sortBy f

6
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -29,7 +29,7 @@ stripInfo i = case i of
AbsCat _ -> i
AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
ResParam mp mt -> ResParam mp Nothing
ResValue lt -> i ----
ResValue _ lt -> i ----
ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
@@ -107,8 +107,8 @@ sizeInfo i = case i of
AbsFun mt mi me mb -> 1 + msize mt +
sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
ResParam mp mt ->
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
ResValue lt -> 0
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co,_) <- ps]
ResValue _ lt -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
CncCat mty _ _ _ _ -> 1 + msize mty -- ignoring lindef, linref and printname

9
src/compiler/GF/Grammar/BNFC.hs
View File

@@ -15,7 +15,6 @@
module GF.Grammar.BNFC(BNFCRule(..), BNFCSymbol, Symbol(..), CFTerm(..), bnfc2cf) where
import GF.Grammar.CFG
import PGF (Token, mkCId)
import Data.List (partition)
type IsList = Bool
@@ -64,12 +63,12 @@ transformRules sepMap (BNFCCoercions c num) = rules ++ [lastRule]
lastRule = Rule (c',[0]) ss rn
where c' = c ++ show num
ss = [Terminal "(", NonTerminal (c,[0]), Terminal ")"]
rn = CFObj (mkCId $ "coercion_" ++ c) []
rn = CFObj ("coercion_" ++ c) []
fRules c n = Rule (c',[0]) ss rn
where c' = if n == 0 then c else c ++ show n
ss = [NonTerminal (c ++ show (n+1),[0])]
rn = CFObj (mkCId $ "coercion_" ++ c') []
rn = CFObj ("coercion_" ++ c') []
transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
transformSymb sepMap s = case s of
@@ -94,7 +93,7 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
then [NonTerminal (c,[0]) | ne]
else [NonTerminal (c,[0]) | ne] ++
[Terminal symb | symb /= "" && ne]
rn = CFObj (mkCId $ "Base" ++ c) []
rn = CFObj ("Base" ++ c) []
ruleCons
| isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
,Rule ("List" ++ c,[1]) smbs1 rn]
@@ -107,4 +106,4 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
smbs = [NonTerminal (c,[0])] ++
[Terminal symb | symb /= ""] ++
[NonTerminal ("List" ++ c,[0])]
rn = CFObj (mkCId $ "Cons" ++ c) []
rn = CFObj ("Cons" ++ c) []

60
src/compiler/GF/Grammar/Binary.hs
View File

@@ -10,9 +10,9 @@
module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
import Prelude hiding (catch)
import Control.Monad
import Control.Exception(catch,ErrorCall(..),throwIO)
import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
import Data.Binary
import qualified Data.Map as Map(empty)
import qualified Data.ByteString.Char8 as BS
@@ -22,11 +22,10 @@ import GF.Infra.Option
import GF.Infra.UseIO(MonadIO(..))
import GF.Grammar.Grammar
import PGF() -- Binary instances
import PGF.Internal(Literal(..))
import PGF2.Internal(Literal(..),Symbol(..))
-- Please change this every time when the GFO format is changed
gfoVersion = "GF04"
gfoVersion = "GF05"
instance Binary Ident where
put id = put (ident2utf8 id)
@@ -120,7 +119,7 @@ instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
put (ResParam x y) = putWord8 2 >> put (x,y)
put (ResValue x) = putWord8 3 >> put x
put (ResValue x y) = putWord8 3 >> put (x,y)
put (ResOper x y) = putWord8 4 >> put (x,y)
put (ResOverload x y)= putWord8 5 >> put (x,y)
put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
@@ -131,7 +130,7 @@ instance Binary Info where
0 -> get >>= \x -> return (AbsCat x)
1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
2 -> get >>= \(x,y) -> return (ResParam x y)
3 -> get >>= \x -> return (ResValue x)
3 -> get >>= \(x,y) -> return (ResValue x y)
4 -> get >>= \(x,y) -> return (ResOper x y)
5 -> get >>= \(x,y) -> return (ResOverload x y)
6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
@@ -298,6 +297,53 @@ instance Binary Label where
1 -> fmap LVar get
_ -> decodingError
instance Binary BindType where
put Explicit = putWord8 0
put Implicit = putWord8 1
get = do tag <- getWord8
case tag of
0 -> return Explicit
1 -> return Implicit
_ -> decodingError
instance Binary Literal where
put (LStr s) = putWord8 0 >> put s
put (LInt i) = putWord8 1 >> put i
put (LFlt d) = putWord8 2 >> put d
get = do tag <- getWord8
case tag of
0 -> liftM LStr get
1 -> liftM LInt get
2 -> liftM LFlt get
_ -> decodingError
instance Binary Symbol where
put (SymCat n l) = putWord8 0 >> put (n,l)
put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymVar n l) = putWord8 2 >> put (n,l)
put (SymKS ts) = putWord8 3 >> put ts
put (SymKP d vs) = putWord8 4 >> put (d,vs)
put SymBIND = putWord8 5
put SymSOFT_BIND = putWord8 6
put SymNE = putWord8 7
put SymSOFT_SPACE = putWord8 8
put SymCAPIT = putWord8 9
put SymALL_CAPIT = putWord8 10
get = do tag <- getWord8
case tag of
0 -> liftM2 SymCat get get
1 -> liftM2 SymLit get get
2 -> liftM2 SymVar get get
3 -> liftM SymKS get
4 -> liftM2 (\d vs -> SymKP d vs) get get
5 -> return SymBIND
6 -> return SymSOFT_BIND
7 -> return SymNE
8 -> return SymSOFT_SPACE
9 -> return SymCAPIT
10-> return SymALL_CAPIT
_ -> decodingError
--putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
--getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
--putGFOVersion = put gfoVersion

23
src/compiler/GF/Grammar/CFG.hs
View File

@@ -4,10 +4,11 @@
--
-- Context-free grammar representation and manipulation.
----------------------------------------------------------------------
module GF.Grammar.CFG where
module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
import GF.Data.Utilities
import PGF
import PGF2(Fun,Cat)
import PGF2.Internal(Token)
import GF.Data.Relation
import Data.Map (Map)
@@ -20,8 +21,6 @@ import qualified Data.Set as Set
-- * Types
--
type Cat = String
data Symbol c t = NonTerminal c | Terminal t
deriving (Eq, Ord, Show)
@@ -39,12 +38,12 @@ data Grammar c t = Grammar {
deriving (Eq, Ord, Show)
data CFTerm
= CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments
= CFObj Fun [CFTerm] -- ^ an abstract syntax function with arguments
| CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id.
| CFApp CFTerm CFTerm -- ^ Application
| CFRes Int -- ^ The result of the n:th (0-based) non-terminal
| CFVar Int -- ^ A lambda-bound variable
| CFMeta CId -- ^ A metavariable
| CFMeta Fun -- ^ A metavariable
deriving (Eq, Ord, Show)
type CFSymbol = Symbol Cat Token
@@ -232,7 +231,7 @@ uniqueFuns = snd . mapAccumL uniqueFun Set.empty
uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args))
where
fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),
let fun'=mkCId (showCId fun++suffix),
let fun'=fun++suffix,
not (fun' `Set.member` funs)]
-- | Gets all rules in a CFG.
@@ -310,12 +309,12 @@ prProductions prods =
prCFTerm :: CFTerm -> String
prCFTerm = pr 0
where
pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
pr p (CFObj f args) = paren p (f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t)
pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
pr _ (CFRes i) = "$" ++ show i
pr _ (CFVar i) = "x" ++ show i
pr _ (CFMeta c) = "?" ++ showCId c
pr _ (CFMeta c) = "?" ++ c
paren 0 x = x
paren 1 x = "(" ++ x ++ ")"
@@ -323,12 +322,12 @@ prCFTerm = pr 0
-- * CFRule Utilities
--
ruleFun :: Rule c t -> CId
ruleFun :: Rule c t -> Fun
ruleFun (Rule _ _ t) = f t
where f (CFObj n _) = n
f (CFApp _ x) = f x
f (CFAbs _ x) = f x
f _ = mkCId ""
f _ = ""
-- | Check if any of the categories used on the right-hand side
-- are in the given list of categories.
@@ -336,7 +335,7 @@ anyUsedBy :: Eq c => [c] -> Rule c t -> Bool
anyUsedBy cs (Rule _ ss _) = any (`elem` cs) (filterCats ss)
mkCFTerm :: String -> CFTerm
mkCFTerm n = CFObj (mkCId n) []
mkCFTerm n = CFObj n []
ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs

26
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -11,7 +11,6 @@
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
import GF.Infra.Ident (RawIdent)
-- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -45,12 +44,12 @@ data LincatDef = LincatDef CatId LinType deriving Show
data LinDef = LinDef FunId [VarId] LinValue deriving Show
-- | Linearization type, RHS of @lincat@
data LinType = FloatType
| IntType
data LinType = FloatType
| IntType
| ParamType ParamType
| RecordType [RecordRowType]
| StrType
| TableType LinType LinType
| StrType
| TableType LinType LinType
| TupleType [LinType]
deriving (Eq,Ord,Show)
@@ -60,7 +59,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral
| ErrorValue String
| ParamConstant ParamValue
| ParamConstant ParamValue
| PredefValue PredefId
| RecordValue [RecordRowValue]
| TableValue LinType [TableRowValue]
@@ -74,9 +73,9 @@ data LinValue = ConcatValue LinValue LinValue
| CommentedValue String LinValue
deriving (Eq,Ord,Show)
data LinLiteral = FloatConstant Float
| IntConstant Int
| StrConstant String
data LinLiteral = FloatConstant Float
| IntConstant Int
| StrConstant String
deriving (Eq,Ord,Show)
data LinPattern = ParamPattern ParamPattern
@@ -107,7 +106,7 @@ newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
-- | Name of param type or param value
-- | Name of param type or param value
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
@@ -127,7 +126,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers
type Id = RawIdent
type Id = String
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
@@ -250,7 +249,7 @@ instance PPA LinLiteral where
FloatConstant f -> pp f
IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm
instance RhsSeparator LinValue where rhsSep _ = pp "="
instance Pretty LinPattern where
@@ -265,7 +264,8 @@ instance PPA LinPattern where
ParamPattern pv -> ppA pv
RecordPattern r -> block r
TuplePattern ps -> "<"<>punctuate "," ps<>">"
WildPattern -> pp "_"
WildPattern -> pp "_"
_ -> parens p
instance RhsSeparator LinPattern where rhsSep _ = pp "="

53
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -6,8 +6,6 @@ import Text.JSON
import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
import Control.Monad (guard)
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
encodeJSON :: FilePath -> Grammar -> IO ()
@@ -30,7 +28,7 @@ instance JSON Grammar where
-- ** Abstract Syntax
instance JSON Abstract where
showJSON (Abstract absid flags cats funs)
showJSON (Abstract absid flags cats funs)
= makeObj [("abs", showJSON absid),
("flags", showJSON flags),
("cats", showJSON cats),
@@ -82,7 +80,7 @@ instance JSON TypeBinding where
-- ** Concrete syntax
instance JSON Concrete where
showJSON (Concrete cncid absid flags params lincats lins)
showJSON (Concrete cncid absid flags params lincats lins)
= makeObj [("cnc", showJSON cncid),
("abs", showJSON absid),
("flags", showJSON flags),
@@ -128,10 +126,10 @@ instance JSON LinType where
-- records are encoded as records:
showJSON (RecordType rows) = showJSON rows
readJSON o = StrType <$ parseString "Str" o
<|> FloatType <$ parseString "Float" o
<|> IntType <$ parseString "Int" o
<|> ParamType <$> readJSON o
readJSON o = do "Str" <- readJSON o; return StrType
<|> do "Float" <- readJSON o; return FloatType
<|> do "Int" <- readJSON o; return IntType
<|> do ptype <- readJSON o; return (ParamType ptype)
<|> TableType <$> o!".tblarg" <*> o!".tblval"
<|> TupleType <$> o!".tuple"
<|> RecordType <$> readJSON o
@@ -188,7 +186,7 @@ instance JSON LinPattern where
-- and records as records:
showJSON (RecordPattern r) = showJSON r
readJSON o = do p <- parseString "_" o; return WildPattern
readJSON o = do "_" <- readJSON o; return WildPattern
<|> do p <- readJSON o; return (ParamPattern (Param p []))
<|> ParamPattern <$> readJSON o
<|> RecordPattern <$> readJSON o
@@ -205,12 +203,12 @@ instance JSON a => JSON (RecordRow a) where
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
showJSON row = showJSONs [row]
showJSONs rows = makeObj (map toRow rows)
where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
readJSON obj = head <$> readJSONs obj
readJSONs obj = mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (RecordRow (LabelId (rawIdentS lbl)) value)
return (RecordRow (LabelId lbl) value)
instance JSON rhs => JSON (TableRow rhs) where
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -220,47 +218,43 @@ instance JSON rhs => JSON (TableRow rhs) where
-- *** Identifiers in Concrete Syntax
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON VarId where
-- the anonymous variable is the underscore:
showJSON Anonymous = showJSON "_"
showJSON (VarId x) = showJSON x
readJSON o = do parseString "_" o; return Anonymous
readJSON o = do "_" <- readJSON o; return Anonymous
<|> VarId <$> readJSON o
instance JSON QualId where
showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
showJSON (Unqual n) = showJSON n
readJSON o = do qualid <- readJSON o
let (mod, id) = span (/= '.') qualid
return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
instance JSON RawIdent where
showJSON i = showJSON $ showRawIdent i
readJSON o = rawIdentS <$> readJSON o
return $ if null mod then Unqual id else Qual (ModId mod) id
instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects):
showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (rawIdentS lbl, value)
return (lbl, value)
instance JSON FlagValue where
-- flag values are encoded as basic JSON types:
@@ -274,9 +268,6 @@ instance JSON FlagValue where
--------------------------------------------------------------------------------
-- ** Convenience functions
parseString :: String -> JSValue -> Result ()
parseString s o = guard . (== s) =<< readJSON o
(!) :: JSON a => JSValue -> String -> Result a
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
readJSON

3
src/compiler/GF/Grammar/EBNF.hs
View File

@@ -16,7 +16,6 @@ module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where
import GF.Data.Operations
import GF.Grammar.CFG
import PGF (mkCId)
type EBNF = [ERule]
type ERule = (ECat, ERHS)
@@ -40,7 +39,7 @@ ebnf2cf :: EBNF -> [ParamCFRule]
ebnf2cf ebnf =
[Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
where
mkCFF i (c,_) = CFObj (mkCId ("Mk" ++ c ++ "_" ++ show i)) []
mkCFF i (c,_) = CFObj ("Mk" ++ c ++ "_" ++ show i) []
normEBNF :: EBNF -> [CFJustRule]
normEBNF erules = let

11
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
-- ** PMCFG
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
) where
import GF.Infra.Ident
@@ -73,7 +73,8 @@ import GF.Infra.Location
import GF.Data.Operations
import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
import PGF2(LIndex, BindType(..))
import PGF2.Internal(FId, FunId, SeqId, Symbol)
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -99,7 +100,7 @@ data ModuleInfo = ModInfo {
mopens :: [OpenSpec],
mexdeps :: [ModuleName],
msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence),
mseqs :: Maybe (Array SeqId [Symbol]),
jments :: Map.Map Ident Info
}
@@ -329,7 +330,7 @@ data Info =
-- judgements in resource
| ResParam (Maybe (L [Param])) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
| ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResValue (L Type) Int -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
@@ -458,7 +459,7 @@ type Case = (Patt, Term)
--type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term))
type Param = (Ident, Context)
type Param = (Ident, Context, Int)
type Altern = (Term, [(Term, Term)])
type Substitution = [(Ident, Term)]

16
src/compiler/GF/Grammar/Lexer.x
View File

@@ -1,6 +1,5 @@
-- -*- haskell -*-
{
{-# LANGUAGE CPP #-}
module GF.Grammar.Lexer
( Token(..), Posn(..)
, P, runP, runPartial, token, lexer, getPosn, failLoc
@@ -19,7 +18,6 @@ import qualified Data.Map as Map
import Data.Word(Word8)
import Data.Char(readLitChar)
--import Debug.Trace(trace)
import qualified Control.Monad.Fail as Fail
}
@@ -35,7 +33,7 @@ $u = [.\n] -- universal: any character
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok ident }
@@ -138,7 +136,7 @@ data Token
res = eitherResIdent
eitherResIdent :: (Ident -> Token) -> Ident -> Token
eitherResIdent tv s =
eitherResIdent tv s =
case Map.lookup s resWords of
Just t -> t
Nothing -> tv s
@@ -267,7 +265,7 @@ type AlexInput2 = (AlexInput,AlexInput)
data ParseResult a
= POk AlexInput2 a
| PFailed Posn -- The position of the error
| PFailed Posn -- The position of the error
String -- The error message
newtype P a = P { unP :: AlexInput2 -> ParseResult a }
@@ -284,16 +282,8 @@ instance Monad P where
(P m) >>= k = P $ \ s -> case m s of
POk s a -> unP (k a) s
PFailed posn err -> PFailed posn err
#if !(MIN_VERSION_base(4,13,0))
-- Monad(fail) will be removed in GHC 8.8+
fail = Fail.fail
#endif
instance Fail.MonadFail P where
fail msg = P $ \(_,AI posn _ _) -> PFailed posn msg
runP :: P a -> BS.ByteString -> Either (Posn,String) a
runP p bs = snd <$> runP' p (Pn 1 0,bs)

42
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -6,7 +6,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/27 13:21:53 $
-- > CVS $Date: 2005/10/27 13:21:53 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.15 $
--
@@ -20,17 +20,18 @@ module GF.Grammar.Lookup (
lookupOrigInfo,
allOrigInfos,
lookupResDef, lookupResDefLoc,
lookupResType,
lookupResType,
lookupOverload,
lookupOverloadTypes,
lookupParamValues,
allParamValues,
lookupParamValueIndex,
lookupAbsDef,
lookupLincat,
lookupFunType,
lookupCatContext,
allOpers, allOpersTo
) where
) where
import GF.Data.Operations
import GF.Infra.Ident
@@ -69,7 +70,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
| isPredefCat c = fmap noLoc (lock c defLinType)
| otherwise = look m c
where
where
look m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -77,13 +78,13 @@ lookupResDefLoc gr (m,c)
ResOper _ Nothing -> return (noLoc (Q (m,c)))
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ -> return (noLoc (QC (m,c)))
ResValue _ _ -> return (noLoc (QC (m,c)))
_ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
@@ -95,11 +96,11 @@ lookupResType gr (m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> return typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
val' <- lock cat val
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
ResValue (L _ t) -> return t
ResValue (L _ t) _-> return t
_ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -111,10 +112,10 @@ lookupOverloadTypes gr id@(m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> ret typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
val' <- lock cat val
ret $ mkProd cont val' []
ResParam _ _ -> ret typePType
ResValue (L _ t) -> ret t
ResParam _ _ -> ret typePType
ResValue (L _ t) _ -> ret t
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -130,8 +131,8 @@ lookupOverload gr (m,c) = do
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr (x,c)) os
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
(L _ ty,L _ tr) <- tysts] ++
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
(L _ ty,L _ tr) <- tysts] ++
concat tss
AnyInd _ n -> lookupOverload gr (n,c)
@@ -166,16 +167,23 @@ allParamValues cnc ptyp =
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
tss <- mapM (allParamValues cnc) tys
return [R (zipAssign ls ts) | ts <- sequence tss]
return [R (zipAssign ls ts) | ts <- combinations tss]
Table pt vt -> do
pvs <- allParamValues cnc pt
vvs <- allParamValues cnc vt
return [V pt ts | ts <- sequence (replicate (length pvs) vvs)]
return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
_ -> raise (render ("cannot find parameter values for" <+> ptyp))
where
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupParamValueIndex :: ErrorMonad m => Grammar -> QIdent -> m Int
lookupParamValueIndex gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResValue _ i -> return i
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter index defined")
lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
info <- lookupQIdentInfo gr (m,c)
@@ -216,7 +224,7 @@ lookupCatContext gr m c = do
-- notice that it only gives the modules that are reachable and the opers that are included
allOpers :: Grammar -> [(QIdent,Type,Location)]
allOpers gr =
allOpers gr =
[((m,op),typ,loc) |
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
(op,info) <- Map.toList (jments mi),
@@ -226,7 +234,7 @@ allOpers gr =
typesIn info = case info of
AbsFun (Just ltyp) _ _ _ -> [ltyp]
ResOper (Just ltyp) _ -> [ltyp]
ResValue ltyp -> [ltyp]
ResValue ltyp _ -> [ltyp]
ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs]
CncFun (Just (i,ctx,typ)) _ _ _ ->
[L NoLoc (mkProdSimple ctx (lock' i typ))]

53
src/compiler/GF/Grammar/Macros.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 16:38:00 $
-- > CVS $Date: 2005/11/11 16:38:00 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.24 $
--
@@ -32,7 +32,6 @@ import Control.Monad (liftM, liftM2, liftM3)
import Data.List (sortBy,nub)
import Data.Monoid
import GF.Text.Pretty(render,(<+>),hsep,fsep)
import qualified Control.Monad.Fail as Fail
-- ** Functions for constructing and analysing source code terms.
@@ -48,17 +47,17 @@ typeForm t =
Q c -> ([],c,[])
QC c -> ([],c,[])
Sort c -> ([],(MN identW, c),[])
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
_ -> error (render ("no normal form of type" <+> show t))
typeFormCnc :: Type -> (Context, Type)
typeFormCnc t =
typeFormCnc t =
case t of
Prod b x a t -> let (x', v) = typeFormCnc t
in ((b,x,a):x',v)
_ -> ([],t)
valCat :: Type -> Cat
valCat typ =
valCat typ =
let (_,cat,_) = typeForm typ
in cat
@@ -99,7 +98,7 @@ isHigherOrderType t = fromErr True $ do -- pessimistic choice
contextOfType :: Monad m => Type -> m Context
contextOfType typ = case typ of
Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
_ -> return []
_ -> return []
termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
termForm t = case t of
@@ -108,8 +107,8 @@ termForm t = case t of
return ((b,x):x', fun, args)
App c a ->
do (_,fun, args) <- termForm c
return ([],fun,args ++ [a])
_ ->
return ([],fun,args ++ [a])
_ ->
return ([],t,[])
termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -238,7 +237,7 @@ isPredefConstant t = case t of
Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
_ -> False
checkPredefError :: Fail.MonadFail m => Term -> m Term
checkPredefError :: Monad m => Term -> m Term
checkPredefError t =
case t of
Error s -> fail ("Error: "++s)
@@ -254,7 +253,7 @@ mkTable :: [Term] -> Term -> Term
mkTable tt t = foldr Table t tt
mkCTable :: [(BindType,Ident)] -> Term -> Term
mkCTable ids v = foldr ccase v ids where
mkCTable ids v = foldr ccase v ids where
ccase (_,x) t = T TRaw [(PV x,t)]
mkHypo :: Term -> Hypo
@@ -287,7 +286,7 @@ plusRecType t1 t2 = case (t1, t2) of
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> raise $ render ("clashing labels" <+> hsep ls)
_ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
_ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
--plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
@@ -304,7 +303,7 @@ defLinType = RecType [(theLinLabel, typeStr)]
-- | refreshing variables
mkFreshVar :: [Ident] -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1)
mkFreshVar olds = varX (maxVarIndex olds + 1)
-- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident
@@ -313,7 +312,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
maxVarIndex :: [Ident] -> Int
maxVarIndex = maximum . ((-1):) . map varIndex
mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
-- | quick hack for refining with var in editor
@@ -413,11 +412,11 @@ patt2term pt = case pt of
PC c pp -> mkApp (Con c) (map patt2term pp)
PP c pp -> mkApp (QC c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
PString s -> K s
PString s -> K s
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
PChar -> appCons cChar [] --- an encoding
@@ -436,7 +435,7 @@ composSafeOp op = runIdentity . composOp (return . op)
-- | to define compositional term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm =
composOp co trm =
case trm of
App c a -> liftM2 App (co c) (co a)
Abs b x t -> liftM (Abs b x) (co t)
@@ -552,15 +551,19 @@ strsFromTerm t = case t of
v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs
--let vs' = zip v0 c0
return [strTok (str2strings def) vars |
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- sequence v0]
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- combinations v0]
]
FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat
_ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String
stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
getTableType :: TInfo -> Err Type
getTableType i = case i of
TTyped ty -> return ty
@@ -590,11 +593,11 @@ noExist = FV []
defaultLinType :: Type
defaultLinType = mkRecType linLabel [typeStr]
-- | normalize records and record types; put s first
-- normalize records and record types; put s first
sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where
ordLabel (r1,_) (r2,_) =
ordLabel (r1,_) (r2,_) =
case (showIdent (label2ident r1), showIdent (label2ident r2)) of
("s",_) -> LT
(_,"s") -> GT
@@ -605,19 +608,21 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list
allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
allDependencies ism b =
allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
where
opersIn t = case t of
Q (n,c) | ism n -> [c]
QC (n,c) | ism n -> [c]
Cn c -> [c]
_ -> collectOp opersIn t
opty (Just (L _ ty)) = opersIn ty
opty _ = []
pts i = case i of
ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont,_) <- ps, (_,_,t) <- cont]
ResValue pty _ -> [Just pty]
CncCat pty _ _ _ _ -> [pty]
CncFun _ pt _ _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual

11
src/compiler/GF/Grammar/Parser.y
View File

@@ -25,7 +25,6 @@ import GF.Compile.Update (buildAnyTree)
import Data.List(intersperse)
import Data.Char(isAlphaNum)
import qualified Data.Map as Map
import PGF(mkCId)
}
@@ -268,7 +267,7 @@ DataDef
ParamDef :: { [(Ident,Info)] }
ParamDef
: Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
[(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
[(f, ResValue (L loc (mkProdSimple co (Cn $2))) i) | L loc (f,co,i) <- $4] }
| Posn LhsIdent Posn { [($2, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,Info)] }
@@ -303,7 +302,7 @@ ListDataConstr
ParConstr :: { L Param }
ParConstr
: Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) }
: Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3,0) }
ListLinDef :: { [(Ident,Info)] }
ListLinDef
@@ -625,7 +624,7 @@ ListCFRule
CFRule :: { [BNFCRule] }
CFRule
: Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
: Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
}
| Ident '::=' ListCFRHS ';' { let { cat = showIdent $1;
mkFun cat its =
@@ -638,7 +637,7 @@ CFRule
Terminal c -> filter isAlphaNum c;
NonTerminal (t,_) -> t
}
} in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
} in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
}
| 'coercions' Ident Integer ';' { [BNFCCoercions (showIdent $2) $3]}
| 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }
@@ -775,7 +774,7 @@ checkInfoType mt jment@(id,info) =
CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue ty -> ifResource mt (locL ty)
ResValue ty _ -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
where

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