diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 000000000..4e261df60 --- /dev/null +++ b/.dockerignore @@ -0,0 +1,11 @@ +# Ignore everything +* + +# Whitelist the following +!LICENSE +!README.md +!StdLib +!frontend +!interpreter +!repl +!stack.yaml \ No newline at end of file diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 000000000..904b27218 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,2 @@ +# Use Agda syntax hightlighting for Granule +*.gr linguist-language=Agda \ No newline at end of file diff --git a/.gitignore b/.gitignore index ec72b1ce5..38a5d71d8 100644 --- a/.gitignore +++ b/.gitignore @@ -60,3 +60,6 @@ Temporary Items # Compiler Examples compiler-examples/ + +# VSCode +.vscode diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 000000000..878e40c24 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,29 @@ +# Stack build environment +FROM fpco/stack-build:lts-13.21 AS build +WORKDIR /granule +COPY . /granule/ +RUN stack install --local-bin-path /usr/bin && stack clean --full +RUN wget https://github.com/Z3Prover/z3/releases/download/z3-4.8.4/z3-4.8.4.d6df51951f4c-x64-ubuntu-16.04.zip \ + && unzip z3-4.8.4.d6df51951f4c-x64-ubuntu-16.04.zip \ + && mv z3-4.8.4.d6df51951f4c-x64-ubuntu-16.04/bin/z3 /usr/bin/z3 \ + && rm -rf z3-4.8.4.d6df51951f4c-x64-ubuntu-16.04* + +# Get a stripped down ubuntu 16.04 for a lean distribution image +FROM ubuntu:xenial-20190515 +WORKDIR /granule +COPY --from=build /usr/bin/gr /usr/bin/grin /usr/bin/z3 /usr/bin/ +COPY --from=build /granule /granule +RUN apt-get update +# for GHC +RUN apt-get install -y libgmp10 +# for Z3 +RUN apt-get install -y libgomp1 +# UTF8 support +RUN apt-get install -y locales \ + && sed -i -e 's/# en_US.UTF-8 UTF-8/en_US.UTF-8 UTF-8/' /etc/locale.gen \ + && dpkg-reconfigure --frontend=noninteractive locales \ + && update-locale LANG=en_US.UTF-8 +ENV LANG en_US.UTF-8 +# add .granule config file +RUN echo "--include-path /granule/StdLib --alternative-colors" > ~/.granule +CMD ["bash"] \ No newline at end of file diff --git a/README.md b/README.md index 5605760a4..35637e5ad 100644 --- a/README.md +++ b/README.md @@ -1,18 +1,24 @@ ``` - ___ - /\_ \ - __ _ _ __ ___ __ __\//\ \ __ + ___ + /\_ \ + __ _ _ __ ___ __ __\//\ \ __ / _ \/\`'__\/ __ \ /' _ `\/\ \/\ \ \ \ \ /'__`\ /\ \_\ \ \ \//\ \_\ \_/\ \/\ \ \ \_\ \ \_\ \_/\ __/ \ \____ \ \_\\ \__/ \_\ \_\ \_\ \____/ /\____\ \____\ - \/___L\ \/_/ \/__/\/_/\/_/\/_/\/___/ \/____/\/____/ - /\____/ + \/___/\ \/_/ \/__/\/_/\/_/\/_/\/___/ \/____/\/____/ + /\____/ \_/__/ ``` -A functional programming language with a linear type system and fine-grained effects and coeffects via **graded modal types**. +Granule is a functional programming language with a linear type system and +fine-grained effects and coeffects via **graded modal types**. -A brief introduction to the Granule programming language can be found in [this extended abstract](http://www.cs.ox.ac.uk/conferences/fscd2017/preproceedings_unprotected/TLLA_Orchard.pdf) presented at TLLA'17. The type system is partly based on the one in ["Combining effects and coeffects via grading" (Gaboardi et al. 2016)](https://www.cs.kent.ac.uk/people/staff/dao7/publ/combining-effects-and-coeffects-icfp16.pdf). +An introduction to Granule can be found in our paper [Quantitative +program reasoning with graded modal types][1]. More details of the project +can be found on the [project website][2]. + +[1]: https://www.cs.kent.ac.uk/people/staff/dao7/publ/granule-icfp19.pdf +[2]: https://granule-project.github.io/ ## Example @@ -42,19 +48,29 @@ map [_] Nil = Nil; map [f] (Cons x xs) = Cons (f x) (map [f] xs) ``` -This type explains that the parameter function `f` is used exactly `n` times, where `n` is the size -of the incoming list. Linearity ensures that the entire list is consumed exactly -once to the produce the result. +This type explains that the parameter function `f` is used exactly `n` times, +where `n` is the size of the incoming list. Linearity ensures that the entire +list is consumed exactly once to the produce the result. ## Installation -Make sure you have [Z3](https://github.com/Z3Prover/z3) and [Stack](https://docs.haskellstack.org/en/stable/README/) on your system. +Binary releases are currently available for MacOS only. If you need a newer +[release](https://github.com/granule-project/granule/releases) than is available +then please open an issue. + +To build Granule from source, make sure you have +[Z3](https://github.com/Z3Prover/z3) and +[Stack](https://docs.haskellstack.org/en/stable/README/) on your system. Now run - $ git clone https://github.com/granule-project/granule && cd granule && stack setup && stack install --test + git clone https://github.com/granule-project/granule \ + && cd granule \ + && stack setup \ + && stack install --test -More details about how to install can be found on the [wiki page](https://github.com/granule-project/granule/wiki/Installing-Granule). +More details about how to install can be found on the [wiki +page](https://github.com/granule-project/granule/wiki/Installing-Granule). ## Running the Interpreter @@ -62,70 +78,171 @@ Granule program files have file extension `.gr`. Use the `gr` command to run the $ gr examples/NonEmpty.gr Checking examples/NonEmpty.gr... - Ok, evaluating... - `main` returned: + OK, evaluating... 1 -See the `examples` directory for more sample programs, or `frontend/tests/cases` -if you dare. +A good starting point for learning about Granule is the tutorial given in +[examples/intro.gr.md](https://github.com/granule-project/granule/blob/master/examples/intro.gr.md). + +### Setting the Path + +Granule has a very basic import system. When `gr` encounters a line `import +A.B.C` anywhere in the file it will attempt to load the file located at +`$GRANULE_PATH/A/B/C.gr`, where `$GRANULE_PATH` defaults to `StdLib`, i.e. it +should work when you are running `gr` from within this project. For a more +stable setup which lets you run `gr` from any directory you can set the path +with the `--include-path` flag (see below). + +### Configuration + +Run `gr` with the `--help` flag for an overview of flags. Flags can be set + + 1. in `~/.granule` (the same way as on the command line) + 2. on the command line + 3. at the top of the file (prepended with `-- gr `) + +and have precedence in that order, e.g. flags set on the command line will +override flags in the config. + +Example `.granule` file: + +~~~sh +$ cat ~/.granule +--include-path /Users/alice/granule/StdLib +--solver-timeout 2000 +~~~ + +### Command line completion + +See [here](https://github.com/pcapriotti/optparse-applicative#bash-zsh-and-fish-completions) +for how to install completion scripts for your shell, although we recommend +dynamically loading the completions in your shell's startup script to account +for changes in `gr`'s interface; e.g. for `fish` on MacOS: + +~~~ fish +echo "#granule +gr --fish-completion-script (which gr) | source" >> ~/.config/fish/config.fish +~~~ + +### Accessibility + +We aim to make Granule as inclusive as possible. If you experience any +accessibility hurdles, please open an issue. + +#### Alternative Colours -### Literate Granule Files +The `--alternative-colors`/`--alternative-colours` flag will cause success +messages to be printed in blue instead of green, which may help with colour +blindness. + +The `--no-color`/`--no-colour` flag will turn off colours altogether. + +### Multi-Byte Unicode + +The following symbols are interchangeable. You can destructively rewrite all +occurrences in your source file by passing +`--ascii-to-unicode`/`--unicode-to-ascii`. `--keep-backup` will save a backup of +the most recent copy of the input file with `.bak` appended. + +| ASCII | Unicode | +|:---:|:---:| +| `forall` | `∀` | +| `Inf` | `∞` | +| `->` | `→` | +| `=>` | `⇒` | +| `<-` | `←` | +| `/\` | `∧` | +| `\/` | `∨` | +| `<=` | `≤` | +| `>=` | `≥` | +| `==` | `≡` | +| `\` | `λ` | + +Usages of the operator `∘` get parsed as an application of `compose`. + +### Literate Granule + +Granule has some basic support for literate programs with Markdown and TeX. +By default code in `granule` code environments will be run. This can be +overridden with the flag `--literate-env-name`. + +#### Markdown The interpreter also takes markdown files with the extension `.md`, in which case all fenced code blocks labelled with `granule` will get parsed as the input source code. All other lines are ignored, but counted as whitespace to retain line numbers for error messages. - # Example literate granule (markdown) file +~~~~ markdown +# Example literate granule (markdown) file - Code blocks can be fenced with twiddles... +Code blocks can be fenced with twiddles... - ~~~ granule - a : Int - a = 1 - ~~~ +~~~ granule +a : Int +a = 1 +~~~ - ... or backticks. +... or backticks. - ```granule - b : Int - b = 2 - ``` +```granule +b : Int +b = 2 +``` - The following code blocks will get ignored. +The following code blocks will get ignored. - ~~~ - c : Int - c = 3 - ~~~ +~~~ +int c = 3; +~~~ - ```not granule - d : Int - d = 4 - ``` +```haskell +d :: Int +d = 4 +``` +~~~~ +#### TeX +You can run Granule on the TeX file below with `gr --literate-env-name verbatim`. +You can use XeLaTeX to properly display multi-byte Unicode characters. -### Options +~~~ tex +\documentclass{article} -`gr` takes several options, run `gr --help` for more information. +\title{Literate Granule (\TeX{}) Example} +\begin{document} +\author{Grampy Granule} +\maketitle -You can set default options in `$HOME/.granule`, e.g.: +Writing things here. -``` -$ cat ~/.granule -Options - { debugging = Nothing - , noColors = Just True - , noEval = Nothing - , suppressInfos = Nothing - , suppressErrors = Nothing - , timestamp = Nothing - , solverTimeoutMillis = Just 2000 - , includePath = Just "Users/alice/granule/StdLib" - , ascii2unicode = Just True - , keepBackupAscii = Just False - } -``` +\begin{verbatim} +import Prelude + +foo : String +foo = "running code here" +\end{verbatim} +\end{document} +~~~ + + +## Caveats + +Granule is a research project to help us gain intuitions about using linearity +and graded modalities in programming. It is licensed under a permissive licence, +so you can use it for whatever, but please don't write your next spaceship +controller in Granule just yet. The interface is not stable (and nor is the +code). You have been warned... -All contributions are welcome! +~~~ + ( All contributions are welcome! ) + __// / + /.__.\ + \ \/ / + '__/ \ + \- ) + \_____/ +_____|_|______________________________________ + " " +~~~ \ No newline at end of file diff --git a/StdLib/Bool.gr b/StdLib/Bool.gr index bc63968bd..c663c7070 100644 --- a/StdLib/Bool.gr +++ b/StdLib/Bool.gr @@ -15,58 +15,58 @@ data Bool = False | True dropB : Bool -> () dropB False = (); -| True = () +dropB True = () --- # Boolean algebra --- Logical negation not : Bool -> Bool not False = True; -| True = False +not True = False --- Logical and --- NB: non-strict in second argument and : Bool -> Bool [0..1] -> Bool -and True [y] = y; -| False [_] = False +and True [y] = y; +and False [_] = False --- Logical and (linear) --- NB: consumes both arguments and' : Bool -> Bool -> Bool and' False False = False; -| False True = False; -| True False = False; -| True True = True +and' False True = False; +and' True False = False; +and' True True = True --- Inclusive or --- NB: non-strict in second argument or : Bool -> Bool [0..1] -> Bool -or True [_] = True; -| False [y] = y +or False [y] = y; +or True [_] = True --- Inclusive or (linear) or' : Bool -> Bool -> Bool or' False False = False; -| False True = True; -| True False = True; -| True True = True +or' False True = True; +or' True False = True; +or' True True = True --- Exclusive or xor : Bool -> Bool -> Bool xor True y = not y; -| False y = y +xor False y = y --- Logical implication --- NB: non-strict in second argument impl : Bool -> Bool [0..1] -> Bool impl True [y] = y; -| False [_] = True +impl False [_] = True --- Logical implication (linear) --- NB: strict in both arguments impl' : Bool -> Bool -> Bool impl' False False = True; -| False True = True; -| True False = False; -| True True = True +impl' False True = True; +impl' True False = False; +impl' True True = True diff --git a/StdLib/Choice.gr b/StdLib/Choice.gr deleted file mode 100644 index 2486ebc5e..000000000 --- a/StdLib/Choice.gr +++ /dev/null @@ -1,45 +0,0 @@ ------- ---- Module: Choice ---- Description: A datatype with two elements. The only way to consume it is by either ---- choosing the first or the second element. You must choose exactly one. ---- Note: still need to encapsulate the `OneOf` constructor—pattern matching on it is BAD! ---- Authors: Vilem-Benjamin Liepelt ---- License: BSD3 ---- Copyright: (c) Authors 2018 ---- Issue-tracking: https://github.com/dorchard/granule/issues ---- Repository: https://github.com/dorchard/granule ------- - -data Choice a b = OneOf (a [0..1]) (b [0..1]) -- TODO: don't export - -choice : forall {a : Type, b : Type} . a [0..1] -> b [0..1] -> Choice a b -choice x y = OneOf x y - --- To construct a `Choice a b`, we need an `a [0..1]` and a `b [0..1]` because --- the consumer can pick either the `a` or the `b`, not both. (That is currently --- a lie, we need to be able to make the Choice constructor abstract, i.e. not --- export it, for this to hold.) --- --- NB: Polymorphism allows further nonlinearity to be encapsulated inside of the --- `a` and `b`. In other words, `[0..1]` is just the minimum amount of linearity --- required. Example: --- --- ```granule --- choiceExample : forall a : Type, b : Type --- . a [0..2] -> b [0..1] -> Choice (a [1..2]) b --- choiceExample aBox bBox = choice (unflatten aBox) bBox --- ``` - -choose1 : forall a : Type, b : Type . Choice a b -> a -choose1 (OneOf [x] [_]) = x - -choose2 : forall a : Type, b : Type . Choice a b -> b -choose2 (OneOf [_] [y]) = y - --- TODO: Use the following when existentials are fixed --- data Choice : Type -> Type -> Nat -> Type where --- Choices : forall a : Type, b : Type, m : Nat, n : Nat --- . a [m] -> b [n] -> Choice a b (m + n) --- --- getA : forall a : Type, b : Type . Choice a b 1 -> a --- getA (Choices [a] [b]) = a diff --git a/StdLib/File.gr b/StdLib/File.gr index 549d5e729..b974d0bf3 100644 --- a/StdLib/File.gr +++ b/StdLib/File.gr @@ -1,18 +1,27 @@ -import Bool +import Maybe -readFile : String -> String +readMany : Int → Handle R → (Handle R, String) +readMany 0 h = pure (h, ""); +readMany n h = + let (h, c) ← readChar h; + (h, cs) ← readMany (n - 1) h + in pure (h, stringCons c cs) + +readFile : String -> String readFile filename = - let h <- openFile filename ReadMode; - (h, cs) <- getCharsUntilEnd h; - () <- hClose h + let h <- openHandle ReadMode filename; + (h, cs) <- readUntilEnd h; + _ <- closeHandle h in pure cs -getCharsUntilEnd : Handle -> (Handle, String) -getCharsUntilEnd h = - let (h, b) <- isEOF h - in case b of - True -> pure (h, ""); - False -> - let (h, c) <- hGetChar h; - (h, cs) <- getCharsUntilEnd h - in pure (h, stringAppend (showChar c) cs) +readUntilEnd : Handle R -> (Handle R, String) +readUntilEnd h = + let (h, eof) <- isEOF h in + case eof of + True -> pure (h, ""); + False -> + let (h, c) <- readChar h; + (h, str) <- readUntilEnd h + in pure (h, stringCons c str) + + diff --git a/StdLib/Fix.gr b/StdLib/Fix.gr index d1415b4f7..89b41b174 100644 --- a/StdLib/Fix.gr +++ b/StdLib/Fix.gr @@ -8,7 +8,7 @@ --- Repository: https://github.com/granule-project/granule ------ -data Fix (f : Type -> Type) where Fix (f (Fix f)) +data Fix (f : Type -> Type) = Fix (f (Fix f)) unfix : forall a : Type, f : Type -> Type . Fix f -> f (Fix f) unfix (Fix x) = x diff --git a/StdLib/Graph.gr b/StdLib/Graph.gr index f6c72a34d..ab8fe1fff 100644 --- a/StdLib/Graph.gr +++ b/StdLib/Graph.gr @@ -18,44 +18,39 @@ data Graph a where Connect : Graph a -> Graph a -> Graph a vertices : forall a : Type . List a -> Graph a -vertices = foldr_list [Overlay `o` Vertex] EmptyG +vertices = foldr_list [Overlay ∘ Vertex] EmptyG edge : forall a : Type . a -> a -> Graph a edge x y = Connect (Vertex x) (Vertex y) -mapG : forall a : Type, b : Type . (a -> b) [∞] -> Graph a -> Graph b +mapG : forall a : Type, b : Type . (a -> b) [0..∞] -> Graph a -> Graph b mapG [f] g = case g of EmptyG -> EmptyG; Vertex a -> Vertex (f a); Overlay g1 g2 -> Overlay (mapG [f] g1) (mapG [f] g2); Connect g1 g2 -> Connect (mapG [f] g1) (mapG [f] g2) --- foldG : forall a : Type, b : Type --- . b [∞] --- -> (a -> b) [∞] --- -> (b -> b -> b) [∞] --- -> (b -> b -> b) [∞] --- -> Graph a --- -> b --- foldG [e] [v] [o] [c] g = --- let [rec] = [foldG [e] [v] [o] [c]] in --- case g of --- EmptyG -> e; --- Vertex a -> v a; --- Overlay g1 g2 -> o (rec g1) (rec g2); --- Connect g1 g2 -> c (rec g1) (rec g2) +foldG' : forall a : Type, b : Type + . b [0..∞] + -> (a -> b) [0..∞] + -> (b -> b -> b) [0..∞] + -> (b -> b -> b) [0..∞] + -> Graph a + -> b +foldG' [e] [v] [o] [c] g = + let [rec] = [foldG' [e] [v] [o] [c]] in + case g of + EmptyG -> e; + Vertex a -> v a; + Overlay g1 g2 -> o (rec g1) (rec g2); + Connect g1 g2 -> c (rec g1) (rec g2) --- Error during type checking: StdLib/Graph.gr: --- Trying to join two type variables: b and b --- CallStack (from HasCallStack): --- error, called at src/Language/Granule/Checker/Types.hs:478:3 in granule-frontend-0.6.1.0-39lWg9n8iVuFNWgIo --- DxNvA:Language.Granule.Checker.Types foldG : forall a : Type, b : Type - . b [∞] - -> (a -> b) [∞] - -> (b -> b -> b) [∞] - -> (b -> b -> b) [∞] + . b [0..∞] + -> (a -> b) [0..∞] + -> (b -> b -> b) [0..∞] + -> (b -> b -> b) [0..∞] -> Graph a -> b foldG [e] [v] [o] [c] g = diff --git a/StdLib/List.gr b/StdLib/List.gr index b47d6b599..937a20f81 100644 --- a/StdLib/List.gr +++ b/StdLib/List.gr @@ -9,21 +9,32 @@ ------ import Result +import Maybe +import Bool data List a where Empty; Next a (List a) -lmap : forall a : Type, b : Type - . (a -> b) [0..∞] -> List a -> List b -lmap [f] Empty = Empty; -lmap [f] (Next x xs) = Next (f x) (lmap [f] xs) - - +-- Length function must ignore the elements length_list : forall a : Type . List (a [0]) -> Int length_list xs = case xs of Empty -> 0; (Next [_] xs) -> 1 + length_list xs +-- Map function for lists +lmap : forall a : Type, b : Type + . (a -> b) [0..∞] -> List a -> List b +lmap [f] Empty = Empty; +lmap [f] (Next x xs) = Next (f x) (lmap [f] xs) + +-- Lookup function +lookupBy : forall {a : Type, b : Type} + . (a -> a -> Bool) [0..∞] -> a [0..∞] -> (List (a, b)) [0..1] -> Maybe b +lookupBy [p] [k] [Empty] = None; +lookupBy [p] [k] [Next (k', v) xs] = + if p k k' then Some v else lookupBy [p] [k] [xs] + +-- Safe head function head_list : forall a : Type . (List a) [0..1] -> Result a head_list xs = case xs of @@ -31,19 +42,19 @@ head_list xs = [(Next x _)] -> Ok x foldr_list : forall {a : Type, b : Type} - . (a -> b -> b) [∞] -> b -> List a -> b + . (a -> b -> b) [0..∞] -> b -> List a -> b foldr_list [f] z xs = case xs of Empty -> z; Next x xs -> f x (foldr_list [f] z xs) -pushList : forall {k : Nat, a : Type} - . (List a) [1..k+1] -> List (a [1..k+1]) +pushList : forall {k : Coeffect, c : k, a : Type} + . (List a) [c+1] -> List (a [c+1]) pushList [Empty] = Empty; pushList [Next x xs] = Next [x] (pushList [xs]) -pullList : forall {k : Nat, a : Type} - . List (a [k]) -> (List a) [k] +pullList : forall {k : Coeffect, c : k, a : Type} + . List (a [c]) -> (List a) [c] pullList xs = case xs of Empty -> [Empty]; diff --git a/StdLib/Maybe.gr b/StdLib/Maybe.gr index 497181348..e5907fb4f 100644 --- a/StdLib/Maybe.gr +++ b/StdLib/Maybe.gr @@ -11,7 +11,7 @@ import Bool --- Type-safe null; wrap a computation that could fail -data Maybe a where Some a | None +data Maybe a = None | Some a --- The maybe function takes a default value, a function, and a Maybe value. --- If the Maybe value is None, the function returns the default value. @@ -19,33 +19,31 @@ data Maybe a where Some a | None -- returns the result. maybe : forall a : Type, b : Type . b [0..1] -> (a -> b) [0..1] -> Maybe a -> b -maybe [default] [f] m = case m of None -> default; Some x -> f x +maybe [d] [_] None = d; +maybe [_] [f] (Some x) = f x -- Monady interface for Maybe -return : forall a : Type . a -> Maybe a -return = Some +returnMb : forall a : Type . a -> Maybe a +returnMb = Some -bind : forall a : Type, b : Type +bindMb : forall a : Type, b : Type . Maybe a -> (a -> Maybe b) [0..1] -> Maybe b -bind m [k] = - case m of - None -> None; - Some x -> k x +bindMb None [_] = None; +bindMb (Some x) [k] = k x --- The fromMaybe function takes a default value and and Maybe value. If the -- Maybe is None, it returns the default values; otherwise, it returns the value -- contained in the Maybe. fromMaybe : forall a : Type . a [0..1] -> Maybe a -> a -fromMaybe default m = maybe default [\(x : a) -> x] m +fromMaybe [d] None = d; +fromMaybe [_] (Some x) = x ---- The isSome function returns True iff its argument is of the form Some _. +--- Whether a `Maybe a` value is `Some a` isSome : forall a : Type . Maybe (a [0]) -> Bool -isSome m = - case m of - Some [x] -> True; - None -> False +isSome None = False; +isSome (Some [_]) = True --- The isNone function returns True iff its argument is None. +--- Whether a `Maybe a` value is `None` isNone : forall a : Type . Maybe (a [0]) -> Bool isNone m = not (isSome m) diff --git a/StdLib/Nat.gr b/StdLib/Nat.gr index 675ccbd65..930aeef77 100644 --- a/StdLib/Nat.gr +++ b/StdLib/Nat.gr @@ -13,33 +13,57 @@ data N (n : Nat) where S : N n -> N (n+1) --- Convert an indexed natural number to an untyped int -natToInt : forall {n : Nat} . N n -> Int +natToInt + : forall {n : Nat} + . N n -> Int natToInt Z = 0; natToInt (S m) = 1 + natToInt m --- # Arithmetic operations --- Addition -add : forall {n : Nat, m : Nat} . N n -> N m -> N (n + m) +add + : forall {m n : Nat} + . N n -> N m -> N (n + m) add Z m = m; add (S n') m = S (add n' m) -monus : forall m : Nat, n : Nat . N m -> N n -> N (m - n) +-- Cut-off subtraction +monus + : forall {m n : Nat} + . N m -> N n -> N (m - n) monus m Z = m; monus Z (S n') = monus Z n'; monus (S m') (S n') = monus m' n' +sub + : forall {m n : Nat} + . {n ≥ m} => N n -> N m -> N (n - m) +sub m Z = m; +sub (S m') (S n') = sub m' n' + +-- less explicit than `sub`, therefore sub-prime (excuse the pun) +-- sub' : forall m n. N (m + n) -> N m -> N n +-- sub' m Z = m; +-- sub' (S m') (S n') = sub' m' n' + --- Right-moded multiplication -mult : forall {n : Nat, m : Nat} . N n -> (N m) [n] -> N (n * m) +mult + : forall {m n : Nat} + . N n -> (N m) [n] -> N (n * m) mult Z [m] = Z; mult (S n') [m] = add m (mult n' [m]) --- Left-moded multiplication -mult_r : forall {n : Nat, m : Nat} . (N n) [m] -> (N m) -> N (n * m) +mult_r + : forall {m n : Nat} + . (N n) [m] -> (N m) -> N (n * m) mult_r [n] Z = Z; mult_r [n] (S m') = add n (mult_r [n] m') --- Divide by two -div2 : forall {n : Nat} . N (2 * n) -> N n +div2 + : forall {n : Nat} + . N (2 * n) -> N n div2 Z = Z; div2 (S (S x)) = S (div2 x) diff --git a/StdLib/Prelude.gr b/StdLib/Prelude.gr index 0e90fa3b3..d81d671fd 100644 --- a/StdLib/Prelude.gr +++ b/StdLib/Prelude.gr @@ -25,28 +25,21 @@ flip f x y = f y x const : forall a : Type, b : Type . a -> b [0] -> a const x [y] = x ---- linear function composition (use infix ``g `o` f``) -o : forall a : Type, b : Type, c : Type +--- linear function composition (the composition operator `g ∘ f` resolves +--- to whatever is bound to `compose`) +compose : forall a : Type, b : Type, c : Type . (b -> c) -> (a -> b) -> (a -> c) -o g f = \x -> g (f x) +compose g f = \x -> g (f x) --- Apply f to x until p holds -until : forall a : Type - . (a -> Bool) [∞] -> (a -> a) [∞] -> a [∞] -> a +until + : forall a : Type + . (a -> Bool) [1..∞] -> (a -> a) [0..∞] -> a [2..∞] -> a until [p] [f] [x] = case p x of False -> x; True -> until [p] [f] [f x] ---- Standard fixed point -fix : forall {a : Type} . (a -> a) [∞] -> a -fix [f] = f (fix [f]) - ---- Specialised first-order fixed point -fixF : forall {a : Type, b : Type} - . ((a -> b) [∞] -> (a -> b)) [∞] -> (a -> b) -fixF [f] = f [fixF [f]] - --- Conditional on integers --- Returns `x` if `g` is zero, else returns `y` if0 : forall a : Type . Int [0..1] -> a [0..1] -> a [0..1] -> a @@ -118,9 +111,9 @@ unflatten : forall {a : Type, n : Nat, m : Nat} . a [n*m] -> (a [n]) [m] unflatten [x] = [[x]] --- Push coeffects on a pair into the left and right elements -push : forall {a : Type, b : Type, n : Nat} . (a × b) [n] -> a [n] × b [n] +push : forall {a : Type, b : Type, k : Coeffect, c : k} . (a × b) [c] -> a [c] × b [c] push [(x, y)] = ([x], [y]) --- Pull coeffects of pair elements up to the pair -pull : forall {a : Type, b : Type, n : Nat} . a [n] × b [n] -> (a × b) [n] +pull : forall {a : Type, b : Type, k : Coeffect, c : k} . a [c] × b [c] -> (a × b) [c] pull ([x], [y]) = [(x, y)] diff --git a/StdLib/Stack.gr b/StdLib/Stack.gr index bb6833868..8d08ebc5f 100644 --- a/StdLib/Stack.gr +++ b/StdLib/Stack.gr @@ -1,12 +1,18 @@ -data Stack : Nat -> Type -> Type where - Empty : forall {a : Type} . Stack 0 a; - Ext : forall {a : Type, n : Nat} . a [0..∞] -> Stack n a -> Stack (n+1) a +-- Use vectors to implement stacks +import Vec -pop : forall {n : Nat, a : Type} . Stack (n+1) a -> (a [0..∞], Stack n a) -pop (Ext x xs) = (x, xs) +pop : forall {n : Nat, a : Type} . Vec (n+1) a -> (a, Vec n a) +pop = uncons -push : forall {n : Nat, a : Type} . a [0..∞] -> Stack n a -> Stack (n+1) a -push x s = Ext x s +push : forall {n : Nat, a : Type} . a -> Vec n a -> Vec (n+1) a +push = Cons -peek : forall {n : Nat, a : Type} . Stack (n+1) a -> (a, Stack (n+1) a) -peek (Ext [x] xs) = (x, Ext [x] xs) +peek : forall {n : Nat, a : Type} . (Vec (n+1) a) [1..2] -> (a, Vec (n+1) a) +peek [Cons x xs] = (x, Cons x xs) + +peek' : forall {n : Nat, m : Ext Nat, a : Type} + . Vec (n+1) (a [m..m+1]) -> (a, Vec (n+1) (a [m..m])) +peek' (Cons [x] xs) = (x, Cons [x] xs) + +peek'' : forall {n : Nat, a : Type} . Vec (n+1) (a [1..2]) -> (a, Vec (n+1) a) +peek'' (Cons [x] xs) = (x, case pullVec xs of [xs'] -> Cons x xs') diff --git a/StdLib/Vec.gr b/StdLib/Vec.gr index 00a36c57c..316666095 100644 --- a/StdLib/Vec.gr +++ b/StdLib/Vec.gr @@ -18,124 +18,168 @@ data Vec (n : Nat) t where Cons : t -> Vec n t -> Vec (n+1) t -- Length of an indexed vector into an indexed nat -length : forall {a : Type, n : Nat} - . Vec n (a [0]) -> N n +-- discarding the elements +length + : forall {a : Type, n : Nat} + . Vec n (a [0]) -> N n length Nil = Z; length (Cons [_] xs) = S (length xs) +-- Length of an indexed vector into an indexed nat +-- copying the spine of the lists and preserinv the elements +length' + : forall {a : Type, n : Nat} + . Vec n a -> (N n, Vec n a) +length' Nil = (Z, Nil); +length' (Cons x xs) = let (n, xs) = length' xs in (S n, Cons x xs) + --- Map function -map : forall {a : Type, b : Type, n : Nat} - . (a -> b) [n] -> Vec n a -> Vec n b +map + : forall {a b : Type, n : Nat} + . (a -> b) [n] -> Vec n a -> Vec n b map [_] Nil = Nil; map [f] (Cons x xs) = Cons (f x) (map [f] xs) -- Safe random-access indexing from a vector -index : forall a : Type, n : Nat - . Fin (n + 1) -> (Vec (n + 1) a) [0..1] -> a -index FZ [Cons x _] = x; -index (FS k) [Cons _ xs'] = index k [xs'] +index : forall a : Type, n m : Nat + . {m > n} => N n -> (Vec m a) [0..1] -> a +index Z [Cons x _] = x; +index (S k) [Cons _ xs'] = index k [xs'] -- Standard foldr on vectors -foldr : forall {a : Type, b : Type, n : Nat} - . (a -> b -> b) [n] -> b -> Vec n a -> b +foldr + : forall {a b : Type, n : Nat} + . (a -> b -> b) [n] -> b -> Vec n a -> b foldr [_] z Nil = z; foldr [f] z (Cons x xs) = f x (foldr [f] z xs) -foldr1 : forall {a : Type, n : Nat} - . (a -> a -> a) [n] -> Vec (n + 1) a -> a +foldr1 + : forall {a : Type, n : Nat} + . (a -> a -> a) [n] -> Vec (n + 1) a -> a foldr1 [_] (Cons x Nil) = x; foldr1 [mag] (Cons x (Cons x' xs)) = foldr1 [mag] (Cons (x `mag` x') xs) -foldl : forall {a : Type, b : Type, n : Nat} - . (b -> a -> b) [n] -> b -> Vec n a -> b +foldl + : forall {a b : Type, n : Nat} + . (b -> a -> b) [n] -> b -> Vec n a -> b foldl [_] acc Nil = acc; foldl [op] acc (Cons x xs) = foldl [op] (acc `op` x) xs -- Append two vectors -append : forall {a : Type, n : Nat, m : Nat} - . Vec n a -> Vec m a -> Vec (n + m) a +append + : forall {a : Type, m n : Nat} + . Vec n a -> Vec m a -> Vec (n + m) a append Nil ys = ys; append (Cons x xs) ys = Cons x (append xs ys) -drop : forall a : Type, m : Nat, n : Nat - . N m -> (Vec n a) [0..1] -> Vec (n - m) a +drop + : forall {a : Type, m n : Nat} + . N m -> (Vec n a) [0..1] -> Vec (n - m) a drop Z [xs] = xs; drop (S n) [Nil] = drop n [Nil]; drop (S n) [Cons _ xs] = drop n [xs] -take : forall a : Type, m : Nat, n : Nat - . N m -> (Vec n a) [0..1] -> Vec (n + (m - n)) a +take + : forall {a : Type, m n : Nat} + . N m -> (Vec n a) [0..1] -> Vec (n + (m - n)) a take Z [xs] = xs; take (S k) [Cons x xs] = Cons x (take k [xs]) --- Return the first item (head) of the vector --- NB: non-linear in the vector -head : forall {a : Type, n : Nat} - . (Vec (n + 1) a) [0..1] -> a +head + : forall {a : Type, n : Nat} + . (Vec (n + 1) a) [0..1] -> a head [Cons x _] = x --- Return the vector with the first item removed --- NB: non-linear in the vector -tail : forall {a : Type, n : Nat} - . (Vec (n + 1) a) [0..1] -> Vec n a +tail + : forall {a : Type, n : Nat} + . (Vec (n + 1) a) [0..1] -> Vec n a tail [Cons _ xs] = xs --- Get the last item of a Vector -last : forall {a : Type, n : Nat} - . (Vec (n + 1) a) [0..1] -> a -last [Cons x Nil] = x; -last [Cons _ xs] = last [xs] +--last : forall {a : Type, n : Nat} +-- . (Vec (n + 1) a) [0..1] -> a +--last [Cons x Nil] = x; +--last [Cons _ xs] = last [xs] --- -init : forall {a : Type, n : Nat} - . (Vec (n + 1) a) [0..1] -> Vec n a -init [Cons _ Nil] = Nil; -init [Cons x xs] = Cons x (init [xs]) - -uncons : forall a : Type, n : Nat - . Vec (n + 1) a -> (a, Vec n a) +--init : forall {a : Type, n : Nat} +-- . (Vec (n + 1) a) [0..1] -> Vec n a +--init [Cons _ Nil] = Nil; +--init [Cons x xs] = Cons x (init [xs]) + +uncons + : forall {a : Type, n : Nat} + . Vec (n + 1) a -> (a, Vec n a) uncons (Cons x xs) = (x,xs) --- Split a vector at position 'n' -split : forall {n : Nat, m : Nat, a : Type} - . N n -> (Vec (n + m) a) -> (Vec n a, Vec m a) +split + : forall {a : Type, m n : Nat} + . N n -> (Vec (n + m) a) -> (Vec n a, Vec m a) split Z xs = (Nil, xs); split (S n) (Cons x xs) = let (xs', ys') = split n xs in (Cons x xs', ys') --- Simple folds -sum : forall n : Nat . Vec n Int -> Int +sum + : forall {n : Nat} + . Vec n Int -> Int sum = foldr [\(x : Int) -> \(y : Int) -> x + y] 0 -product : forall n : Nat . Vec n Int -> Int +product + : forall {n : Nat} + . Vec n Int -> Int product = foldr [\(x : Int) -> \(y : Int) -> x * y] 1 --- Replicate n x is a vector of length n with x the value of every element -replicate : forall {n : Nat, a : Type} . N n -> a [n] -> Vec n a +replicate + : forall {a : Type, n : Nat} + . N n -> a [n] -> Vec n a replicate Z [c] = Nil; replicate (S n) [c] = Cons c (replicate n [c]) --- Make a vector of length n with all integers from 0 to n-1 --- > range (S (S (S (S Z)))) --- Cons 0 (Cons 1 (Cons 2 (Cons 3 Nil))) -range : forall n : Nat . N n -> Vec n Int +range + : forall {n : Nat} + . N n -> Vec n Int range n = range' n [0] --- Make a vector of length n with all integers from `start` up until `n + i - 1` --- > range' (S (S (S (S Z)))) [-6] --- Cons -6 (Cons -5 (Cons -4 (Cons -3 Nil))) -range' : forall n : Nat . N n -> Int [n] -> Vec n Int +range' + : forall {n : Nat} + . N n -> Int [n] -> Vec n Int range' Z [i] = Nil; range' (S n) [i] = Cons i (range' n [i + 1]) --- pullVec pulls non linearity in elements into a non linearity on the whole vector -pullVec : forall {k : Nat, n : Nat, a : Type} - . Vec n (a [k]) -> (Vec n a) [k] +pullVec + : forall {a : Type, c : Coeffect, k : c, n : Nat} + . Vec n (a [k]) -> (Vec n a) [k] pullVec Nil = [Nil]; pullVec (Cons [x] xs) = case pullVec xs of [ys] -> [Cons x ys] -copySpine : forall a : Type, n : Nat - . Vec n a -> Vec n () × Vec n a +copySpine + : forall {a : Type, n : Nat} + . Vec n a -> Vec n () × Vec n a copySpine Nil = (Nil, Nil); copySpine (Cons x xs) = let (ss, xs) = copySpine xs in (Cons () ss, Cons x xs) + +data VecX a where + VecX : ∀ n . Vec n a → VecX a + +-- import Maybe + +-- stringToVecX : String → VecX Char +-- stringToVecX s = case stringUncons s of +-- None → VecX Nil; +-- Some (c, s) → let VecX v = stringToVecX s in VecX (Cons c v) + diff --git a/compiler/src/Language/Granule/Codegen/ClosureFreeDef.hs b/compiler/src/Language/Granule/Codegen/ClosureFreeDef.hs index 77f049673..d8e642f81 100644 --- a/compiler/src/Language/Granule/Codegen/ClosureFreeDef.hs +++ b/compiler/src/Language/Granule/Codegen/ClosureFreeDef.hs @@ -45,12 +45,6 @@ data ClosureFreeFunctionDef = ClosureFreeFunctionDef { type ClosureFreeExpr = Expr (Either GlobalMarker ClosureMarker) Type type ClosureFreeValue = Value (Either GlobalMarker ClosureMarker) Type - -instance Definition ClosureFreeFunctionDef where - definitionSpan = closureFreeDefSpan - definitionIdentifier = closureFreeDefIdentifier - definitionTypeScheme = closureFreeDefTypeScheme - type ClosureFreeValueDef = ValueDef (Either GlobalMarker ClosureMarker) Type data ClosureMarker = diff --git a/compiler/src/Language/Granule/Codegen/NormalisedDef.hs b/compiler/src/Language/Granule/Codegen/NormalisedDef.hs index 128da3fec..8237e724d 100644 --- a/compiler/src/Language/Granule/Codegen/NormalisedDef.hs +++ b/compiler/src/Language/Granule/Codegen/NormalisedDef.hs @@ -85,11 +85,6 @@ data ValueDef v a = deriving instance (Show a, Show v) => Show (ValueDef v a) deriving instance (Eq a, Eq v) => Eq (ValueDef v a) -instance Definition (ValueDef v a) where - definitionSpan = valueDefSpan - definitionIdentifier = valueDefIdentifier - definitionTypeScheme = valueDefTypeScheme - data FunctionDef v a = FunctionDef { functionDefSpan :: Span, diff --git a/examples/Cake.gr b/examples/Cake.gr index adb1843b0..7b879e87f 100644 --- a/examples/Cake.gr +++ b/examples/Cake.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Cake where Cake : Cake data Happy where Happy : Happy diff --git a/examples/Church.gr b/examples/Church.gr index a9c58844f..ff17fbdee 100644 --- a/examples/Church.gr +++ b/examples/Church.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + -- Church numerals have graded types that explain what they encode zero : ∀ {a : Type} . (a → a) [0] → a → a diff --git a/examples/CombinatoryLogic.gr b/examples/CombinatoryLogic.gr index bfdb3854c..a9691dc70 100644 --- a/examples/CombinatoryLogic.gr +++ b/examples/CombinatoryLogic.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + i : ∀ {a : Type} . a → a i x = x diff --git a/examples/Database.gr b/examples/Database.gr index 8b3b8067e..3bb8525da 100644 --- a/examples/Database.gr +++ b/examples/Database.gr @@ -20,6 +20,9 @@ meanAge' [Next (Patient [_] [_] [age]) xs] [total] [n] = meanAge' [Empty] [total] [n] = [div total n] +main : Int [Public] +main = meanAge [Next (Patient [1] ["Alice"] [32]) (Next (Patient [2] ["Bob"] [16]) Empty)] + -- Rejected -- names : (List Patient) [0..1] → String [Public] -- names [Next (Patient [_] [name] [_]) xs] = diff --git a/examples/Database.gr.output b/examples/Database.gr.output new file mode 100644 index 000000000..cabf43b5d --- /dev/null +++ b/examples/Database.gr.output @@ -0,0 +1 @@ +24 \ No newline at end of file diff --git a/examples/Door.gr b/examples/Door.gr index cf08f8c61..e45316c2c 100644 --- a/examples/Door.gr +++ b/examples/Door.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + -- Example based on 'Type-Driven Development of Concurrent Communicating Systems' by Edwin Brady. data Opened where @@ -18,6 +20,6 @@ data DoorLang : Type → Type where doorOK : DoorH Closed → DoorLang (DoorH Opened) doorOK h = -- do - Action (Knock h) `ThenWith` (λ(h : DoorH Closed) + Action (Knock h) `ThenWith` (λ(h : DoorH Closed) → Action (Knock h) `ThenWith` (λ(h : DoorH Closed) → Action (OpenDoor h))) diff --git a/examples/Files.gr b/examples/Files.gr index a4e852fec..0dc1069a9 100644 --- a/examples/Files.gr +++ b/examples/Files.gr @@ -1,7 +1,7 @@ -main : String +main : String main = - let h ← openFile "LICENSE" ReadMode; - (h, c) ← hGetChar h; - (h, c') ← hGetChar h; - () ← hClose h - in pure (((showChar c) `stringAppend` (showChar c'))) + let h ← openHandle ReadMode "LICENSE"; + (h, c1) ← readChar h; + (h, c2) ← readChar h; + () ← closeHandle h + in pure (stringCons c1 (stringCons c2 "")) \ No newline at end of file diff --git a/examples/Files.gr.output b/examples/Files.gr.output new file mode 100644 index 000000000..586bc9d14 --- /dev/null +++ b/examples/Files.gr.output @@ -0,0 +1 @@ +"Co" \ No newline at end of file diff --git a/examples/Files2.gr b/examples/Files2.gr deleted file mode 100644 index 49df3f1ee..000000000 --- a/examples/Files2.gr +++ /dev/null @@ -1,34 +0,0 @@ -import File -import List - --- Haskell vs Granule file manipulation - --- openFile :: String → IOMode → IO Handle -openFile' : String → IOMode → Handle -openFile' = openFile - --- hGetChar :: Handle → IO Char -hGetChar' : Handle → (Handle, Char) -hGetChar' = hGetChar - --- hPutChar :: Handle → Char → IO () -hPutChar' : Handle → Char → Handle -hPutChar' = hPutChar - --- hClose :: Handle → IO () -hClose' : Handle → () -hClose' = hClose - -getMany : Int → Handle → (Handle, String) -getMany 0 h = pure (h, ""); -getMany n h = let - (h, c) ← hGetChar h; - (h, cs) ← getMany (n - 1) h - in pure (h, stringAppend (showChar c) cs) - -main : String -main = let - h ← openFile "LICENSE" ReadMode; - (h, s) ← getMany 10 h; - () ← hClose h - in pure s diff --git a/examples/FilesBoxed.gr b/examples/FilesBoxed.gr index 962c6d8ba..20e023ab9 100644 --- a/examples/FilesBoxed.gr +++ b/examples/FilesBoxed.gr @@ -2,11 +2,11 @@ import File main : String main = - let [mh] = [openFile "LICENSE" ReadMode] in - let h ← mh; - h' ← mh; - () ← hClose h'; - (h, c) ← hGetChar h; - (h, c') ← hGetChar h; - () ← hClose h + let [mh] = [openHandle ReadMode "LICENSE"] in + let h <- mh; + h' <- mh; + () <- closeHandle h'; + (h, c) <- readChar h; + (h, c') <- readChar h; + () <- closeHandle h in pure ((showChar c) `stringAppend` (showChar c')) diff --git a/examples/FilesBoxed.gr.output b/examples/FilesBoxed.gr.output new file mode 100644 index 000000000..586bc9d14 --- /dev/null +++ b/examples/FilesBoxed.gr.output @@ -0,0 +1 @@ +"Co" \ No newline at end of file diff --git a/examples/Fold.gr.output b/examples/Fold.gr.output new file mode 100644 index 000000000..62f945751 --- /dev/null +++ b/examples/Fold.gr.output @@ -0,0 +1 @@ +6 \ No newline at end of file diff --git a/examples/Ftree.gr b/examples/Ftree.gr index 3608d14bf..b9d1731cd 100644 --- a/examples/Ftree.gr +++ b/examples/Ftree.gr @@ -1,8 +1,10 @@ +-- gr --no-eval + import List import Vec --- A tree which abstracts over the branching factor. ---- Stolen from SPJ's _Adventure with Types in Haskell_ (lecture 2) +--- Stolen from SPJ's _Adventures with Types in Haskell_ (lecture 2) data FTree (f : Type → Type) a where Leaf : a → FTree f a; Branch : f (FTree f a) → FTree f a diff --git a/examples/IO.gr b/examples/IO.gr index b9254e35a..5e4a4b6dc 100644 --- a/examples/IO.gr +++ b/examples/IO.gr @@ -1,5 +1,7 @@ +-- gr --no-eval + dubInput : () -dubInput = let x ← readInt in write (showInt (x * 2)) +dubInput = let x ← readInt in toStdout (showInt (x * 2)) main : () main = dubInput diff --git a/examples/LeftPad.gr b/examples/LeftPad.gr deleted file mode 100644 index 6db337ebd..000000000 --- a/examples/LeftPad.gr +++ /dev/null @@ -1,6 +0,0 @@ -import Vec - -leftPad : ∀ {n : Nat, m : Nat} - . Char [n] → N n → Vec m Char → Vec (n + m) Char -leftPad [_] Z str = str; -leftPad [c] (S n) str = Cons c (leftPad [c] n str) diff --git a/examples/LeftPadShort.gr b/examples/LeftPadShort.gr new file mode 100644 index 000000000..9c1264c8a --- /dev/null +++ b/examples/LeftPadShort.gr @@ -0,0 +1,29 @@ +import Vec +import Nat + +-- Representing strings as lists of chars.. + +leftPad : forall {t : Type, m : Nat, n : Nat} + . Vec n t -> t [m - n] -> N m -> Vec (n ∨ m) t +leftPad str c n = + let (m, str) = length' str + in append (replicate (monus n m) c) str + +-- The type says that given an input vector of length `n` and a target +-- length `m` then we must consume the padding element of type `t` +-- exactly `m - n` times to produce the output vector of the target +-- `m`. + +-- In Granule this type alone implies the specification---modulo +-- reordering of elements---via: +-- +-- * Parametric polymorphism: ensuring that the implementation cannot +-- depend on the concrete padding items provided or the items of the +-- input list (hence we use lists instead of strings; +-- +-- * Indexed types ensuring the correct size and explaining the exact +-- usage of the padding element; +-- +-- * Graded linearity: ensuring that every item in the input list +-- appears exactly once in the output. The type `t [m - n]` of the +-- padding element reveals its exact usage. diff --git a/examples/LeftPadTutorial.gr b/examples/LeftPadTutorial.gr new file mode 100644 index 000000000..901ac03dd --- /dev/null +++ b/examples/LeftPadTutorial.gr @@ -0,0 +1,138 @@ +-- The following demonstrates the interaction between linear, indexed, +-- and graded modal types in Granule via the function `leftPad`. + +-- The syntax of Granule is similar to Haskell, but Granule is +-- eager (call-by-value) and is linear-by-default, that is, every +-- variable must be used exactly once, unless it is wrapped +-- in a "graded modal type". We'll see these as we go: + +-- `leftPad` takes a vector and a value and pads the vector to a +-- desired length with that value + +-- First, let's start by defining some indexed types, which in +-- Granule follow Haskell's GADT syntax. + +-- The following gives the data types for sized-indexed vectors + +data Vec (n : Nat) (a : Type) where + Nil : Vec 0 a; + Cons : a -> Vec n a -> Vec (n + 1) a + +-- And the "singleton" representation for indexed naturals: + +data N (n : Nat) where + Z : N 0; + S : N n -> N (n + 1) + +-- We can then define the standard kinds of functions on size-indexed +-- vectors, e.g., append + +append : forall {t : Type, n : Nat, m : Nat} . Vec n t -> Vec m t -> Vec (n + m) t +append Nil ys = ys; +append (Cons x xs) ys = Cons x (append xs ys) + +-- Indexed types give us the useful property that the length of the +-- output list is indeed the sum of the length of the inputs. But +-- because Granule is linear we also get the additional guarantee +-- that: every element from the inputs must appear in the output. In a +-- nonlinear setting, the implementation of this type could drop and +-- copy values, as long as the output has the correct length. + +-- The length function on a vector ignores the elements in the +-- vector. Thus in Granule, we can leverage the graded modal types +-- to explain that `length` uses the elements of a vector precisely +-- 0 times: + +length : forall {t : Type, n : Nat} . Vec n (t [0]) -> N n +length Nil = Z; +length (Cons [_] xs) = S (length xs) + +-- The type `t [0]` represents values of type `t` wrapped in a +-- "graded modality" whose "grade" (index) states that the value +-- is used 0 times. This non-linear behaviour is then accessed by +-- the "unboxing" pattern match in the second equation of `length`. + +-- Alternatively, we can reconstruct the vector and return it +-- whilst also building the length: + +length' : forall {t : Type, n : Nat} . Vec n t -> (N n, Vec n t) +length' Nil = (Z, Nil); +length' (Cons x xs) = + let (n, xs) = length' xs in (S n, Cons x xs) + +-- Granule brings graded and indexed types together so that we +-- can have graded modal types that explain how the usage of a +-- value depends on other values. For example, when we replicate +-- a value to create a vector of a particular size, we consume +-- that value exactly the number of times as the desired length +-- of the output vector: + +replicate : forall {t : Type, n : Nat} . N n -> t [n] -> Vec n t +replicate Z [c] = Nil; +replicate (S n) [c] = Cons c (replicate n [c]) + +-- Note again the graded modal type `t [n]` here providing the +-- ability to use `t` exactly `n` times. In the second equation, +-- with `n` equal to `m + 1` for some `m : Nat`, +-- we pattern match on the graded modality, meaning we can use +-- the variable `c` exactly `m+1` times, where it is used once +-- to build a `Cons` cell and then it is "reboxed" to provide +-- the capability to be used `m` times in the recursive call. + +-- We can now define left pad with one further helper combinator +-- that subtracts two indexed naturals: + +sub : forall {m : Nat, n : Nat} . {m >= n} => N m -> N n -> N (m - n) +sub m Z = m; +sub (S m') (S n') = sub m' n' + +-- Note that this also shows off Granule's "refinement type" style +-- predicates, where before => in the type we have a precondition +-- that `m` is greater than or equal to `n`. + +-- Finally we can put all these together to give the definition +-- of `leftPad`: + +leftPad : forall {t : Type, m : Nat, n : Nat} + . {m >= n} => Vec n t -> t [m - n] -> N m -> Vec m t +leftPad str c n = + let (m, str) = length' str + in append (replicate (sub n m) c) str + +-- The type says that given a target length an input vector of length `n` +-- and a target length `m` that is greater than or equal to `m`, then we +-- must consume the padding element of type `t` exactly `m - n` times to +-- produce the output vector of the target `m`. + +-- In Granule this type alone implies the specification---modulo +-- reordering of elements---via: +-- +-- * Parametric polymorphism: ensuring that the implementation cannot +-- depend on the concrete padding items provided or the items of the +-- input list (hence we use lists instead of strings; +-- +-- * Indexed types ensuring the correct size and explaining the exact +-- usage of the padding element; +-- +-- * Graded linearity: ensuring that every item in the input list +-- appears exactly once in the output. The type `t [m - n]` of the +-- padding element reveals its exact usage. + +-- The type of `leftPad` in Granule is superficially similar to what +-- we could write in GHC Haskell or a fully dependently-typed +-- language, except for the nonlinearity of the padding element, a +-- minor syntactic addition. However the extra guarantees we get in a +-- graded linear system like Granule's means we get properties for +-- free which we would otherwise have to prove ourselves. + +-- Let's run it! +-- e.g., take an `input` vector of length 3 containing integers... + +input : Vec 3 Int +input = Cons 1 (Cons 2 (Cons 3 Nil)) + +-- ... pad it on the "left" of the vector with the value 0 until it a +-- vector length 6 + +main : Vec 6 Int +main = leftPad input [0] (S (S (S (S (S (S Z)))))) \ No newline at end of file diff --git a/examples/LeftPadTutorial.gr.output b/examples/LeftPadTutorial.gr.output new file mode 100644 index 000000000..db2dea6f2 --- /dev/null +++ b/examples/LeftPadTutorial.gr.output @@ -0,0 +1 @@ +Cons 0 (Cons 0 (Cons 0 (Cons 1 (Cons 2 (Cons 3 Nil))))) \ No newline at end of file diff --git a/examples/NonEmpty.gr b/examples/NonEmpty.gr index 76b9e1a03..5a6cc33ee 100644 --- a/examples/NonEmpty.gr +++ b/examples/NonEmpty.gr @@ -4,7 +4,7 @@ data NonEmpty a where head : ∀ a : Type . (NonEmpty a) [0..1] → a head [Next x _] = x; -| [NonEmpty x] = x +head [NonEmpty x] = x main : Int main = head [NonEmpty 1] diff --git a/examples/NonEmpty.gr.output b/examples/NonEmpty.gr.output new file mode 100644 index 000000000..56a6051ca --- /dev/null +++ b/examples/NonEmpty.gr.output @@ -0,0 +1 @@ +1 \ No newline at end of file diff --git a/examples/Secure.gr b/examples/Secure.gr index f198647c3..1336c5077 100644 --- a/examples/Secure.gr +++ b/examples/Secure.gr @@ -16,8 +16,8 @@ hash [x] = [x + x] main : Int [Private] main = hash secret --- Flattening takes the meet (`∨`) of both Levels (see example below). -flatten : ∀ k : Level, l : Level . (Int [k]) [l] → Int [k ∨ l] +-- Flattening takes the meet (∧) of both Levels (see example below). +flatten : ∀ k : Level, l : Level . (Int [k]) [l] → Int [k ∧ l] flatten [[x]] = [x] xbb : (Int [Public]) [Private] diff --git a/examples/Secure.gr.output b/examples/Secure.gr.output new file mode 100644 index 000000000..cebceba23 --- /dev/null +++ b/examples/Secure.gr.output @@ -0,0 +1 @@ +2468 \ No newline at end of file diff --git a/examples/Sessions.gr b/examples/Sessions.gr index 82715eaa6..300656f2f 100644 --- a/examples/Sessions.gr +++ b/examples/Sessions.gr @@ -5,7 +5,7 @@ fooClient : Chan (Send Bool (Recv Int End)) → Int fooClient c = let c ← send c True; (n, c) ← recv c; - () ← close c + _ ← close c in pure n fooServer : Chan (Dual (Send Bool (Recv Int End))) → () @@ -16,7 +16,7 @@ fooServer c = example : Int example = - let c ← fork fooServer + let c ← forkLinear fooServer in fooClient c @@ -30,7 +30,7 @@ sendVec : ∀ {n : Nat, a : Type} . sendVec [c] Nil = pure (); sendVec [c] (Cons x xs) = let c' ← send c x; - () ← close c' + _ ← close c' in sendVec [c] xs recvVec : ∀ {n : Nat, a : Type} . @@ -38,14 +38,14 @@ recvVec : ∀ {n : Nat, a : Type} . recvVec Z [c] = pure Nil; recvVec (S n) [c] = let (x, c') ← recv c; - () ← close c'; + _ ← close c'; xs ← recvVec n [c] in pure (Cons x xs) example2 : ∀ {n : Nat, a : Type} . N n → Vec n a → (Vec n a) example2 n list = - let c ← forkRep (λc → sendVec c list) + let c ← fork (λc → sendVec c list) in recvVec n c main : (Vec 5 Int, Int) diff --git a/examples/Sessions.gr.output b/examples/Sessions.gr.output new file mode 100644 index 000000000..5f1098822 --- /dev/null +++ b/examples/Sessions.gr.output @@ -0,0 +1 @@ +(Cons 1 (Cons 1 (Cons 2 (Cons 3 (Cons 5 Nil)))), 1) \ No newline at end of file diff --git a/examples/ablist.gr b/examples/ablist.gr index 0bf488c89..b0ad25048 100644 --- a/examples/ablist.gr +++ b/examples/ablist.gr @@ -9,5 +9,10 @@ data ABList (a : Type) (b : Type) : Nat → Nat → Type where abmap : ∀ {a : Type, b : Type, c : Type, d : Type, n : Nat, m : Nat} . (a → b) [m] → (c → d) [n] → ABList a c m n → ABList b d m n abmap [_] [_] Nil = Nil; -| [f] [g] (Acons a xs) = Acons (f a) (abmap [f] [g] xs); -| [f] [g] (Bcons b xs) = Bcons (g b) (abmap [f] [g] xs) +abmap [f] [g] (Acons a xs) = Acons (f a) (abmap [f] [g] xs); +abmap [f] [g] (Bcons b xs) = Bcons (g b) (abmap [f] [g] xs) + +import Bool + +main : ABList Bool Int 1 2 +main = abmap [not] [λx → x + 1] (Bcons 1 (Acons True (Bcons 0 Nil))) diff --git a/examples/ablist.gr.output b/examples/ablist.gr.output new file mode 100644 index 000000000..bb8115416 --- /dev/null +++ b/examples/ablist.gr.output @@ -0,0 +1 @@ +Bcons 2 (Acons False (Bcons 1 Nil)) \ No newline at end of file diff --git a/examples/cata.gr b/examples/cata.gr index f9c785f29..62b7f2316 100644 --- a/examples/cata.gr +++ b/examples/cata.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + import Prelude import Fix @@ -6,11 +8,11 @@ data Expr expr where App expr expr; Abs Int expr -map_expr : ∀ a : Type, b : Type . (a → b) [∞] → Expr a → Expr b +map_expr : ∀ a : Type, b : Type . (a → b) [] → Expr a → Expr b map_expr [f] e = case e of Var i → Var i; App e1 e2 → App (f e1) (f e2); Abs i e → Abs i (f e) -cata : ∀ a : Type . (Expr a → a) [∞] → Fix Expr → a -cata [alg] = alg `o` (map_expr [cata [alg]]) `o` unfix +cata : ∀ a : Type . (Expr a → a) [] → Fix Expr → a +cata [alg] = alg ∘ map_expr [cata [alg]] ∘ unfix diff --git a/examples/coeffect-poly.gr b/examples/coeffect-poly.gr new file mode 100644 index 000000000..5862e168f --- /dev/null +++ b/examples/coeffect-poly.gr @@ -0,0 +1,9 @@ +-- gr --no-eval + +-- works on any coeffect +cp : forall {a : Type, c : Coeffect} . a [(1 + 1):c] -> (a × a) +cp [x] = (x, x) + +-- equivalent +cp2 : forall {a : Type, c : Coeffect} . a [2:c] -> (a × a) +cp2 [x] = (x,x) \ No newline at end of file diff --git a/examples/filterSequence.gr.output b/examples/filterSequence.gr.output new file mode 100644 index 000000000..52e88a6e3 --- /dev/null +++ b/examples/filterSequence.gr.output @@ -0,0 +1 @@ +Next 1 (Next 2 Empty) \ No newline at end of file diff --git a/examples/further-examples.gr b/examples/further-examples.gr new file mode 100644 index 000000000..f12cec22e --- /dev/null +++ b/examples/further-examples.gr @@ -0,0 +1,66 @@ +-- This is a stripped down version of `further-examples.md.gr` without all the explanation. +-- But this is useful for experimenting with in `grin`. + +-- $ grin +-- > :l examples/further-examples.gr + +pushPair : forall {a : Type, b : Type, k : Coeffect, c : k} . (a × b) [c] -> a [c] × b [c] +pushPair [(x, y)] = ([x], [y]) + +pullPair : forall {a : Type, b : Type, k : Coeffect, c : k} . a [c] × b [c] -> (a × b) [c] +pullPair ([x], [y]) = [(x, y)] + +import Vec + +-- called `head` in the `Vec` library, but renamed here for example +safeHead : forall {a : Type, n : Nat} . (Vec (n+1) a) [0..1] -> a +safeHead [Cons x _] = x + +-- Stack example (see StdLib/Stack.gr) + +pop : forall {n : Nat, a : Type} . Vec (n+1) a -> (a, Vec n a) +pop = uncons + +push : forall {n : Nat, a : Type} . a -> Vec n a -> Vec (n+1) a +push = Cons + +peek : forall {n : Nat, a : Type} . (Vec (n+1) a) [1..2] -> (a, Vec (n+1) a) +peek [Cons x xs] = (x, Cons x xs) + +peek' : forall m : Ext Nat, a, n . Vec (n+1) (a [m..m+1]) -> (a, Vec (n+1) (a [m..m])) +peek' (Cons [x] xs) = (x, Cons [x] xs) + +-- Patient database example + +data Patient = Patient (String [Public]) (String [Private]) + +sampleCities : forall n k . N k -> (Vec (n+k) Patient) [0..1] -> Vec k (String [Public]) +sampleCities Z [_] = Nil; +sampleCities (S n) [Cons (Patient [city] [name]) ps] = Cons [city] (sampleCities n [ps]) + +-- getCitiesBad : forall n. Vec n (Patient [0..1]) -> Vec n (String [Public]) +-- getCitiesBad Nil = Nil; +-- getCitiesBad (Cons [Patient [city] [name]] ps) = Cons [name] (getCitiesBad ps) + +-- Session types example + +sendVec : forall n a . + (Chan (Send a End)) [n] + -> Vec n a -> () +sendVec [c] Nil = pure (); +sendVec [c] (Cons x xs) = + let c' <- send c x; + () <- close c' + in sendVec [c] xs + +recvVec : forall n a . + N n -> (Chan (Recv a End)) [n] -> (Vec n a) +recvVec Z [c] = pure Nil; +recvVec (S n) [c] = + let (x, c') <- recv c; + () <- close c'; + xs <- recvVec n [c] + in pure (Cons x xs) + +example : forall {n : Nat, a : Type} . N n -> Vec n a -> (Vec n a) +example n list = let c <- fork (\c -> sendVec c list) in recvVec n c diff --git a/examples/further-examples.gr.md b/examples/further-examples.gr.md new file mode 100644 index 000000000..48168a1f2 --- /dev/null +++ b/examples/further-examples.gr.md @@ -0,0 +1,215 @@ +This file is based on Section 8 of the ICFP 2019 paper _Quantitative program +reasoning with graded modal types_. +Please refer to the paper for the technical details and a formalisation of the +overall system. + +### Interaction with data structures + +Graded modalities can be commuted with other data types, for example +to pull information about consumption of sub-parts of data up to the +whole, or dually to push capabilities for consumption down to +sub-parts of a data type. Such notions are embodied by functions like +the following for commuting products with the exact-usage graded +modality: + +~~~ granule +pushPair : forall {a : Type, b : Type, k : Coeffect, c : k} . (a × b) [c] -> a [c] × b [c] +pushPair [(x, y)] = ([x], [y]) +~~~ + +~~~ granule +pullPair : forall {a : Type, b : Type, k : Coeffect, c : k} . a [c] × b [c] -> (a × b) [c] +pullPair ([x], [y]) = [(x, y)] +~~~ + +In practice, combinators such as `pushPair` and `pullPair` are rarely +used directly as we can instead use Granule's pattern matching +features over graded modalities, as in the derivation of +`pushPair`/`pullPair`. For example, for the safe head function on +vectors can be defined: + +~~~ granule +import Vec + +-- called `head` in the `Vec` library, but renamed here for example +safeHead : forall {a : Type, n : Nat} . (Vec (n+1) a) [0..1] -> a +safeHead [Cons x _] = x +~~~ + +The incoming vector has the capability to be consumed either `0` or +`1` times. By pattern matching, this capability is pushed down to the +sub-parts of the data such that every element can be used `0..1` +times, and every tail can be used `0..1` times. This is utilised in +the last pattern match where the tail of the list (and subsequently +all its elements) is discarded, as indicated by the wildcard pattern +inside of the unboxing pattern. + +The Granule +[standard library](https://github.com/granule-project/granule/tree/master/StdLib) +provides a variety of data structures including graphs, lists, stacks, +vectors. There are often different design decisions for the interaction +of data structures and graded modal types. For example, we represent +stacks with vectors with _pop_ and _push_ as dual linear operations +corresponding to cons and uncons: + +~~~ granule +pop : forall {n : Nat, a : Type} . Vec (n+1) a -> (a, Vec n a) +pop = uncons + +push : forall {n : Nat, a : Type} . a -> Vec n a -> Vec (n+1) a +push = Cons +~~~ + +The peek operation is more interesting as it is non-linear: we need to +use the head element twice: + +~~~ granule +peek : forall {n : Nat, a : Type} . (Vec (n+1) a) [1..2] -> (a, Vec (n+1) a) +peek [Cons x xs] = (x, Cons x xs) +~~~ + +This corresponds to a kind of implicit \emph{push}: we have the +capability to use every component of the stack once or twice. In the +case of the head element `x`, we use it twice, and in the case of the +rest of the stack `xs` we use it once. An alternate definition of +`peek` provides a linear interface for the stack structure, but with +non-linearity on the elements: + +~~~ granule +peek' : forall m : Ext Nat, a, n . Vec (n+1) (a [m..m+1]) -> (a, Vec (n+1) (a [m..m])) +peek' (Cons [x] xs) = (x, Cons [x] xs) +~~~ + +The type explains that we have a stack whose elements can be used +`m` to `m+1` times and we use this capability to copy +the head element returning a pair of the head and a stack whose +elements can now be used `m` to `m`. This type is +useful for chaining together operations which operate on the elements +of the stack non-linearly. The former `peek` definition is more +suited to situations where the whole stack is being manipulated +non-linearly, rather than just its elements. Exploring the design +space and trade-offs for data structure libraries is further work. + +### Grade interaction +To illustrate the interaction between different modalities, +consider a data type for storing patient +information of different privacy levels: + +~~~ granule +data Patient = Patient (String [Public]) (String [Private]) +~~~ + +where the first field gives the city for a patient (public information) and +the second field gives their name (private). We can +then define a function that, e.g., extracts a sample of cities +from a list of patients: + + +~~~ granule +import Vec -- Granule's standard vector library +sampleCities : forall n k . N k -> (Vec (n+k) Patient) [0..1] -> Vec k (String [Public]) +sampleCities Z [_] = Nil; +sampleCities (S n) [Cons (Patient [city] [name]) ps] = Cons [city] (sampleCities n [ps]) +~~~ + +Since we do not use all of the information in the vector, we declare +the input as affine using an `Interval Nat` modality with `0..1`. The +base case (`Nil`) is straightfoward. + +This demonstrates the use of different nested graded modalities. The +outer modality declares that the input vector is affine, since we do +not necessarily use all its elements, given by an `Interval Nat` +modality with `0..1`. The inner modalities provide the security +levels of patient information. In the inductive case, we thus get +`ps` graded by `0..1` and by flattening `city` and `name` are graded +by products `(0..1, Public)` and `(0..1, Private)` respectively. We +can safely collect the cities and output a list of public city names +in out database. + +~~~ grill +import Vec +data Patient = Patient (String [Public]) (String [Private]) +~~~ + +Let us see what happens when we try to accumulate the private name fields into a list +of public data: + +~~~ grill +getCitiesBad : forall n. Vec n (Patient [0..1]) -> Vec n (String [Public]) +getCitiesBad Nil = Nil; +getCitiesBad (Cons [Patient [city] [name]] ps) = Cons [name] (getCitiesBad ps) +~~~ +(`gr examples/further-examples.gr.md --literate-env-name grill`) + +The Granule checker gives the following type error, showing the +privacy violation: + + Grading error: 3:54: + Private value cannot be moved to level Public. + +### Session types + +Granule supports *session types* in the style of the GV calculus +leveraging linear types to embed session types primitives. When +combined with graded linearity, we can express novel communication +properties not supported by existing session type approaches. +Granule's builtin library provides channel primitives, where `Session` is +a trivial graded possibility modality for capturing communication +effects: + + +~~~ +data Protocol = Recv Type Protocol | Send Type Protocol | ... +send : forall { a : Type, s : Protocol } . Chan (Send a s) -> a -> (Chan s) +recv : forall { a : Type, s : Protocol } . Chan (Recv a s) -> (a, Chan s) +fork : forall { s : Protocol, k : Coeffect, c : k } . ((Chan s) [c] -> () ) + -> ((Chan (Dual s)) [c]) +~~~ + +where `Dual : Protocol -> Protocol` computes the dual of a protocol. + fork : forall { s : Protocol } . (Chan s -> Session ()) -> Session (Chan (Dual s)) + +Thus, `send` takes a channel on which an `a` can be +sent, returning a channel on which behaviour `s` can then +be carried out. Similarly, `recv` takes a channel +on which one can receive an `a` value, getting back (in a pair) +the continuation channel `Chan n`. The `fork` +primitive is higher-order, taking a function that uses a +channel in a way captured by some graded modality with grade +`c`, producing +a session computation. A channel with dual capabilities is returned, +that can also be used in a way captured by the grade `c`. + +We can use these primitives to capture precisely-bounded replication +in protocols: + +~~~ granule +sendVec : forall n a . (Chan (Send a End)) [n] -> Vec n a -> () +sendVec [c] Nil = pure (); +sendVec [c] (Cons x xs) = + let c' <- send c x; + () <- close c' + in sendVec [c] xs +~~~ + +~~~ granule +recvVec : forall n a . N n -> (Chan (Recv a End)) [n] -> (Vec n a) +recvVec Z [c] = pure Nil; +recvVec (S n) [c] = + let (x, c') <- recv c; + () <- close c'; + xs <- recvVec n [c] + in pure (Cons x xs) +~~~ + +On the left, `sendVec` has a channel which it can use exactly `n` +times to send values of type `a`, taking a vector and sending each +element on the channel. Dually, `recvVec` takes a size `n` and a +channel which it uses `n` times to receive values of `a`, collecting +the results into an output vector. We can then put these two processes +together using `fork`: + +~~~ granule +example : forall {n : Nat, a : Type} . N n -> Vec n a -> (Vec n a) +example n list = let c <- fork (\c -> sendVec c list) in recvVec n c +~~~ diff --git a/examples/intro.gr b/examples/intro.gr new file mode 100644 index 000000000..8141f25a7 --- /dev/null +++ b/examples/intro.gr @@ -0,0 +1,127 @@ +-- This is a stripped down version of `intro.md.gr` without all the explanation. +-- But this is useful for experimenting with in `grin`, e.g. + +-- $ grin +-- > :l exmaples/intro.gr + +-- Grin is a REPL a bit like ghci, so you can run code and inspect types, e.g. +-- > :t id +-- id : forall a : Type. a -> a +-- > not True +-- False + +-- Simple ADTs + +data Bool = False | True + +not : Bool -> Bool +not False = True; +not True = False + +-- Linear combinators + +id : forall {a : Type} . a -> a +id x = x + +flip : forall {a b c : Type} . (a -> b -> c) -> b -> a -> c +flip f y x = f x y + +-- Ill-typed non-linearity +-- drop : forall {a : Type} . a -> () +-- drop x = () + +-- copy : forall {a : Type} . a -> (a, a) +-- copy x = (x,x) + +-- File handles and side effects +firstChar : Char +firstChar = let + h <- openHandle ReadMode "examples/intro.gr.md"; + (h, c) <- readChar h; + () <- closeHandle h + in pure c + +-- forgetful : Char +-- forgetful = let +-- h <- openHandle ReadMode "examples/intro.gr.md"; +-- (h, c) <- readChar h +-- in pure c + +-- outOfOrder : Char +-- outOfOrder = let +-- h0 <- openHandle ReadMode "examples/intro.gr.md"; +-- () <- closeHandle h0; +-- (h1, c) <- readChar h0 +-- in pure c + +twoChars : (Char, Char) +twoChars = let + h <- openHandle ReadMode "examples/intro.gr.md"; + (h, c_1) <- readChar h; + (h, c_2) <- readChar h; + () <- closeHandle h + in pure (c_1, c_2) + +-- Non-linearity via modality +drop' : forall {a : Type}. a [] -> () +drop' [x] = () + +copy' : forall {a : Type}. a [] -> (a, a) +copy' [x] = (x, x) + +-- Precise non-linearity via grading +drop'' : forall {a : Type}. a [0] -> () +drop'' [x] = () + +copy'' : forall {a : Type}. a [2] -> (a, a) +copy'' [x] = (x, x) + +data Maybe a = None | Some a + +-- Interval grades +fromMaybe : forall {a : Type} . a [0..1] -> Maybe a -> a +fromMaybe [d] None = d; +fromMaybe [_] (Some x) = x + +-- Indexed types +data Vec (n : Nat) (a : Type) where + Nil : Vec 0 a; + Cons : a -> Vec n a -> Vec (n + 1) a + +data N (n : Nat) where + Z : N 0; + S : N n -> N (n + 1) + +append : forall {a : Type, m n : Nat} . Vec n a -> Vec m a -> Vec (n + m) a +append Nil ys = ys; +append (Cons x xs) ys = Cons x (append xs ys) + +length : forall {a : Type, n : Nat} . Vec n a -> (N n, Vec n a) +length Nil = (Z, Nil); +length (Cons x xs) = + let (n, xs) = length xs in (S n, Cons x xs) + +-- Combining indexing and grading +rep : forall {a : Type, n : Nat} . N n -> a [n] -> Vec n a +rep Z [c] = Nil; +rep (S n) [c] = Cons c (rep n [c]) + +sub : forall {m n : Nat} . {m >= n} => N m -> N n -> N (m - n) +sub m Z = m; +sub (S m') (S n') = sub m' n' + +leftPad : forall {t : Type, m n : Nat} . {m >= n} => N m -> Vec n t -> t [m - n] -> Vec m t +leftPad n str c = let (m, str) = length str in append (rep (sub n m) c) str + +-- Privacy levels +secret : Int [Private] +secret = [1234] + +hash : forall {l : Level} . Int [l] -> Int [l] +hash [x] = [x*x*x] + +good : Int [Private] +good = hash secret + +-- bad : Int [Public] +-- bad = hash secret diff --git a/examples/intro.gr.md b/examples/intro.gr.md new file mode 100644 index 000000000..25b66dc40 --- /dev/null +++ b/examples/intro.gr.md @@ -0,0 +1,667 @@ +A taste of Granule +================== + +This tutorial is based on Section 2 of the ICFP 2019 paper _Quantitative program +reasoning with graded modal types_ with additional complementary exercises. +Please refer to the paper for the technical details and a formalisation of the +overall system. + +Are you ready? +-------------- + +This tutorial assumes some familiarity with ML/Haskell. + +This Markdown document is a tutorial-style literate Granule program. Execute `gr +examples/intro.gr.md` on the command line to typecheck and run it (assuming that +you are in the granule source directory). Specify the function you want to run +with `--entry-point`. + +The illtyped definitions are in a code environments called **grillN** +(**gr**anule **ill**typed where *N* is some number), which you can +give to the checker by passing the option `--literate-env grillN`. We +number ill-typed blocks here so that the reader can focus on +particular typing errors as we go through the tutorial. + +Run `gr --help` to see various command line options. + +For help with installing `gr`, the Granule interpreter, please see the +[installation instructions](https://github.com/granule-project/granule#installation). + +See the [documentation](https://github.com/granule-project/granule#running-the-interpreter) +on how to use the interpreter. + +Please do open an [issue](https://github.com/granule-project/granule/issues) +if something doesn't work as expected. + + +Combinators +----------- + +Granule features a linear type system. This allows us to reason about +data in a resource-like manner. Linearity means that, by default, a +function must use each argument exactly once. What does "use" mean? +For concrete value constructors, we must **pattern match**. For +example, we can define the algebraic data type for booleans and give +the `not` function (which is linear) as: + +~~~ granule +data Bool = False | True + + +not : Bool -> Bool +not False = True; +not True = False +~~~ + +Granule syntax is inspired by Haskell, but note the single colon for +typing rather than double, and note that the function arrow -> denotes +linear functions now. + +For variables, linearity means we must either **return** them unchanged or +**pass them to a linear function**. If the variable is of a function type, then +**applying** that function is also a use. The following are two well-typed +examples, also showing polymorphism in Granule: + +~~~ granule +id : forall {a : Type} . a -> a +id x = x + + +flip : forall {a b c : Type} . (a -> b -> c) -> b -> a -> c +flip f y x = f x y +~~~ + +Polymorphic type variables are explicit, given with their kind. These +functions are both linear: they use their inputs exactly once. The +`id` function binds its argument to some variable `x` on the left, +which it simply returns on the right. The `flip` function switches +around the order in which some function `f` takes arguments `y` and +`x` (lhs). The argument function `f` gets applied exactly once to `x` +and `y` (rhs), which are use exactly once by the parameter function as +indicated by their types. + + + + +Next, let us look at what happens when we write nonlinear functions. + +~~~ grill1 +drop : forall {a : Type} . a -> () +drop x = () +~~~ +> Linearity error: Linear variable `x` is never used. + +~~~ grill1 +copy : forall {a : Type} . a -> (a, a) +copy x = (x,x) +~~~ +> Linearity error: Linear variable `x` is used more than once. + +(`gr examples/intro.gr.md --literate-env-name grill1`) + +As you can see from the error messages following both definitions, Granule's +type checker does not accept these definitions. + +Why would we want to enforce these restrictions? + +By universally quantifying over the type of the inputs ("`forall {a : Type}`"), +we are claiming that we can implement these functions generically for any type; +however some resource-like data may be subject to specific usage protocols. +Examples: + + - prohibit cross-thread aliasing to prevent race conditions + - close file handles exactly once and don't read from a closed handle + - use a session-typed channel exactly once + +If we want to reason about resources at the type level, we must renounce +*thoughtless* `drop`ping and `copy`ing. We will accommodate +non-linearity later using graded modalities. + +For now, we briefly think about why linearity on its own can be +useful. + +### Safer file handles + +Granule provides an interface to files, which includes the following +operations, given here in a slightly simplified form that elides the +type indexing by handle capabilities for reading, writing and +appending, since this is orthogonal to our present narrative. The +exact types can be found +[here](https://github.com/granule-project/granule/blob/330682a280b8fb04305b9ad07f0b4b706afe99d1/frontend/src/Language/Granule/Checker/Primitives.hs#L176). + +~~~ granule-interface +openHandle : IOMode -> String -> Handle + +readChar : Handle -> (Handle, Char) + +closeHandle : Handle -> () +~~~ + +The `openHandle` function +creates a handle, and its dual `closeHandle` destroys a handle. Linearity means +we can never *not* close a handle: we must use `closeHandle` to erase it. The +`readChar` function takes a readable handle and returns a pair of a readable +handle and a character. Logically, `readChar` can be thought of as consuming and +producing a handle, though at runtime this is backed by a single mutable data +structure. The `` type is a modality, written postfix, which captures I/O +side effects akin to Haskell's `IO` monad. We explain `` more later as it +approximates a more fine-grained graded modality. We now give two programs, +using Granule's notation for sequencing effectful computations akin to Haskell +`do` notation: of the form `let p_1 <- e_1; ...; p_n <- e_n in e`: + + +~~~ granule +firstChar : Char +firstChar = let + h <- openHandle ReadMode "examples/intro.gr.md"; + (h, c) <- readChar h; + () <- closeHandle h + in pure c +~~~ + +(`gr examples/intro.gr.md --entry-point firstChar`) + + +~~~ grill2 +forgetful : Char +forgetful = let + h <- openHandle ReadMode "examples/intro.gr.md"; + (h, c) <- readChar h + in pure c + + +outOfOrder : Char +outOfOrder = let + h0 <- openHandle ReadMode "examples/intro.gr.md"; + () <- closeHandle h0; + (h1, c) <- readChar h0 + in pure c +~~~ + +(`gr examples/intro.gr.md --literate-env-name grill2`) + +The paper also provides the example reading two characters: + +~~~ granule +twoChars : (Char, Char) +twoChars = let + h <- openHandle ReadMode "examples/intro.gr.md"; + (h, c_1) <- readChar h; + (h, c_2) <- readChar h; + () <- closeHandle h + in pure (c_1, c_2) +~~~ + +(`gr examples/intro.gr.md --entry-point twoChars`) + +There is also the ill-typed example which contains both +the mistakes of `forgetful` and `outOfOrder` together: + +~~~ grill3 +bad : Char +bad = let + h_1 <- openHandle ReadMode "somefile"; + h_2 <- openHandle ReadMode "another"; + () <- closeHandle h_1; + (h_1, c) <- readChar h_1 + in pure c +~~~ +(`gr examples/intro.gr.md --literate-env-name grill3`) + +### Reintroducing Nonlinearity + +The linear world is useful, but there are programs we want to write which are +fundamentally non-linear, such as `drop` and `copy`. Just like in Linear Logic, +Granule provides a type constructor for "requesting" nonlinearity. The typing +rules will enforce that the call site can actually provide this capability. This +type constructor is `[]`, written postfix. + +~~~ granule +drop' : forall {a : Type}. a [] -> () +drop' [x] = () + + +copy' : forall {a : Type}. a [] -> (a, a) +copy' [x] = (x, x) +~~~ + +The “box” constructor `[]` can be thought of as the equivalent of +linear logic's `!` exponential for unrestricted use. Our choice of syntax alludes +to necessity modality ("box") from modal logic. + +Since the parameters are now modal, of type `a []`, we can use an “unboxing” +pattern to bind a variable of `x` of type `a`, which can now be discarded or +copied freely in the bodies of the functions. + +Note that a value of type `a []` is itself still subject to linearity: it must +be used: + +~~~ grill4 +dropNot : forall {a : Type}. a [] -> () +dropNot xB = () +~~~ +> Linearity error: Linear variable `xB` is never used. + +(`gr examples/intro.gr.md --literate-env-name grill4`) + +Whilst this modality provides us with a non-linear binding for `x`, it however +gives a rather coarse-grained view: we cannot +distinguish the different forms of non-linearity employed by `copy'` and +`drop'`, which have the same type for their parameter. + +### Going graded + +To track fine-grained resource information, modalities in Granule are +*graded* by elements of a *resource algebra* whose +operations capture program structure. One built-in resource algebra +counts variable use via the natural numbers semiring. This enables +more precisely typed `copy` and `drop`: + +~~~ granule +drop'' : forall {a : Type}. a [0] -> () +drop'' [x] = () + + +copy'' : forall {a : Type}. a [2] -> (a, a) +copy'' [x] = (x, x) +~~~ + +The function definitions replay +`drop'` and `copy'`, but the types now +provide exact specifications of the amount of non-linearity: +`0` and `2`. +We will see various other graded modalities in due course. + +### Exercises + +Solutions are at the end of this file. + +#### 1.1 +Make the following functions typecheck by addition of graded modalities at the +type level only where needed and the relevant unboxing pattern matches at the +value level. Give the most precise type. + +~~~ grill +const : forall {a c : Type} . a -> (c -> a) +const x = \ctx -> x + + +ap : forall {a b c : Type}. (c -> a -> b) -> (c -> a) -> (c -> b) +ap f x = \ctx -> f ctx (x ctx) +~~~ + +#### 1.2 + +Consider the following definition: +~~~ granule +copyBool : Bool -> Bool × Bool +copyBool False = (False, False); +copyBool True = (True, True) +~~~ + +Why does `copyBool` not violate linearity? + +#### 1.3 + +Imagine you want to model a resource `Cake` which can be converted into +`Happiness` only via some linear function `eat`: + +~~~ granule +data Cake = ACake +data Happiness = SomeHappiness + +eat : Cake -> Happiness +eat ACake = SomeHappiness +~~~ + +How do we prevent greedy library clients from both `eat`ing and keeping their +`Cake`? + +Section 2 +--------- + +All the usual (Generalised) Algebraic Data Types from ML/Haskell work in Granule. +We saw a definition of `Bool` above; here we define `Maybe` (a.k.a. `option`): + +~~~ granule +data Maybe a = None | Some a +~~~ + + + +To safely unwrap a `Maybe a` value to an `a`, we need to provide a default value +in case we actually hold a `None` in our hands. + +~~~ grill5 +fromMaybe : forall {a : Type} . a -> Maybe a -> a +fromMaybe d None = d; +fromMaybe d (Some x) = x +~~~ +> Linearity error: Linear variable `d` is never used. +(`gr examples/intro.gr.md --literate-env-name grill5`) + +The equivalent of `fromMaybe` would be a valid Haskell or ML program, but Granule +rejects it and in fact this type is not inhabited in Granule. Since the `d`efault value +doesn't get used in the `None` case of the `Maybe a` parameter, we must wrap +it in a modality that witnesses/enables nonlinearity. However, we don't know +statically what it is supposed to be. For this Granule lets us declare a lower +and upper bound with an interval: + +~~~ granule +fromMaybe : forall {a : Type} . a [0..1] -> Maybe a -> a +fromMaybe [d] None = d; +fromMaybe [_] (Some x) = x +~~~ + +Intervals give us a fine-grained analysis, which is a feature that distinguishes +Granule from many other implementations of systems stemming from Linear Logic. + + +### Exercises + +#### 2.1 + +At my first attempt of writing `fromMaybe`, I copy-pasted the first line and +replaced `None` with `Some x`, but I forgot to change the right hand side: + +~~~ grill6 +data Maybe t = None | Some t + +fromMaybeNot : forall {a : Type} . a -> Maybe a -> a +fromMaybeNot d None = d; +fromMaybeNot d (Some x) = d +~~~ +(`gr examples/intro.gr.md --literate-env-name grill6`) + +Granule rejects this definition with a type error. Most compilers can emit a +warning for unused bindings, which would help track down the bug in this case. +Write a piece of code that subtly fails its specification where such a warning +would not help. Check whether Granule would point out the issue. + +#### 2.2 + +Consider the following program implementing logical ‘and’. + +~~~ granule +and : Bool -> Bool [0..1] -> Bool +and False [_] = False; +and True [q] = q +~~~ + +What is the technical term for the specific amount of nonlinearity denoted +by `[0..1]`? + +Indexed Types +------------- + + +Indexed types give us type-level access to further information about +data. Granule supports user-defined indexed types, in a similar style +to Haskell's GADTs. We use the well-known +example of size-indexed lists (`Vec`) to write a partially [verified implementation +of `leftPad`](https://github.com/hwayne/lets-prove-leftpad#readme). + +~~~ granule +data Vec (n : Nat) (a : Type) where + Nil : Vec 0 a; + Cons : a -> Vec n a -> Vec (n + 1) a + + +data N (n : Nat) where + Z : N 0; + S : N n -> N (n + 1) +~~~ + +Now we define some familiar list operations. + +~~~ granule +append : forall {a : Type, m n : Nat} . Vec n a -> Vec m a -> Vec (n + m) a +append Nil ys = ys; +append (Cons x xs) ys = Cons x (append xs ys) +~~~ + +Notice that the type is exactly the same as in a nonlinear language. +Indexed types give us the useful property that the length of the output list is +indeed the sum of the length of the inputs. But in a linear language this type +guarantees even more: *every element from the inputs must appear in the +output.* In a nonlinear +setting, the implementation of this type could drop and copy +values, as long as the output has the correct length. + +Polymorphism is important when reasoning about linearity: when we +can pattern match on the concrete values, then we consume them. In `append` we +cannot pattern match on the exact value of the elements of the list because of +their polymorphic type, hence the only thing we can do is to return it. + +The most straightforward way to get the length of a list linearly is to +destruct the list until we reach the base case `Nil` and then reconstruct it as +we keep incrementing our `N`. + +~~~ granule +length : forall {a : Type, n : Nat} . Vec n a -> (N n, Vec n a) +length Nil = (Z, Nil); +length (Cons x xs) = + let (n, xs) = length xs in (S n, Cons x xs) +~~~ + + + +Next we define a function `rep` to produce a list of a desired length by +replicating a given element: + +~~~ granule +rep : forall {a : Type, n : Nat} . N n -> a [n] -> Vec n a +rep Z [c] = Nil; +rep (S n) [c] = Cons c (rep n [c]) +~~~ + +Note that grades can depend on variables! + +Now we define subtraction on our indexed naturals: + +~~~ granule +sub : forall {m n : Nat} . {m >= n} => N m -> N n -> N (m - n) +sub m Z = m; +sub (S m') (S n') = sub m' n' +~~~ + +Granule lets us give preconditions in the context of type schemes (before `=>`). +These must hold where the function is used. Such predicates are discharged by +the external solver. + +Finally, we can put the above functions together and define our left pad +function: + +~~~ granule +leftPad : forall {t : Type, m n : Nat} . {m >= n} => N m -> Vec n t -> t [m - n] -> Vec m t +leftPad n str c = let (m, str) = length str in append (rep (sub n m) c) str +~~~ + + +The type says that given a target length `m` and an input list with a +lesser or equal length `n`, we consume some padding element of type +`a` exactly `m - n` times to produce an output list of the target +length `m`. In Granule this type alone implies the correct implementation—modulo reorderings and nontermination—via: + +- *Parametric polymorphism*: ensuring that the implementation cannot depend +on the concrete padding items provided or the items of the input list (hence we +use lists instead of strings); +- *Indexed types*: ensuring the correct size and explaining the exact +usage of the padding element; +- *Graded linearity*: ensuring that every item in the input list appears +exactly once in the output. The type `[m - n]` of the padding element +reveals its exact usage. + + +The type of `leftPad` in Granule is superficially similar to what we could +write in GHC Haskell or a fully dependently-typed language, except for the +nonlinearity of the padding element, a minor syntactic addition. However the +extra guarantees we get in a graded linear system like Granule's means we get +properties for free which we would otherwise have to prove ourselves. + +### Exercises + +#### 3.1 + +Consider the following type signature: + +~~~ granule-interface +id_Vec : Vec n a -> Vec n a +~~~ + +A function of this type need not necessarily be the identity function on lists. +Why? Which structural rule could help us to reason about this? + + +Other graded modalities +----------------------- + +In the file handles example we swept past the `` type +constructor. +This is an example of an effect-capturing +modality (the “diamond” constructor alludes to modal possibility), in the +spirit of Haskell's `IO` monad. However, Granule provides +*graded monads*, which can give a +more fine-grained account of effects. +`firstChar : Char <{Open, Read, IOExcept, Close}>` +which tells us its range of possible side effects via a set of labels, and notably +that there are no `Write` effects. Thus, Granule provides +graded modalities in two flavours: graded necessity/comonads for +coeffects (properties of input variables) and graded possibility/monads +for effects (properties of output computations). + +A further graded modality that we have not seen yet provides +a notion of *information-flow security* via a lattice-indexed +graded necessity with labels `Public` and `Private`. +We can then, for example, define programs like the following which +capture the security level of values, and how levels are preserved +(or not) by functions: + + +~~~ granule +secret : Int [Private] +secret = [1234] +~~~ + +~~~ grill7 +leak : Int [Public] +leak = hash secret +~~~ +(`gr examples/intro.gr.md --literate-env-name grill7`) + +~~~ granule +hash : forall {l : Level} . Int [l] -> Int [l] +hash [x] = [x*x*x] +~~~ + +~~~ granule +good : Int [Private] +good = hash secret +~~~ + + + +The End... For Now! +------------------- + +There is another file, `further-examples.gr.md` if you are hungry for more. + +Solutions +--------- + +#### 1.1 + +~~~ granule +const : forall {a c : Type} . a -> (c [0] -> a) +const x = \[ctx] -> x +~~~ +Or equivalently: +~~~ granule +const' : forall {a c : Type} . a -> (c [0] -> a) +const' x [ctx] = x +~~~ + +~~~ granule +ap : forall {a b c : Type} . (c -> a -> b) -> (c -> a) -> (c [2] -> b) +ap f x = \[ctx] -> f ctx (x ctx) +~~~ +Or equivalently: +~~~ granule +ap' : forall {a b c : Type} . (c -> a -> b) -> (c -> a) -> (c [2] -> b) +ap' f x [ctx] = f ctx (x ctx) +~~~ + +#### 1.2 + +> Why does `copyBool` not violate linearity? + +Because in all cases we are pattern matching on concrete values on the left hand +side. On the right we are simply returning closed terms, which we are able to do +because the definition of `Bool` is in scope. + + +#### 1.3 + +> How do we prevent library clients from both `eat`ing and keeping their `Cake`? + +We need to make `Cake` and `Happiness` abstract data types by hiding their +definitions and only export `eat`, as well as some restricted means of obtaining +a `Cake` in the first place. This prevents clients from implementing something like the following: + +~~~ granule +copyCake : Cake -> Cake × Cake +copyCake ACake = (ACake, ACake) + +eatAndKeep : Cake -> (Cake × Happiness) +eatAndKeep c = let (c1, c2) = copyCake c in (c1, eat c2) +~~~ + +Caveat: Granule doesn't yet have a means of selectively exporting definitions, +nor of enforcing linear usage of top-level definitions. + +#### 2.1 + +One example: +~~~ grill8 +--- Given two integers x and y, returns their sum and product resp. +foo : Int [2] -> Int [2] -> (Int, Int) +foo [x] [y] = (x + y, x * x) +~~~ +> Grading error: `1` is not approximatable by `2` for type `Nat` because `Nat` denotes precise usage. +(`gr examples/intro.gr.md --literate-env-name grill8`) + +Generally unused binding warnings will only trigger when a variable is not used +at all. + +#### 2.2 + +> What is the technical term for the specific amount of nonlinearity denoted +by `[0..1]`? + +_Affinity_, hence we say `and` is _affine_ in its second parameter. `[1..∞]` +denotes _relevance_. Intervals generalise this by allowing any lower and upper +bound for usage. + +#### 3.1 + +> A function of this type need not necessarily be the identity function on lists. +Why? + +Because the function could be reordering elements, e.g. reversing the list. + +> Which structural rule could help us to reason about this? + +_Exchange_, which controls the order in which term-level variables can be used. diff --git a/examples/lambda-gadt.gr b/examples/lambda-gadt.gr index 42c42b048..fca081de7 100644 --- a/examples/lambda-gadt.gr +++ b/examples/lambda-gadt.gr @@ -1,9 +1,11 @@ +-- gr --no-eval + data Lam : Type → Type where - Lift : ∀ a : Type . a → Lam a; --- lifted value - Pair : ∀ a : Type, b : Type . a → b → Lam (a,b); --- product - Lam : ∀ a : Type, b : Type . (a → b) → Lam (a → b); --- lambda abstraction + Lift : ∀ a : Type . a → Lam a; --- lifted value + Pair : ∀ a : Type, b : Type . Lam a → Lam b → Lam (a,b); --- product + Lam : ∀ a : Type, b : Type . (Lam a → Lam b) → Lam (a → b); --- lambda abstraction App : ∀ a : Type, b : Type . Lam (a → b) → Lam a → Lam b; --- beta reduction - Fix : ∀ a : Type . (Lam (a → a)) [∞] → Lam a --- fixed point + Fix : ∀ a : Type . (Lam (a → a)) [∞] → Lam a --- fixed point eval : ∀ a : Type . Lam a → a eval e = case e of diff --git a/examples/nonlinear.gr b/examples/nonlinear.gr new file mode 100644 index 000000000..f6dd21c27 --- /dev/null +++ b/examples/nonlinear.gr @@ -0,0 +1,2 @@ +copy : ∀ {a : Type, n : Nat} . a [n+1] -> a × a [n] +copy [x] = (x, [x]) \ No newline at end of file diff --git a/examples/pad_left.gr b/examples/pad_left.gr new file mode 100644 index 000000000..3ddf0cd64 --- /dev/null +++ b/examples/pad_left.gr @@ -0,0 +1,15 @@ +import Vec + +pad_left + : ∀ {a : Type, m : Nat, n : Nat} + . a [n - m] + → N n + → Vec m a + → Vec (m ∨ n) a +pad_left [c] n str = let + (m, str) = length' str + in append (replicate (monus n m) [c]) str + +main : Vec 5 Char +main = let five = (S (S (S (S (S Z))))) in + pad_left [' '] five (Cons 'a' (Cons 'b' (Cons 'c' Nil))) diff --git a/examples/pad_left.gr.output b/examples/pad_left.gr.output new file mode 100644 index 000000000..0e3b6dd81 --- /dev/null +++ b/examples/pad_left.gr.output @@ -0,0 +1 @@ +Cons ' ' (Cons ' ' (Cons 'a' (Cons 'b' (Cons 'c' Nil)))) \ No newline at end of file diff --git a/examples/stream.gr b/examples/stream.gr index 93ddc2008..83221cb92 100644 --- a/examples/stream.gr +++ b/examples/stream.gr @@ -3,14 +3,11 @@ import Vec data Stream a where Next : a → (() → Stream a) [0..1] → Stream a -delay : ∀ a : Type . a → (() → a) -delay x = λ() → x - force : ∀ a : Type . (() → a) → a force t = t () repeat : ∀ a : Type . a [1..∞] → Stream a -repeat [x] = Next x [delay (repeat [x])] +repeat [x] = Next x [λ() → (repeat [x])] takeS : ∀ a : Type, p : Nat . N p → Stream a → Vec p a takeS (S Z) (Next hd [_]) = Cons hd Nil; @@ -24,8 +21,8 @@ cycleInner . (Vec (m+1) a) [0..∞] → (Vec (n+1) a) [0..1] → Stream a -cycleInner [again] [Cons x Nil] = Next x [delay (cycleInner [again] [again])]; -cycleInner [again] [Cons x xs] = Next x [delay (cycleInner [again] [xs])] +cycleInner [again] [Cons x Nil] = Next x [λ() → (cycleInner [again] [again])]; +cycleInner [again] [Cons x xs] = Next x [λ() → (cycleInner [again] [xs])] main : Vec 7 Int main = takeS (S (S (S (S (S (S (S Z))))))) (cycle [Cons 1 (Cons 2 (Cons 3 Nil))]) diff --git a/examples/stream.gr.output b/examples/stream.gr.output new file mode 100644 index 000000000..6ac944a3b --- /dev/null +++ b/examples/stream.gr.output @@ -0,0 +1 @@ +Cons 1 (Cons 2 (Cons 3 (Cons 1 (Cons 2 (Cons 3 (Cons 1 Nil)))))) \ No newline at end of file diff --git a/frontend/package.yaml b/frontend/package.yaml index a7770dcc4..66e987029 100644 --- a/frontend/package.yaml +++ b/frontend/package.yaml @@ -1,5 +1,5 @@ name: granule-frontend -version: '0.7.2.0' +version: '0.7.3.0' synopsis: The Granule abstract-syntax-tree, parser and type checker libraries author: Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Preston Keel copyright: 2018 authors @@ -8,18 +8,27 @@ github: granule-project/granule dependencies: - base >=4.10 && <5 +ghc-options: +- -O0 +- -Wall +- -Werror +- -Wcompat +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wredundant-constraints +- -Wno-unused-matches +- -Wno-name-shadowing +- -Wno-type-defaults + +default-extensions: +- ImplicitParams +- ViewPatterns +- LambdaCase +- TupleSections +- NamedFieldPuns + library: source-dirs: src - ghc-options: -O0 -W -Werror -Wno-unused-matches - # ghc-options: > - # -O0 - # -Wall - # -Werror - # -Wcompat - # -Wincomplete-record-updates - # -Wincomplete-uni-patterns - # -Wredundant-constraints - # when: # - condition: flag(dev) # then: @@ -41,7 +50,8 @@ library: - Language.Granule.Checker.Patterns - Language.Granule.Checker.Predicates - Language.Granule.Checker.Primitives - - Language.Granule.Checker.Substitutions + - Language.Granule.Checker.SubstitutionContexts + - Language.Granule.Checker.Substitution - Language.Granule.Checker.Types - Language.Granule.Syntax.Def - Language.Granule.Syntax.Expr @@ -80,8 +90,8 @@ tests: source-dirs: tests/hspec ghc-options: -fno-warn-partial-type-signatures dependencies: - - filemanip - - directory + # - filemanip + # - directory - granule-frontend - hspec - QuickCheck diff --git a/frontend/src/Data/Bifunctor/Foldable.hs b/frontend/src/Data/Bifunctor/Foldable.hs index 8abaf7276..2f710472f 100644 --- a/frontend/src/Data/Bifunctor/Foldable.hs +++ b/frontend/src/Data/Bifunctor/Foldable.hs @@ -38,11 +38,10 @@ instance Eq (f (Fix2 f g) (Fix2 g f)) => Eq (Fix2 f g) where class (Bifunctor (Base t q)) => Birecursive t q | t -> q where project :: t -> (Base t q) t q -instance (Bifunctor f, Bifunctor g) => Birecursive (Fix2 f g) (Fix2 g f) where +instance (Bifunctor f) => Birecursive (Fix2 f g) (Fix2 g f) where project = unFix bicata :: (Birecursive x z, Birecursive z x) - => (Bifunctor (Base x z), Bifunctor (Base z x)) => ((Base x z) a b -> a) -> ((Base z x) b a -> b) -> x @@ -53,7 +52,6 @@ bicata falg galg = gcata = galg . (bimap gcata fcata) . project bicataP :: (Birecursive x z, Birecursive z x) - => (Bifunctor (Base x z), Bifunctor (Base z x)) => ((p -> (Base x z) a b -> a), x -> p -> p) -> ((p -> (Base z x) b a -> b), z -> p -> p) -> p @@ -98,7 +96,6 @@ bicataPM (falgPM, ftop) (galgPM, gtop) = in (bimapM (gcataPM p') (fcataPM p') $ project fp) >>= galgPM p' bipara :: (Birecursive x z, Birecursive z x) - => (Bifunctor (Base x z), Bifunctor (Base z x)) => ((Base x z) (x, a) (z, b) -> a) -> ((Base z x) (z, b) (x, a) -> b) -> x @@ -110,13 +107,10 @@ bipara falg galg = gpara = galg . (bimap ((,) <*> gpara) ((,) <*> fpara)) . project --- Is there a magic operator to get this like (,) <*> above? -applyLeft f x = do - fx <- f x - return (x, fx) +applyLeft :: Functor f => (a -> f b) -> a -> f (a, b) +applyLeft f x = (,) x <$> f x biparaP :: (Birecursive x z, Birecursive z x) - => (Bifunctor (Base x z), Bifunctor (Base z x)) => ((p -> (Base x z) (x, a) (z, b) -> a), x -> p -> p) -> ((p -> (Base z x) (z, b) (x, a) -> b), z -> p -> p) -> p diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs index 628106342..4d7d6b46c 100644 --- a/frontend/src/Language/Granule/Checker/Checker.hs +++ b/frontend/src/Language/Granule/Checker/Checker.hs @@ -10,23 +10,27 @@ module Language.Granule.Checker.Checker where import Control.Monad (unless) import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import Data.List (genericLength, intercalate) +import Control.Monad.Except (throwError) +import Data.List (genericLength) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty (toList) import Data.Maybe import qualified Data.Text as T import Language.Granule.Checker.Constraints.Compile -import Language.Granule.Checker.Errors import Language.Granule.Checker.Coeffects import Language.Granule.Checker.Constraints import Language.Granule.Checker.Kinds +import Language.Granule.Checker.KindsImplicit import Language.Granule.Checker.Exhaustivity import Language.Granule.Checker.Monad +import Language.Granule.Checker.NameClash import Language.Granule.Checker.Patterns import Language.Granule.Checker.Predicates import qualified Language.Granule.Checker.Primitives as Primitives import Language.Granule.Checker.Simplifier -import Language.Granule.Checker.Substitutions +import Language.Granule.Checker.SubstitutionContexts +import Language.Granule.Checker.Substitution import Language.Granule.Checker.Types import Language.Granule.Checker.Variables import Language.Granule.Context @@ -44,26 +48,25 @@ import Language.Granule.Utils --import Debug.Trace -- Checking (top-level) -check :: (?globals :: Globals) => AST () () -> IO (Maybe (AST () Type)) -check (AST dataDecls defs) = evalChecker initState $ do - rs1 <- mapM (runMaybeT . checkTyCon) dataDecls - rs2 <- mapM (runMaybeT . checkDataCons) dataDecls - rs3 <- mapM (runMaybeT . kindCheckDef) defs - rs4 <- mapM (runMaybeT . (checkDef defCtxt)) defs - - return $ - if all isJust (rs1 <> rs2 <> rs3 <> (map (fmap (const ())) rs4)) - then Just (AST dataDecls (catMaybes rs4)) - else Nothing - where - defCtxt = map (\(Def _ name _ tys) -> (name, tys)) defs - -checkTyCon :: (?globals :: Globals) => DataDecl -> MaybeT Checker () -checkTyCon (DataDecl sp name tyVars kindAnn ds) = do - clash <- isJust . lookup name <$> gets typeConstructors - if clash - then halt $ NameClashError (Just sp) $ "Type constructor `" <> pretty name <> "` already defined." - else modify' $ \st -> +check :: (?globals :: Globals) + => AST () () + -> IO (Either (NonEmpty CheckerError) (AST () Type)) +check ast@(AST dataDecls defs imports) = evalChecker initState $ do + _ <- checkNameClashes ast + _ <- runAll checkTyCon dataDecls + _ <- runAll checkDataCons dataDecls + defs <- runAll kindCheckDef defs + let defCtxt = map (\(Def _ name _ tys) -> (name, tys)) defs + defs <- runAll (checkDef defCtxt) defs + pure $ AST dataDecls defs imports + +-- TODO: we are checking for name clashes again here. Where is the best place +-- to do this check? +checkTyCon :: DataDecl -> Checker () +checkTyCon (DataDecl sp name tyVars kindAnn ds) + = lookup name <$> gets typeConstructors >>= \case + Just _ -> throw TypeConstructorNameClash{ errLoc = sp, errId = name } + Nothing -> modify' $ \st -> st{ typeConstructors = (name, (tyConKind, cardin)) : typeConstructors st } where cardin = (Just . genericLength) ds -- the number of data constructors @@ -71,11 +74,12 @@ checkTyCon (DataDecl sp name tyVars kindAnn ds) = do mkKind [] = case kindAnn of Just k -> k; Nothing -> KType -- default to `Type` mkKind (v:vs) = KFun v (mkKind vs) -checkDataCons :: (?globals :: Globals) => DataDecl -> MaybeT Checker () -checkDataCons (DataDecl _ name tyVars _ dataConstrs) = - do +checkDataCons :: (?globals :: Globals) => DataDecl -> Checker () +checkDataCons (DataDecl sp name tyVars k dataConstrs) = do st <- get - let Just (kind,_) = lookup name (typeConstructors st) -- can't fail, tyCon must be in checker state + let kind = case lookup name (typeConstructors st) of + Just (kind,_) -> kind + Nothing -> error $ "Internal error. Trying to lookup data constructor " <> pretty name modify' $ \st -> st { tyVarContext = [(v, (k, ForallQ)) | (v, k) <- tyVars] } mapM_ (checkDataCon name kind tyVars) dataConstrs @@ -84,9 +88,13 @@ checkDataCon :: (?globals :: Globals) -> Kind -- ^ The kind of the type constructor -> Ctxt Kind -- ^ The type variables -> DataConstr -- ^ The data constructor to check - -> MaybeT Checker () -- ^ Return @Just ()@ on success, @Nothing@ on failure -checkDataCon tName kind tyVarsT (DataConstrIndexed sp dName tySch@(Forall _ tyVarsD constraints ty)) = - case intersectCtxts tyVarsT tyVarsD of + -> Checker () -- ^ Return @Just ()@ on success, @Nothing@ on failure +checkDataCon + tName + kind + tyVarsT + d@(DataConstrIndexed sp dName tySch@(Forall s tyVarsD constraints ty)) = do + case map fst $ intersectCtxts tyVarsT tyVarsD of [] -> do -- no clashes -- Only relevant type variables get included @@ -94,49 +102,117 @@ checkDataCon tName kind tyVarsT (DataConstrIndexed sp dName tySch@(Forall _ tyVa let tyVars_justD = relevantSubCtxt (freeVars ty) tyVarsD -- Add the type variables from the data constructor into the environment - modify $ \st -> st { tyVarContext = [(v, (k, ForallQ)) | (v, k) <- tyVars_justD] ++ tyVarContext st } - tySchKind <- inferKindOfType' sp tyVars ty + modify $ \st -> st { tyVarContext = + [(v, (k, ForallQ)) | (v, k) <- tyVars_justD] ++ tyVarContext st } + tySchKind <- inferKindOfTypeInContext sp tyVars ty + + -- Freshen the data type constructors type + (ty, tyVarsFreshD, _, constraints, []) <- + freshPolymorphicInstance ForallQ False (Forall s tyVars constraints ty) [] + + -- Create a version of the data constructor that matches the data type head + -- but with a list of coercions + + (ty', coercions, tyVarsNewAndOld) <- checkAndGenerateSubstitution sp tName ty (indexKinds kind) + + -- Reconstruct the data constructor's new type scheme + let tyVarsD' = tyVarsFreshD <> tyVarsNewAndOld + let tySch = Forall sp tyVarsD' constraints ty' case tySchKind of - KType -> do - check ty - st <- get - case extend (dataConstructors st) dName (Forall sp tyVars constraints ty) of - Some ds -> do - put st { dataConstructors = ds } - None _ -> halt $ NameClashError (Just sp) $ "Data constructor `" <> pretty dName <> "` already defined." - KPromote (TyCon k) | internalName k == "Protocol" -> do - check ty - st <- get - case extend (dataConstructors st) dName (Forall sp tyVars constraints ty) of - Some ds -> put st { dataConstructors = ds } - None _ -> halt $ NameClashError (Just sp) $ "Data constructor `" <> pretty dName <> "` already defined." - - _ -> illKindedNEq sp KType kind - vs -> halt $ NameClashError (Just sp) $ mconcat - ["Type variable(s) ", intercalate ", " $ map (\(i,_) -> "`" <> pretty i <> "`") vs - ," in data constructor `", pretty dName - ,"` are already bound by the associated type constructor `", pretty tName - , "`. Choose different, unbound names."] + KType -> + registerDataConstructor tySch coercions + + KPromote (TyCon k) | internalName k == "Protocol" -> + registerDataConstructor tySch coercions + + _ -> throw KindMismatch{ errLoc = sp, kExpected = KType, kActual = kind } + + (v:vs) -> (throwError . fmap mkTyVarNameClashErr) (v:|vs) where - check (TyCon tC) = - if tC == tName - then return () - else halt $ GenericError (Just sp) $ "Expected type constructor `" <> pretty tName - <> "`, but got `" <> pretty tC <> "` in `" - check (FunTy arg res) = check res - check (TyApp fun arg) = check fun - check x = halt $ GenericError (Just sp) $ "`" <> pretty x <> "` not valid in a datatype definition." + indexKinds (KFun k1 k2) = k1 : indexKinds k2 + indexKinds k = [] + + registerDataConstructor dataConstrTy subst = do + st <- get + case extend (dataConstructors st) dName (dataConstrTy, subst) of + Just ds -> put st { dataConstructors = ds, tyVarContext = [] } + Nothing -> throw DataConstructorNameClashError{ errLoc = sp, errId = dName } + + mkTyVarNameClashErr v = DataConstructorTypeVariableNameClash + { errLoc = sp + , errDataConstructorId = dName + , errTypeConstructor = tName + , errVar = v + } checkDataCon tName kind tyVars d@DataConstrNonIndexed{} = checkDataCon tName kind tyVars $ nonIndexedToIndexedDataConstr tName tyVars d + +{- + Checks whether the type constructor name matches the return constraint + of the data constructor + and at the same time generate coercions for every parameter of result type type constructor + then generate fresh variables for parameter and coercions that are either trivial + variable ones or to concrete types + + e.g. + checkAndGenerateSubstitution Maybe (a' -> Maybe a') [Type] + > (a' -> Maybe a, [a |-> a'], [a : Type]) + + checkAndGenerateSubstitution Other (a' -> Maybe a') [Type] + > *** fails + + checkAndGenerateSubstitution Vec (Vec 0 t') [Nat, Type] + > (Vec n t', [n |-> Subst 0, t |-> t'], [n : Type, ]) + + checkAndGenerateSubstitution Vec (t' -> Vec n' t' -> Vec (n'+1) t') [Nat, Type] + > (t' -> Vec n' t' -> Vec n t, [n |-> Subst (n'+1), t |-> t'], []) + + checkAndGenerateSubstitution Foo (Int -> Foo Int) [Type] + > (Int -> Foo t1, [t1 |-> Subst Int], [t1 : Type]) + +-} + +checkAndGenerateSubstitution :: + Span -- ^ Location of this application + -> Id -- ^ Name of the type constructor + -> Type -- ^ Type of the data constructor + -> [Kind] -- ^ Types of the remaining data type indices + -> Checker (Type, Substitution, Ctxt Kind) +checkAndGenerateSubstitution sp tName ty ixkinds = + checkAndGenerateSubstitution' sp tName ty (reverse ixkinds) + where + checkAndGenerateSubstitution' sp tName (TyCon tC) [] + | tC == tName = return (TyCon tC, [], []) + | otherwise = throw UnexpectedTypeConstructor + { errLoc = sp, tyConActual = tC, tyConExpected = tName } + + checkAndGenerateSubstitution' sp tName (FunTy arg res) kinds = do + (res', subst, tyVarsNew) <- checkAndGenerateSubstitution' sp tName res kinds + return (FunTy arg res', subst, tyVarsNew) + + checkAndGenerateSubstitution' sp tName (TyApp fun arg) (kind:kinds) = do + varSymb <- freshIdentifierBase "t" + let var = mkId varSymb + (fun', subst, tyVarsNew) <- checkAndGenerateSubstitution' sp tName fun kinds + return (TyApp fun' (TyVar var), (var, SubstT arg) : subst, (var, kind) : tyVarsNew) + + checkAndGenerateSubstitution' sp _ t _ = + throw InvalidTypeDefinition { errLoc = sp, errTy = t } + checkDef :: (?globals :: Globals) => Ctxt TypeScheme -- context of top-level definitions -> Def () () -- definition - -> MaybeT Checker (Def () Type) -checkDef defCtxt (Def s defName equations tys@(Forall _ foralls constraints ty)) = do + -> Checker (Def () Type) +checkDef defCtxt (Def s defName equations tys@(Forall s_t foralls constraints ty)) = do + + -- duplicate forall bindings + case duplicates (map (sourceName . fst) foralls) of + [] -> pure () + (d:ds) -> throwError $ fmap (DuplicateBindingError s_t) (d :| ds) -- Clean up knowledge shared between equations of a definition modify (\st -> st { guardPredicates = [[]] @@ -147,7 +223,6 @@ checkDef defCtxt (Def s defName equations tys@(Forall _ foralls constraints ty)) modify' $ \st -> st { predicateStack = [] , tyVarContext = [] - , kVarContext = [] , guardContexts = [] } elaboratedEq <- checkEquation defCtxt defName equation tys @@ -169,7 +244,7 @@ checkEquation :: (?globals :: Globals) => -> Id -- Name of the definition -> Equation () () -- Equation -> TypeScheme -- Type scheme - -> MaybeT Checker (Equation () Type) + -> Checker (Equation () Type) checkEquation defCtxt _ (Equation s () pats expr) tys@(Forall _ foralls constraints ty) = do -- Check that the lhs doesn't introduce any duplicate binders @@ -198,7 +273,11 @@ checkEquation defCtxt _ (Equation s () pats expr) tys@(Forall _ foralls constrai newConjunct -- Specialise the return type by the pattern generated substitution + debugM "eqn" $ "### -- patternGam = " <> show patternGam + debugM "eqn" $ "### -- localVars = " <> show localVars + debugM "eqn" $ "### -- tau = " <> show tau tau' <- substitute subst tau + debugM "eqn" $ "### -- tau' = " <> show tau' -- Check the body (localGam, subst', elaboratedExpr) <- @@ -206,6 +285,8 @@ checkEquation defCtxt _ (Equation s () pats expr) tys@(Forall _ foralls constrai case checkLinearity patternGam localGam of [] -> do + localGam <- substitute subst localGam + -- Check that our consumption context approximations the binding ctxtApprox s localGam patternGam @@ -220,12 +301,10 @@ checkEquation defCtxt _ (Equation s () pats expr) tys@(Forall _ foralls constrai return elab' -- Anything that was bound in the pattern but not used up - xs -> illLinearityMismatch s xs - + (p:ps) -> illLinearityMismatch s (p:|ps) data Polarity = Positive | Negative deriving Show - flipPol :: Polarity -> Polarity flipPol Positive = Negative flipPol Negative = Positive @@ -245,10 +324,9 @@ checkExpr :: (?globals :: Globals) -> Bool -- whether we are top-level or not -> Type -- type -> Expr () () -- expression - -> MaybeT Checker (Ctxt Assumption, Substitution, Expr () Type) + -> Checker (Ctxt Assumption, Substitution, Expr () Type) -- Checking of constants - checkExpr _ [] _ _ ty@(TyCon c) (Val s _ (NumInt n)) | internalName c == "Int" = do let elaborated = Val s ty (NumInt n) return ([], [], elaborated) @@ -265,32 +343,38 @@ checkExpr defs gam pol _ ty@(FunTy sig tau) (Val s _ (Abs _ p t e)) = do Nothing -> return (tau, []) Just t' -> do (eqT, unifiedType, subst) <- equalTypes s sig t' - unless eqT (halt $ GenericError (Just s) $ pretty sig <> " not equal to " <> pretty t') + unless eqT $ throw TypeError{ errLoc = s, tyExpected = sig, tyActual = t' } return (tau, subst) - (bindings, _, subst, elaboratedP, _) <- ctxtFromTypedPattern s sig p NotFull + newConjunct + + (bindings, localVars, subst, elaboratedP, _) <- ctxtFromTypedPattern s sig p NotFull debugM "binding from lam" $ pretty bindings pIrrefutable <- isIrrefutable s sig p if pIrrefutable then do -- Check the body in the extended context - (gam', subst2, elaboratedE) <- checkExpr defs (bindings <> gam) pol False tau' e + tau'' <- substitute subst tau' + + newConjunct + + (gam', subst2, elaboratedE) <- checkExpr defs (bindings <> gam) pol False tau'' e -- Check linearity of locally bound variables case checkLinearity bindings gam' of [] -> do subst <- combineSubstitutions s subst1 subst2 -- Locally we should have this property (as we are under a binder) - ctxtEquals s (gam' `intersectCtxts` bindings) bindings + ctxtApprox s (gam' `intersectCtxts` bindings) bindings - let elaborated = Val s ty (Abs ty elaboratedP t elaboratedE) - return (gam' `subtractCtxt` bindings, subst, elaborated) - - xs -> illLinearityMismatch s xs - else refutablePattern s p + concludeImplication s localVars + let elaborated = Val s ty (Abs ty elaboratedP t elaboratedE) + return (gam' `subtractCtxt` bindings, subst, elaborated) + (p:ps) -> illLinearityMismatch s (p:|ps) + else throw RefutablePatternError{ errLoc = s, errPat = p } -- Application special case for built-in 'scale' -- TODO: needs more thought @@ -302,12 +386,14 @@ checkExpr defs gam pol _ ty@(FunTy sig tau) (Val s _ (Abs _ p t e)) = do -- Application checking checkExpr defs gam pol topLevel tau (App s _ e1 e2) = do + (argTy, gam2, subst2, elaboratedR) <- synthExpr defs gam pol e2 + + funTy <- substitute subst2 (FunTy argTy tau) + (gam1, subst1, elaboratedL) <- checkExpr defs gam (flipPol pol) topLevel funTy e1 - (argTy, gam2, subst', elaboratedR) <- synthExpr defs gam pol e2 - (gam1, subst, elaboratedL) <- checkExpr defs gam (flipPol pol) topLevel (FunTy argTy tau) e1 gam <- ctxtPlus s gam1 gam2 - subst <- combineSubstitutions s subst' subst + subst <- combineSubstitutions s subst1 subst2 let elaborated = App s tau elaboratedL elaboratedR return (gam, subst, elaborated) @@ -364,6 +450,7 @@ checkExpr defs gam pol True tau (Case s _ guardExpr cases) = do newConjunct (patternGam, eVars, subst, elaborated_pat_i, _) <- ctxtFromTypedPattern s guardTy pat_i NotFull + -- Checking the case body newConjunct -- Specialise the return type and the incoming environment using the @@ -403,9 +490,6 @@ checkExpr defs gam pol True tau (Case s _ guardExpr cases) = do branchCtxt' <- ctxtPlus s branchCtxt (justLinear $ (gam `intersectCtxts` specialisedGam) `intersectCtxts` localGam) - -- Probably don't want to remove specialised things in this way- we want to - -- invert the substitution and put these things into the context - -- Check local binding use ctxtApprox s (localGam `intersectCtxts` patternGam) patternGam @@ -423,14 +507,17 @@ checkExpr defs gam pol True tau (Case s _ guardExpr cases) = do return (branchCtxt', subst', (elaborated_pat_i, elaborated_i)) -- Anything that was bound in the pattern but not used correctly - xs -> illLinearityMismatch s xs + p:ps -> illLinearityMismatch s (p:|ps) st <- get debugM "pred so after branches" (pretty (predicateStack st)) + -- All branches must be possible + checkGuardsForImpossibility s $ mkId "case" + -- Pop from stacks related to case - popGuardContext - popCaseFrame + _ <- popGuardContext + _ <- popCaseFrame -- Find the upper-bound contexts let (branchCtxts, substs, elaboratedCases) = unzip3 branchCtxtsAndSubst @@ -478,8 +565,8 @@ checkExpr defs gam pol topLevel tau e = do return (gam', substFinal, elaboratedE) else do case pol of - Positive -> typeClash (getSpan e) tau tau' - Negative -> typeClash (getSpan e) tau' tau + Positive -> throw TypeError{ errLoc = getSpan e, tyExpected = tau , tyActual = tau' } + Negative -> throw TypeError{ errLoc = getSpan e, tyExpected = tau', tyActual = tau } -- | Synthesise the 'Type' of expressions. -- See @@ -488,7 +575,7 @@ synthExpr :: (?globals :: Globals) -> Ctxt Assumption -- ^ Local typing context -> Polarity -- ^ Polarity of subgrading -> Expr () () -- ^ Expression - -> MaybeT Checker (Type, Ctxt Assumption, Substitution, Expr () Type) + -> Checker (Type, Ctxt Assumption, Substitution, Expr () Type) -- Literals can have their type easily synthesised synthExpr _ _ _ (Val s _ (NumInt n)) = do @@ -520,17 +607,20 @@ synthExpr _ gam _ (Val s _ (Constr _ c [])) = do -- Should be provided in the type checkers environment st <- get case lookup c (dataConstructors st) of - Just tySch -> do + Just (tySch, coercions) -> do -- Freshen the constructor -- (discarding any fresh type variables, info not needed here) - (ty, _, []) <- freshPolymorphicInstance InstanceQ False tySch + -- TODO: allow data type constructors to have constraints + (ty, _, _, _, coercions') <- freshPolymorphicInstance InstanceQ False tySch coercions + + -- Apply coercions + ty <- substitute coercions' ty let elaborated = Val s ty (Constr ty c []) return (ty, [], [], elaborated) - Nothing -> halt $ UnboundVariableError (Just s) $ - "Data constructor `" <> pretty c <> "`" show (dataConstructors st) + Nothing -> throw UnboundDataConstructor{ errLoc = s, errId = c } -- Case synthesis synthExpr defs gam pol (Case s _ guardExpr cases) = do @@ -559,7 +649,10 @@ synthExpr defs gam pol (Case s _ guardExpr cases) = do -- the variable bound in the pattern of this branch [] -> return (tyCase, (localGam `subtractCtxt` patternGam, subst'), (elaborated_pat_i, elaborated_i)) - xs -> illLinearityMismatch s xs + p:ps -> illLinearityMismatch s (p:|ps) + + -- All branches must be possible + checkGuardsForImpossibility s $ mkId "case" popCaseFrame @@ -586,52 +679,47 @@ synthExpr defs gam pol (Case s _ guardExpr cases) = do return (branchType, gamNew, subst, elaborated) -- Diamond cut +-- let [[p]] <- [[e1 : sig]] in [[e2 : tau]] synthExpr defs gam pol (LetDiamond s _ p optionalTySig e1 e2) = do -- TODO: refactor this once we get a proper mechanism for -- specifying effect over-approximations and type aliases (sig, gam1, subst1, elaborated1) <- synthExpr defs gam pol e1 - (ef1, ty1) <- - case sig of - Diamond ["IO"] ty1 -> return ([], ty1) - Diamond ["Session"] ty1 -> return ([], ty1) - Diamond ef1 ty1 -> return (ef1, ty1) - t -> halt $ GenericError (Just s) - $ "Expected an effect type but got `" - <> pretty t <> "` in subject of let" + (ef1, ty1) <- case sig of + Diamond ["IO"] ty1 -> return ([], ty1) + Diamond ["Session"] ty1 -> return ([], ty1) + Diamond ef1 ty1 -> return (ef1, ty1) + t -> throw ExpectedEffectType{ errLoc = s, errTy = t } -- Type body of the let... -- ...in the context of the binders from the pattern (binders, _, substP, elaboratedP, _) <- ctxtFromTypedPattern s ty1 p NotFull pIrrefutable <- isIrrefutable s ty1 p - if not pIrrefutable - then refutablePattern s p - else do - (tau, gam2, subst2, elaborated2) <- synthExpr defs (binders <> gam) pol e2 - (ef2, ty2) <- - case tau of - Diamond ["IO"] ty2 -> return ([], ty2) - Diamond ["Session"] ty2 -> return ([], ty2) - Diamond ef2 ty2 -> return (ef2, ty2) - t -> halt $ GenericError (Just s) - $ "Expected an effect type but got `" - <> pretty t <> "` in body of let" + unless pIrrefutable $ throw RefutablePatternError{ errLoc = s, errPat = p } + (tau, gam2, subst2, elaborated2) <- synthExpr defs (binders <> gam) pol e2 + (ef2, ty2) <- case tau of + Diamond ["IO"] ty2 -> return ([], ty2) + Diamond ["Session"] ty2 -> return ([], ty2) + Diamond ef2 ty2 -> return (ef2, ty2) + t -> throw ExpectedEffectType{ errLoc = s, errTy = t } - optionalSigEquality s optionalTySig ty1 + optionalSigEquality s optionalTySig ty1 - -- Check that usage matches the binding grades/linearity - -- (performs the linearity check) - ctxtEquals s (gam2 `intersectCtxts` binders) binders + -- Check that usage matches the binding grades/linearity + -- (performs the linearity check) + ctxtEquals s (gam2 `intersectCtxts` binders) binders - gamNew <- ctxtPlus s (gam2 `subtractCtxt` binders) gam1 + gamNew <- ctxtPlus s (gam2 `subtractCtxt` binders) gam1 - let t = Diamond (ef1 <> ef2) ty2 + let t = Diamond (ef1 <> ef2) ty2 - subst <- combineManySubstitutions s [substP, subst1, subst2] + subst <- combineManySubstitutions s [substP, subst1, subst2] + -- Synth subst + t' <- substitute substP t - let elaborated = LetDiamond s t elaboratedP optionalTySig elaborated1 elaborated2 - return (t, gamNew, subst, elaborated) + let elaborated = LetDiamond s t elaboratedP optionalTySig elaborated1 elaborated2 + return (t, gamNew, subst, elaborated) -- Variables synthExpr defs gam _ (Val s _ (Var _ x)) = @@ -641,7 +729,7 @@ synthExpr defs gam _ (Val s _ (Var _ x)) = -- Try definitions in scope case lookup x (defs <> Primitives.builtins) of Just tyScheme -> do - (ty', _, constraints) <- freshPolymorphicInstance InstanceQ False tyScheme -- discard list of fresh type variables + (ty', _, _, constraints, []) <- freshPolymorphicInstance InstanceQ False tyScheme [] -- discard list of fresh type variables mapM_ (\ty -> do pred <- compileTypeConstraintToConstraint s ty @@ -651,12 +739,8 @@ synthExpr defs gam _ (Val s _ (Var _ x)) = return (ty', [], [], elaborated) -- Couldn't find it - Nothing -> halt $ UnboundVariableError (Just s) $ pretty x "synthExpr on variables" - <> if debugging ?globals then - " { looking for " <> show x - <> " in context " <> show gam - <> "}" - else "" + Nothing -> throw UnboundVariableError{ errLoc = s, errId = x } + -- In the local context Just (Linear ty) -> do let elaborated = Val s ty (Var ty x) @@ -687,15 +771,14 @@ synthExpr defs gam pol (App s _ e e') = do subst <- combineSubstitutions s subst1 subst2 - tau <- substitute subst tau + -- Synth subst + tau <- substitute subst2 tau let elaborated = App s tau elaboratedL elaboratedR return (tau, gamNew, subst, elaborated) -- Not a function type - t -> - halt $ GenericError (Just s) $ "Left-hand side of application is not a function" - <> " but has type '" <> pretty t <> "'" + t -> throw LhsOfApplicationNotAFunction{ errLoc = s, errTy = t } {- Promotion @@ -711,10 +794,10 @@ synthExpr defs gam pol (Val s _ (Promote _ e)) = do -- Create a fresh kind variable for this coeffect vark <- freshIdentifierBase $ "kprom_" <> [head (pretty e)] -- remember this new kind variable in the kind environment - modify (\st -> st { kVarContext = (mkId vark, KCoeffect) : kVarContext st }) + modify (\st -> st { tyVarContext = (mkId vark, (KCoeffect, InstanceQ)) : tyVarContext st }) -- Create a fresh coeffect variable for the coeffect of the promoted expression - var <- freshTyVarInContext (mkId $ "prom_[" <> pretty e <> "]") (KPromote $ TyVar $ mkId vark) + var <- freshTyVarInContext (mkId $ "prom_[" <> pretty (startPos s) <> "]") (KPromote $ TyVar $ mkId vark) gamF <- discToFreshVarsIn s (freeVars e) gam (CVar var) @@ -731,32 +814,30 @@ synthExpr defs gam pol (Binop s _ op e1 e2) = do (t2, gam2, subst2, elaboratedR) <- synthExpr defs gam pol e2 -- Look through the list of operators (of which there might be -- multiple matching operators) - case lookupMany op Primitives.binaryOperators of - [] -> halt $ UnboundVariableError (Just s) $ "Binary operator " <> op - ops -> do - returnType <- selectFirstByType t1 t2 ops - gamOut <- ctxtPlus s gam1 gam2 - - subst <- combineSubstitutions s subst1 subst2 - - let elaborated = Binop s returnType op elaboratedL elaboratedR - return (returnType, gamOut, subst, elaborated) + returnType <- + selectFirstByType t1 t2 + . NonEmpty.toList + . Primitives.binaryOperators + $ op + gamOut <- ctxtPlus s gam1 gam2 + subst <- combineSubstitutions s subst1 subst2 + let elaborated = Binop s returnType op elaboratedL elaboratedR + return (returnType, gamOut, subst, elaborated) where -- No matching type were found (meaning there is a type error) - selectFirstByType t1 t2 [] = - halt $ GenericError (Just s) $ "Could not resolve operator " <> op <> " at type: " - <> pretty (FunTy t1 (FunTy t2 (TyVar $ mkId "..."))) + selectFirstByType t1 t2 [] = throw FailedOperatorResolution + { errLoc = s, errOp = op, errTy = t1 .-> t2 .-> var "..." } selectFirstByType t1 t2 ((FunTy opt1 (FunTy opt2 resultTy)):ops) = do -- Attempt to use this typing - (result, local) <- localChecking $ do + (result, local) <- peekChecker $ do (eq1, _, _) <- equalTypes s t1 opt1 (eq2, _, _) <- equalTypes s t2 opt2 return (eq1 && eq2) -- If successful then return this local computation case result of - Just True -> local >> return resultTy + Right True -> local >> return resultTy _ -> selectFirstByType t1 t2 ops selectFirstByType t1 t2 (_:ops) = selectFirstByType t1 t2 ops @@ -765,92 +846,108 @@ synthExpr defs gam pol (Binop s _ op e1 e2) = do -- Abstraction, can only synthesise the types of -- lambda in Church style (explicit type) synthExpr defs gam pol (Val s _ (Abs _ p (Just sig) e)) = do - (bindings, _, substP, elaboratedP, _) <- ctxtFromTypedPattern s sig p NotFull + + newConjunct + + (bindings, localVars, substP, elaboratedP, _) <- ctxtFromTypedPattern s sig p NotFull + + newConjunct pIrrefutable <- isIrrefutable s sig p if pIrrefutable then do (tau, gam'', subst, elaboratedE) <- synthExpr defs (bindings <> gam) pol e -- Locally we should have this property (as we are under a binder) - ctxtEquals s (gam'' `intersectCtxts` bindings) bindings + ctxtApprox s (gam'' `intersectCtxts` bindings) bindings let finalTy = FunTy sig tau let elaborated = Val s finalTy (Abs finalTy elaboratedP (Just sig) elaboratedE) substFinal <- combineSubstitutions s substP subst - return (finalTy, gam'' `subtractCtxt` bindings, substFinal, elaborated) - else refutablePattern s p + finalTy' <- substitute substP finalTy + + concludeImplication s localVars + + return (finalTy', gam'' `subtractCtxt` bindings, substFinal, elaborated) + + else throw RefutablePatternError{ errLoc = s, errPat = p } -- Abstraction, can only synthesise the types of -- lambda in Church style (explicit type) synthExpr defs gam pol (Val s _ (Abs _ p Nothing e)) = do + newConjunct + tyVar <- freshTyVarInContext (mkId "t") KType let sig = (TyVar tyVar) - (bindings, _, substP, elaboratedP, _) <- ctxtFromTypedPattern s sig p NotFull + (bindings, localVars, substP, elaboratedP, _) <- ctxtFromTypedPattern s sig p NotFull + + newConjunct pIrrefutable <- isIrrefutable s sig p if pIrrefutable then do (tau, gam'', subst, elaboratedE) <- synthExpr defs (bindings <> gam) pol e -- Locally we should have this property (as we are under a binder) - ctxtEquals s (gam'' `intersectCtxts` bindings) bindings + ctxtApprox s (gam'' `intersectCtxts` bindings) bindings let finalTy = FunTy sig tau let elaborated = Val s finalTy (Abs finalTy elaboratedP (Just sig) elaboratedE) + finalTy' <- substitute substP finalTy - substFinal <- combineSubstitutions s substP subst - return (finalTy, gam'' `subtractCtxt` bindings, substFinal, elaborated) - else refutablePattern s p + concludeImplication s localVars + + subst <- combineSubstitutions s substP subst + + return (finalTy', gam'' `subtractCtxt` bindings, subst, elaborated) + else throw RefutablePatternError{ errLoc = s, errPat = p } synthExpr _ _ _ e = - halt $ GenericError (Just $ getSpan e) $ "Type cannot be calculated here for `" - <> pretty e <> "` try adding more type signatures." + throw NeedTypeSignature{ errLoc = getSpan e, errExpr = e } -- Check an optional type signature for equality against a type -optionalSigEquality :: (?globals :: Globals) => Span -> Maybe Type -> Type -> MaybeT Checker Bool -optionalSigEquality _ Nothing _ = return True +optionalSigEquality :: (?globals :: Globals) => Span -> Maybe Type -> Type -> Checker () +optionalSigEquality _ Nothing _ = pure () optionalSigEquality s (Just t) t' = do - (eq, _, _) <- equalTypes s t' t - return eq + _ <- equalTypes s t' t + pure () -solveConstraints :: (?globals :: Globals) => Pred -> Span -> Id -> MaybeT Checker () +solveConstraints :: (?globals :: Globals) => Pred -> Span -> Id -> Checker () solveConstraints predicate s name = do -- Get the coeffect kind context and constraints checkerState <- get let ctxtCk = tyVarContext checkerState - let ctxtCkVar = kVarContext checkerState coeffectVars <- justCoeffectTypesConverted s ctxtCk - coeffectKVars <- justCoeffectTypesConvertedVars s ctxtCkVar - result <- liftIO $ provePredicate s predicate coeffectVars coeffectKVars + result <- liftIO $ provePredicate predicate coeffectVars case result of QED -> return () NotValid msg -> do - msg' <- rewriteMessage msg - simpPred <- simplifyPred predicate - - halt $ GenericError (Just s) $ "The associated theorem for `" <> pretty name <> "` " - <> if msg' == "is Falsifiable\n" - then "is false. " - <> "\n That is: " <> pretty (NegPred simpPred) - else msg' <> "\n thus: " <> pretty (NegPred simpPred) - + msg' <- rewriteMessage msg + simplPred <- simplifyPred predicate + + -- try trivial unsats again + let unsats' = trivialUnsatisfiableConstraints simplPred + if not (null unsats') + then mapM_ (\c -> throw GradingError{ errLoc = getSpan c, errConstraint = Neg c }) unsats' + else + if msg' == "is Falsifiable\n" + then throw SolverErrorFalsifiableTheorem + { errLoc = s, errDefId = name, errPred = simplPred } + else throw SolverErrorCounterExample + { errLoc = s, errDefId = name, errPred = simplPred } NotValidTrivial unsats -> - mapM_ (\c -> halt $ GradingError (Just $ getSpan c) (pretty . Neg $ c)) unsats + mapM_ (\c -> throw GradingError{ errLoc = getSpan c, errConstraint = Neg c }) unsats Timeout -> - halt $ CheckerError Nothing $ - "Solver timed out with limit of " <> - show (solverTimeoutMillis ?globals) <> - " ms. You may want to increase the timeout (see --help)." - Error msg -> - halt msg + throw SolverTimeout{ errLoc = s, errSolverTimeoutMillis = solverTimeoutMillis, errDefId = name, errContext = "grading", errPred = predicate } + OtherSolverError msg -> throw SolverError{ errLoc = s, errMsg = msg } + SolverProofError msg -> error msg -- Rewrite an error message coming from the solver -rewriteMessage :: String -> MaybeT Checker String +rewriteMessage :: String -> Checker String rewriteMessage msg = do st <- get let tyVars = tyVarContext st @@ -870,11 +967,13 @@ rewriteMessage msg = do KPromote (TyCon (internalName -> "Level")) -> T.replace (T.pack $ show privateRepresentation) (T.pack "Private") (T.replace (T.pack $ show publicRepresentation) (T.pack "Public") - (T.replace (T.pack "Integer") (T.pack "Level") line')) + (T.replace (T.pack "Integer") (T.pack "Level") line')) _ -> line' else line' in line'' +justCoeffectTypesConverted :: (?globals::Globals) + => Span -> [(a, (Kind, b))] -> Checker [(a, (Type, b))] justCoeffectTypesConverted s xs = mapM convert xs >>= (return . catMaybes) where convert (var, (KPromote t, q)) = do @@ -888,7 +987,8 @@ justCoeffectTypesConverted s xs = mapM convert xs >>= (return . catMaybes) KCoeffect -> return $ Just (var, (TyVar v, q)) _ -> return Nothing convert _ = return Nothing - +justCoeffectTypesConvertedVars :: (?globals::Globals) + => Span -> [(Id, Kind)] -> Checker (Ctxt Type) justCoeffectTypesConvertedVars s env = do let implicitUniversalMadeExplicit = map (\(var, k) -> (var, (k, ForallQ))) env env' <- justCoeffectTypesConverted s implicitUniversalMadeExplicit @@ -898,7 +998,7 @@ justCoeffectTypesConvertedVars s env = do -- and the typical pattern is that `ctxt2` represents a specification -- (i.e. input to checking) and `ctxt1` represents actually usage ctxtApprox :: (?globals :: Globals) => - Span -> Ctxt Assumption -> Ctxt Assumption -> MaybeT Checker () + Span -> Ctxt Assumption -> Ctxt Assumption -> Checker () ctxtApprox s ctxt1 ctxt2 = do -- intersection contains those ids from ctxt1 which appears in ctxt2 intersection <- @@ -915,7 +1015,7 @@ ctxtApprox s ctxt1 ctxt2 = do Nothing -> case ass2 of -- Linear gets instantly reported - Linear t -> illLinearityMismatch s [LinearNotUsed id] + Linear t -> illLinearityMismatch s . pure $ LinearNotUsed id -- Else, this could be due to weakening so see if this is allowed Discharged t c -> do kind <- inferCoeffectType s c @@ -926,15 +1026,14 @@ ctxtApprox s ctxt1 ctxt2 = do forM_ ctxt1 $ \(id, ass1) -> if (id `elem` intersection) then return () - else halt $ UnboundVariableError (Just s) $ - "Variable `" <> pretty id <> "` was used but is not bound here" + else throw UnboundVariableError{ errLoc = s, errId = id } -- | `ctxtEquals ctxt1 ctxt2` checks if two contexts are equal -- and the typical pattern is that `ctxt2` represents a specification -- (i.e. input to checking) and `ctxt1` represents actually usage ctxtEquals :: (?globals :: Globals) => - Span -> Ctxt Assumption -> Ctxt Assumption -> MaybeT Checker () + Span -> Ctxt Assumption -> Ctxt Assumption -> Checker () ctxtEquals s ctxt1 ctxt2 = do -- intersection contains those ids from ctxt1 which appears in ctxt2 intersection <- @@ -951,7 +1050,7 @@ ctxtEquals s ctxt1 ctxt2 = do Nothing -> case ass2 of -- Linear gets instantly reported - Linear t -> illLinearityMismatch s [LinearNotUsed id] + Linear t -> illLinearityMismatch s . pure $ LinearNotUsed id -- Else, this could be due to weakening so see if this is allowed Discharged t c -> do kind <- inferCoeffectType s c @@ -962,14 +1061,13 @@ ctxtEquals s ctxt1 ctxt2 = do forM_ ctxt1 $ \(id, ass1) -> if (id `elem` intersection) then return () - else halt $ UnboundVariableError (Just s) $ - "Variable `" <> pretty id <> "` was used but is not bound here" + else throw UnboundVariableError{ errLoc = s, errId = id } {- | Take the least-upper bound of two contexts. If one context contains a linear variable that is not present in the other, then the resulting context will not have this linear variable -} joinCtxts :: (?globals :: Globals) => Span -> Ctxt Assumption -> Ctxt Assumption - -> MaybeT Checker (Ctxt Assumption) + -> Checker (Ctxt Assumption) joinCtxts s ctxt1 ctxt2 = do -- All the type assumptions from ctxt1 whose variables appear in ctxt2 -- and weaken all others @@ -991,8 +1089,12 @@ joinCtxts s ctxt1 ctxt2 = do {- | intersect contexts and weaken anything not appear in both relative to the left context (this is not commutative) -} -intersectCtxtsWithWeaken :: (?globals :: Globals) => Span -> Ctxt Assumption -> Ctxt Assumption - -> MaybeT Checker (Ctxt Assumption) +intersectCtxtsWithWeaken + :: (?globals :: Globals) + => Span + -> Ctxt Assumption + -> Ctxt Assumption + -> Checker (Ctxt Assumption) intersectCtxtsWithWeaken s a b = do let intersected = intersectCtxts a b -- All the things that were not shared @@ -1006,7 +1108,7 @@ intersectCtxtsWithWeaken s a b = do isNonLinearAssumption (_, Discharged _ _) = True isNonLinearAssumption _ = False - weaken :: (Id, Assumption) -> MaybeT Checker (Id, Assumption) + weaken :: (Id, Assumption) -> Checker (Id, Assumption) weaken (var, Linear t) = return (var, Linear t) weaken (var, Discharged t c) = do @@ -1037,7 +1139,7 @@ relateByAssumption :: (?globals :: Globals) -> (Span -> Coeffect -> Coeffect -> Type -> Constraint) -> (Id, Assumption) -> (Id, Assumption) - -> MaybeT Checker () + -> Checker () -- Linear assumptions ignored relateByAssumption _ _ (_, Linear _) (_, Linear _) = return () @@ -1048,23 +1150,19 @@ relateByAssumption s rel (_, Discharged _ c1) (_, Discharged _ c2) = do addConstraint (rel s c1 c2 kind) relateByAssumption s _ x y = - halt $ GenericError (Just s) $ "Can't unify free-variable types:\n\t" - <> "(graded) " <> pretty x <> "\n with\n\t(linear) " <> pretty y + throw UnifyGradedLinear{ errLoc = s, errGraded = fst x, errLinear = fst y } + -- Replace all top-level discharged coeffects with a variable -- and derelict anything else -- but add a var discToFreshVarsIn :: (?globals :: Globals) => Span -> [Id] -> Ctxt Assumption -> Coeffect - -> MaybeT Checker (Ctxt Assumption) + -> Checker (Ctxt Assumption) discToFreshVarsIn s vars ctxt coeffect = mapM toFreshVar (relevantSubCtxt vars ctxt) where toFreshVar (var, Discharged t c) = do coeffTy <- mguCoeffectTypes s c coeffect - - -- Create a fresh variable - cvar <- freshTyVarInContext var (promoteTypeToKind coeffTy) - -- Return the freshened var-type mapping - return (var, Discharged t (CVar cvar)) + return (var, Discharged t (CSig c coeffTy)) toFreshVar (var, Linear t) = do coeffTy <- inferCoeffectType s coeffect @@ -1085,7 +1183,7 @@ discToFreshVarsIn s vars ctxt coeffect = mapM toFreshVar (relevantSubCtxt vars c -- ("y", Linear Int)] -- freshVarsIn :: (?globals :: Globals) => Span -> [Id] -> Ctxt Assumption - -> MaybeT Checker (Ctxt Assumption) + -> Checker (Ctxt Assumption) freshVarsIn s vars ctxt = mapM toFreshVar (relevantSubCtxt vars ctxt) where toFreshVar (var, Discharged t c) = do @@ -1104,7 +1202,7 @@ freshVarsIn s vars ctxt = mapM toFreshVar (relevantSubCtxt vars ctxt) -- Combine two contexts ctxtPlus :: (?globals :: Globals) => Span -> Ctxt Assumption -> Ctxt Assumption - -> MaybeT Checker (Ctxt Assumption) + -> Checker (Ctxt Assumption) ctxtPlus _ [] ctxt2 = return ctxt2 ctxtPlus s ((i, v) : ctxt1) ctxt2 = do ctxt' <- extCtxt s ctxt2 i v @@ -1112,21 +1210,20 @@ ctxtPlus s ((i, v) : ctxt1) ctxt2 = do -- ExtCtxt the context extCtxt :: (?globals :: Globals) => Span -> Ctxt Assumption -> Id -> Assumption - -> MaybeT Checker (Ctxt Assumption) + -> Checker (Ctxt Assumption) extCtxt s ctxt var (Linear t) = do case lookup var ctxt of Just (Linear t') -> if t == t' - then halt $ LinearityError (Just s) - $ "Linear variable `" <> pretty var <> "` is used more than once.\n" - else typeClashForVariable s var t t' + then throw LinearityError{ errLoc = s, linearityMismatch = LinearUsedMoreThanOnce var } + else throw TypeVariableMismatch{ errLoc = s, errVar = var, errTy1 = t, errTy2 = t' } Just (Discharged t' c) -> if t == t' then do k <- inferCoeffectType s c return $ replace ctxt var (Discharged t (c `CPlus` COne k)) - else typeClashForVariable s var t t' + else throw TypeVariableMismatch{ errLoc = s, errVar = var, errTy1 = t, errTy2 = t' } Nothing -> return $ (var, Linear t) : ctxt extCtxt s ctxt var (Discharged t c) = do @@ -1135,13 +1232,13 @@ extCtxt s ctxt var (Discharged t c) = do Just (Discharged t' c') -> if t == t' then return $ replace ctxt var (Discharged t' (c `CPlus` c')) - else typeClashForVariable s var t t' + else throw TypeVariableMismatch{ errLoc = s, errVar = var, errTy1 = t, errTy2 = t' } Just (Linear t') -> if t == t' then do k <- inferCoeffectType s c return $ replace ctxt var (Discharged t (c `CPlus` COne k)) - else typeClashForVariable s var t t' + else throw TypeVariableMismatch{ errLoc = s, errVar = var, errTy1 = t, errTy2 = t' } Nothing -> return $ (var, Discharged t c) : ctxt -- Helper, foldM on a list with at least one element @@ -1149,21 +1246,22 @@ fold1M :: Monad m => (a -> a -> m a) -> [a] -> m a fold1M _ [] = error "Must have at least one case" fold1M f (x:xs) = foldM f x xs +justLinear :: [(a, Assumption)] -> [(a, Assumption)] justLinear [] = [] justLinear ((x, Linear t) : xs) = (x, Linear t) : justLinear xs justLinear ((x, _) : xs) = justLinear xs checkGuardsForExhaustivity :: (?globals :: Globals) - => Span -> Id -> Type -> [Equation () ()] -> MaybeT Checker () + => Span -> Id -> Type -> [Equation () ()] -> Checker () checkGuardsForExhaustivity s name ty eqs = do - -- TODO: + debugM "Guard exhaustivity" "todo" return () -checkGuardsForImpossibility :: (?globals :: Globals) => Span -> Id -> MaybeT Checker () +checkGuardsForImpossibility :: (?globals :: Globals) => Span -> Id -> Checker () checkGuardsForImpossibility s name = do -- Get top of guard predicate stack st <- get - let ps : _ = guardPredicates st + let ps = head $ guardPredicates st -- Convert all universal variables to existential let tyVarContextExistential = @@ -1172,35 +1270,46 @@ checkGuardsForImpossibility s name = do BoundQ -> Nothing _ -> Just (v, (k, InstanceQ))) (tyVarContext st) tyVars <- justCoeffectTypesConverted s tyVarContextExistential - kVars <- justCoeffectTypesConvertedVars s (kVarContext st) -- For each guard predicate forM_ ps $ \((ctxt, p), s) -> do - p <- simplifyPred p - -- Existentially quantify those variables occuring in the pattern in scope let thm = foldr (uncurry Exists) p ctxt + debugM "impossibility" $ "about to try" <> pretty thm -- Try to prove the theorem - result <- liftIO $ provePredicate s thm tyVars kVars + result <- liftIO $ provePredicate thm tyVars - let msgHead = "Pattern guard for equation of `" <> pretty name <> "`" + p <- simplifyPred thm case result of QED -> return () -- Various kinds of error - NotValid msg -> halt $ GenericError (Just s) $ msgHead <> - " is impossible. Its condition " <> msg - NotValidTrivial unsats -> - halt $ GenericError (Just s) $ msgHead <> - " is impossible.\n\t" <> - intercalate "\n\t" (map (pretty . Neg) unsats) - Timeout -> halt $ CheckerError (Just s) $ - "While checking plausibility of pattern guard for equation " <> pretty name - <> "the solver timed out with limit of " <> - show (solverTimeoutMillis ?globals) <> - " ms. You may want to increase the timeout (see --help)." - - Error msg -> halt msg + -- TODO make errors better + NotValid msg -> throw ImpossiblePatternMatch + { errLoc = s + , errId = name + , errPred = p + } + NotValidTrivial unsats -> throw ImpossiblePatternMatchTrivial + { errLoc = s + , errId = name + , errUnsats = unsats + } + Timeout -> throw SolverTimeout + { errLoc = s + , errDefId = name + , errSolverTimeoutMillis = solverTimeoutMillis + , errContext = "pattern match of an equation" + , errPred = p + } + + OtherSolverError msg -> throw ImpossiblePatternMatch + { errLoc = s + , errId = name + , errPred = p + } + + SolverProofError msg -> error msg diff --git a/frontend/src/Language/Granule/Checker/Coeffects.hs b/frontend/src/Language/Granule/Checker/Coeffects.hs index 82161450e..b7d333dd4 100644 --- a/frontend/src/Language/Granule/Checker/Coeffects.hs +++ b/frontend/src/Language/Granule/Checker/Coeffects.hs @@ -10,20 +10,27 @@ import Language.Granule.Context import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Type + -- | Find out whether a coeffect if flattenable, and if so get the operation -- | used to representing flattening on the grades flattenable :: Type -> Type -> Maybe ((Coeffect -> Coeffect -> Coeffect), Type) flattenable t1 t2 | t1 == t2 = case t1 of + t1 | t1 == extendedNat -> Just (CTimes, t1) + TyCon (internalName -> "Nat") -> Just (CTimes, t1) - TyCon (internalName -> "Level") -> Just (CJoin, t1) + TyCon (internalName -> "Level") -> Just (CMeet, t1) - TyApp (TyCon (internalName -> "Interval")) t -> flattenable t t - TyApp (TyCon (internalName -> "Ext")) t -> flattenable t t -- TODO + TyApp (TyCon (internalName -> "Interval")) t -> flattenable t t _ -> Nothing - | otherwise = Just (CProduct, TyCon (mkId "×") .@ t1 .@ t2) + | otherwise = + case (t1, t2) of + (t1, TyCon (internalName -> "Nat")) | t1 == extendedNat -> Just (CTimes, t1) + (TyCon (internalName -> "Nat"), t2) | t2 == extendedNat -> Just (CTimes, t2) + + _ -> Just (CProduct, TyCon (mkId "×") .@ t1 .@ t2) -- | Multiply an context by a coeffect -- (Derelict and promote all variables which are not discharged and are in th @@ -39,4 +46,4 @@ multAll vars c ((name, Discharged t c') : ctxt) | name `elem` vars = (name, Discharged t (c `CTimes` c')) : multAll vars c ctxt multAll vars c ((_, Linear _) : ctxt) = multAll vars c ctxt -multAll vars c ((_, Discharged _ _) : ctxt) = multAll vars c ctxt +multAll vars c ((_, Discharged _ _) : ctxt) = multAll vars c ctxt \ No newline at end of file diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs index d86ec4407..67244ed3b 100644 --- a/frontend/src/Language/Granule/Checker/Constraints.hs +++ b/frontend/src/Language/Granule/Checker/Constraints.hs @@ -16,7 +16,6 @@ import qualified Data.Set as S import Control.Arrow (first) import Control.Exception (assert) -import Language.Granule.Checker.Errors import Language.Granule.Checker.Predicates import Language.Granule.Checker.Kinds import Language.Granule.Context (Ctxt) @@ -26,9 +25,9 @@ import Language.Granule.Checker.Constraints.Quantifiable import Language.Granule.Checker.Constraints.SNatX (SNatX(..)) import qualified Language.Granule.Checker.Constraints.SNatX as SNatX +import Language.Granule.Syntax.Helpers import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Pretty -import Language.Granule.Syntax.Span import Language.Granule.Syntax.Type import Language.Granule.Utils @@ -41,9 +40,9 @@ compileQuant BoundQ = existential -- | Compile constraint into an SBV symbolic bool, along with a list of -- | constraints which are trivially unequal (if such things exist) (e.g., things like 1=0). compileToSBV :: (?globals :: Globals) - => Pred -> Ctxt (Type, Quantifier) -> Ctxt Type + => Pred -> Ctxt (Type, Quantifier) -> (Symbolic SBool, Symbolic SBool, [Constraint]) -compileToSBV predicate tyVarContext kVarContext = +compileToSBV predicate tyVarContext = (buildTheorem id compileQuant , undefined -- buildTheorem sNot (compileQuant . flipQuant) , trivialUnsatisfiableConstraints predicate') @@ -53,7 +52,7 @@ compileToSBV predicate tyVarContext kVarContext = -- flipQuant InstanceQ = ForallQ -- flipQuant BoundQ = BoundQ - predicate' = rewriteConstraints kVarContext predicate + predicate' = rewriteConstraints tyVarContext predicate buildTheorem :: (SBool -> SBool) @@ -62,8 +61,13 @@ compileToSBV predicate tyVarContext kVarContext = buildTheorem polarity quant = do -- Create fresh solver variables for everything in the type variable -- context of the write kind + + -- IMPORTANT: foldrM creates its side effects in reverse order + -- this is good because tyVarContext has the reverse order for our + -- quantifiers, so reversing order of the effects in foldrM gives us + -- the order we want for the predicate (preConstraints, constraints, solverVars) <- - foldrM (createFreshVar quant) (sTrue, sTrue, []) tyVarContext + foldrM (createFreshVar quant predicate) (sTrue, sTrue, []) tyVarContext predC <- buildTheorem' solverVars predicate' return (polarity (preConstraints .=> (constraints .&& predC))) @@ -89,7 +93,7 @@ compileToSBV predicate tyVarContext kVarContext = return $ sNot p' buildTheorem' solverVars (Exists v k p) = - if v `elem` (vars p) + if v `elem` (freeVars p) -- optimisation then @@ -117,7 +121,8 @@ compileToSBV predicate tyVarContext kVarContext = forSome [(internalName v)] $ \solverVar -> do pred' <- buildTheorem' ((v, SLevel solverVar) : solverVars) p return ((solverVar .== literal privateRepresentation - .|| solverVar .== literal publicRepresentation) .&& pred') + .|| solverVar .== literal publicRepresentation + .|| solverVar .== literal unusedRepresentation) .&& pred') k -> error $ "Solver error: I don't know how to create an existntial for " <> show k Just k -> error $ "Solver error: I don't know how to create an existntial for demotable type " <> show k @@ -131,14 +136,15 @@ compileToSBV predicate tyVarContext kVarContext = buildTheorem' solverVars p -- TODO: generalise this to not just Nat indices - buildTheorem' solverVars (Impl (v:vs) p p') = - if v `elem` (vars p <> vars p') + buildTheorem' solverVars (Impl ((v, _kind):vs) p p') = + if v `elem` (freeVars p <> freeVars p') -- If the quantified variable appears in the theorem then + -- Create fresh solver variable forAll [(internalName v)] $ \vSolver -> do - impl <- buildTheorem' ((v, SNat vSolver) : solverVars) (Impl vs p p') - return ((vSolver .>= literal 0) .=> impl) + impl <- buildTheorem' ((v, SNat vSolver) : solverVars) (Impl vs p p') + return ((vSolver .>= literal 0) .=> impl) else -- An optimisation, don't bother quantifying things @@ -153,32 +159,39 @@ compileToSBV predicate tyVarContext kVarContext = -- with an associated refinement predicate createFreshVar :: (forall a. Quantifiable a => Quantifier -> (String -> Symbolic a)) + -> Pred -> (Id, (Type, Quantifier)) -> (SBool, SBool, Ctxt SGrade) -> Symbolic (SBool, SBool, Ctxt SGrade) -- Ignore variables coming from a dependent pattern match because -- they get created elsewhere - createFreshVar _ (_, (_, BoundQ)) x = return x + createFreshVar _ _ (_, (_, BoundQ)) x = return x - createFreshVar quant + createFreshVar quant predicate (var, (kind, quantifierType)) - (universalConstraints, existentialConstraints, ctxt) = do - (pre, symbolic) <- freshCVar quant (internalName var) kind quantifierType - let (universalConstraints', existentialConstraints') = - case quantifierType of - ForallQ -> (pre .&& universalConstraints, existentialConstraints) - InstanceQ -> (universalConstraints, pre .&& existentialConstraints) - b -> error $ "Impossible freshening a BoundQ, but this is cause above" - -- BoundQ -> (universalConstraints, pre .&& existentialConstraints) - return (universalConstraints', existentialConstraints', (var, symbolic) : ctxt) + (universalConstraints, existentialConstraints, ctxt) = + if not (var `elem` (freeVars predicate)) + -- If the variable is not in the predicate, then don't create a new var + then return (universalConstraints, existentialConstraints, ctxt) + + -- Otherwise... + else do + (pre, symbolic) <- freshCVar quant (internalName var) kind quantifierType + let (universalConstraints', existentialConstraints') = + case quantifierType of + ForallQ -> (pre .&& universalConstraints, existentialConstraints) + InstanceQ -> (universalConstraints, pre .&& existentialConstraints) + b -> error $ "Impossible freshening a BoundQ, but this is cause above" + -- BoundQ -> (universalConstraints, pre .&& existentialConstraints) + return (universalConstraints', existentialConstraints', (var, symbolic) : ctxt) -- TODO: replace with use of `substitute` -- given an context mapping coeffect type variables to coeffect typ, -- then rewrite a set of constraints so that any occruences of the kind variable -- are replaced with the coeffect type -rewriteConstraints :: Ctxt Type -> Pred -> Pred +rewriteConstraints :: Ctxt (Type, Quantifier) -> Pred -> Pred rewriteConstraints ctxt = predFold Conj @@ -193,42 +206,47 @@ rewriteConstraints ctxt = Exists var k' p where k' = case lookup kvar ctxt of - Just ty -> KPromote ty + Just (ty, _) -> KPromote ty Nothing -> KVar kvar existsCase var k p = Exists var k p -- `updateConstraint v k c` rewrites any occurence of the kind variable -- `v` in the constraint `c` with the kind `k` - updateConstraint :: Id -> Type -> Constraint -> Constraint - updateConstraint ckindVar ckind (Eq s c1 c2 k) = + updateConstraint :: Id -> (Type, Quantifier) -> Constraint -> Constraint + updateConstraint ckindVar (ckind, _) (Eq s c1 c2 k) = Eq s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) (case k of TyVar ckindVar' | ckindVar == ckindVar' -> ckind _ -> k) - updateConstraint ckindVar ckind (Neq s c1 c2 k) = + updateConstraint ckindVar (ckind, _) (Neq s c1 c2 k) = Neq s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) (case k of TyVar ckindVar' | ckindVar == ckindVar' -> ckind _ -> k) - updateConstraint ckindVar ckind (ApproximatedBy s c1 c2 k) = + updateConstraint ckindVar (ckind, _) (ApproximatedBy s c1 c2 k) = ApproximatedBy s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) (case k of TyVar ckindVar' | ckindVar == ckindVar' -> ckind _ -> k) - updateConstraint ckindVar ckind (NonZeroPromotableTo s x c t) = + updateConstraint ckindVar (ckind, _) (NonZeroPromotableTo s x c t) = NonZeroPromotableTo s x (updateCoeffect ckindVar ckind c) (case t of TyVar ckindVar' | ckindVar == ckindVar' -> ckind _ -> t) - updateConstraint ckindVar ckind (Lt s c1 c2) = + updateConstraint ckindVar (ckind, _) (Lt s c1 c2) = Lt s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) - updateConstraint ckindVar ckind (Gt s c1 c2) = + updateConstraint ckindVar (ckind, _) (Gt s c1 c2) = Gt s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) + updateConstraint ckindVar (ckind, _) (GtEq s c1 c2) = + GtEq s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) + + updateConstraint ckindVar (ckind, _) (LtEq s c1 c2) = + LtEq s (updateCoeffect ckindVar ckind c1) (updateCoeffect ckindVar ckind c2) -- `updateCoeffect v k c` rewrites any occurence of the kind variable -- `v` in the coeffect `c` with the kind `k` @@ -255,6 +273,7 @@ rewriteConstraints ctxt = -- | Symbolic coeffect representing 0..Inf +zeroToInfinity :: SGrade zeroToInfinity = SInterval (SExtNat $ SNatX 0) (SExtNat SNatX.inf) @@ -300,7 +319,8 @@ freshCVar quant name (TyCon k) q = "Level" -> do -- constrain (solverVar .== 0 .|| solverVar .== 1) return (solverVar .== literal privateRepresentation - .|| solverVar .== literal publicRepresentation, SLevel solverVar) + .|| solverVar .== literal publicRepresentation + .|| solverVar .== literal unusedRepresentation, SLevel solverVar) k -> do error $ "I don't know how to make a fresh solver variable of type " <> show k @@ -316,9 +336,12 @@ freshCVar quant name t q | t == extendedNat = do -- infinity value (since this satisfies all the semiring properties on the nose) freshCVar quant name (TyVar v) q | "kprom" `isPrefixOf` internalName v = do -- future TODO: resolve polymorphism to free coeffect (uninterpreted) --- TODO: possibly this can now be removed return (sTrue, SPoint) +freshCVar quant name (TyVar v) q = do + solverVar <- quant q name + return (sTrue, SUnknown $ SynLeaf $ Just solverVar) + freshCVar _ _ t _ = error $ "Trying to make a fresh solver variable for a grade of type: " <> show t <> " but I don't know how." @@ -354,6 +377,19 @@ compile vars (Gt s c1 c2) = c1' = compileCoeffect c1 (TyCon $ mkId "Nat") vars c2' = compileCoeffect c2 (TyCon $ mkId "Nat") vars +compile vars (LtEq s c1 c2) = + return $ c1' .<= c2' + where + c1' = compileCoeffect c1 (TyCon $ mkId "Nat") vars + c2' = compileCoeffect c2 (TyCon $ mkId "Nat") vars + +compile vars (GtEq s c1 c2) = + return $ c1' .>= c2' + where + c1' = compileCoeffect c1 (TyCon $ mkId "Nat") vars + c2' = compileCoeffect c2 (TyCon $ mkId "Nat") vars + + -- NonZeroPromotableTo s c means that: compile vars (NonZeroPromotableTo s x c t) = do -- exists x . @@ -439,7 +475,7 @@ compileCoeffect (CZero k') k vars = case (k', k) of (TyCon k', TyCon k) -> assert (internalName k' == internalName k) $ case internalName k' of - "Level" -> SLevel $ literal privateRepresentation + "Level" -> SLevel $ literal unusedRepresentation "Nat" -> SNat 0 "Q" -> SFloat (fromRational 0) "Set" -> SSet (S.fromList []) @@ -456,6 +492,8 @@ compileCoeffect (CZero k') k vars = SInterval (compileCoeffect (CZero t) t' vars) (compileCoeffect (CZero t) t' vars) + + (TyVar _, _) -> SUnknown (SynLeaf (Just 0)) _ -> error $ "I don't know how to compile a 0 for " <> pretty k' compileCoeffect (COne k') k vars = @@ -481,11 +519,23 @@ compileCoeffect (COne k') k vars = SInterval (compileCoeffect (COne t) t' vars) (compileCoeffect (COne t) t' vars) + (TyVar _, _) -> SUnknown (SynLeaf (Just 1)) + _ -> error $ "I don't know how to compile a 1 for " <> pretty k' compileCoeffect (CProduct c1 c2) (isProduct -> Just (t1, t2)) vars = SProduct (compileCoeffect c1 t1 vars) (compileCoeffect c2 t2 vars) +-- For grade-polymorphic coeffects, that have come from a nat +-- expression (sometimes this is just from a compounded expression of 1s), +-- perform the injection from Natural numbers to arbitrary semirings +compileCoeffect (CNat n) (TyVar _) _ | n > 0 = + SUnknown (injection n) + where + injection 0 = SynLeaf (Just 0) + injection 1 = SynLeaf (Just 1) + injection n = SynPlus (SynLeaf (Just 1)) (injection (n-1)) + compileCoeffect c (TyVar _) _ = error $ "Trying to compile a polymorphically kinded " <> pretty c @@ -504,6 +554,8 @@ eqConstraint (SExtNat x) (SExtNat y) = x .== y eqConstraint SPoint SPoint = sTrue eqConstraint s t | isSProduct s && isSProduct t = applyToProducts (.==) (.&&) (const sTrue) s t +eqConstraint u@(SUnknown{}) u'@(SUnknown{}) = + u .== u' eqConstraint x y = error $ "Kind error trying to generate equality " <> show x <> " = " <> show y @@ -511,7 +563,11 @@ eqConstraint x y = approximatedByOrEqualConstraint :: SGrade -> SGrade -> SBool approximatedByOrEqualConstraint (SNat n) (SNat m) = n .== m approximatedByOrEqualConstraint (SFloat n) (SFloat m) = n .<= m -approximatedByOrEqualConstraint (SLevel l) (SLevel k) = l .>= k +approximatedByOrEqualConstraint (SLevel l) (SLevel k) = + -- Private <= Public + ite (l .== literal unusedRepresentation) sTrue + $ ite (l .== literal privateRepresentation) sTrue + $ ite (k .== literal publicRepresentation) sTrue sFalse approximatedByOrEqualConstraint (SSet s) (SSet t) = if s == t then sTrue else sFalse approximatedByOrEqualConstraint SPoint SPoint = sTrue @@ -531,13 +587,18 @@ approximatedByOrEqualConstraint (SInterval lb1 ub1) (SInterval lb2 ub2) = .&& (approximatedByOrEqualConstraint ub1 ub2) approximatedByOrEqualConstraint (SExtNat x) (SExtNat y) = x .== y + +approximatedByOrEqualConstraint u@(SUnknown{}) u'@(SUnknown{}) = + -- Note shortcircuiting version of || implemented here + ite (u .== u') sTrue (u .< u') + approximatedByOrEqualConstraint x y = error $ "Kind error trying to generate " <> show x <> " <= " <> show y trivialUnsatisfiableConstraints :: Pred -> [Constraint] trivialUnsatisfiableConstraints - = filter unsat + = concatMap unsat . map normaliseConstraint . positiveConstraints where @@ -551,26 +612,41 @@ trivialUnsatisfiableConstraints positiveConstraints = predFold concat (\_ -> []) (\_ _ q -> q) (\x -> [x]) id (\_ _ p -> p) - unsat :: Constraint -> Bool - unsat (Eq _ c1 c2 _) = c1 `neqC` c2 - unsat (Neq _ c1 c2 _) = not (c1 `neqC` c2) - unsat (ApproximatedBy _ c1 c2 _) = c1 `approximatedByC` c2 - unsat (NonZeroPromotableTo _ _ (CZero _) _) = True - unsat (NonZeroPromotableTo _ _ _ _) = False + -- All the unsatisfiable constraints + unsat :: Constraint -> [Constraint] + unsat c@(Eq _ c1 c2 _) = if (c1 `neqC` c2) then [c] else [] + unsat c@(Neq _ c1 c2 _) = if (c1 `neqC` c2) then [] else [c] + unsat c@(ApproximatedBy{}) = approximatedByC c + unsat c@(NonZeroPromotableTo _ _ (CZero _) _) = [c] + unsat (NonZeroPromotableTo _ _ _ _) = [] -- TODO: look at this information - unsat (Lt _ c1 c2) = False - unsat (Gt _ c1 c2) = False + unsat (Lt _ c1 c2) = [] + unsat (Gt _ c1 c2) = [] + unsat (LtEq _ c1 c2) = [] + unsat (GtEq _ c1 c2) = [] -- TODO: unify this with eqConstraint and approximatedByOrEqualConstraint -- Attempt to see if one coeffect is trivially greater than the other - approximatedByC :: Coeffect -> Coeffect -> Bool - approximatedByC (CNat n) (CNat m) = n /= m - approximatedByC (Level n) (Level m) = n < m - approximatedByC (CFloat n) (CFloat m) = n > m + approximatedByC :: Constraint -> [Constraint] + approximatedByC c@(ApproximatedBy _ (CNat n) (CNat m) _) | n /= m = [c] + approximatedByC c@(ApproximatedBy _ (Level n) (Level m) _) | n > m = [c] + approximatedByC c@(ApproximatedBy _ (CFloat n) (CFloat m) _) | n > m = [c] -- Nat like intervals - approximatedByC (CInterval (CNat lb1) (CNat ub1)) (CInterval (CNat lb2) (CNat ub2)) = - not $ (lb2 <= lb1) && (ub1 <= ub2) - approximatedByC _ _ = False + approximatedByC c@(ApproximatedBy _ + (CInterval (CNat lb1) (CNat ub1)) + (CInterval (CNat lb2) (CNat ub2)) _) + | not $ (lb2 <= lb1) && (ub1 <= ub2) = [c] + + approximatedByC (ApproximatedBy s (CProduct c1 c2) (CProduct d1 d2) (isProduct -> Just (t1, t2))) = + (approximatedByC (ApproximatedBy s c1 d1 t1)) ++ (approximatedByC (ApproximatedBy s c2 d2 t2)) + + approximatedByC (ApproximatedBy s c (CProduct d1 d2) (isProduct -> Just (t1, t2))) = + (approximatedByC (ApproximatedBy s c d1 t1)) ++ (approximatedByC (ApproximatedBy s c d2 t2)) + + approximatedByC (ApproximatedBy s (CProduct c1 c2) d (isProduct -> Just (t1, t2))) = + (approximatedByC (ApproximatedBy s c1 d t1)) ++ (approximatedByC (ApproximatedBy s c2 d t2)) + + approximatedByC _ = [] -- Attempt to see if one coeffect is trivially not equal to the other neqC :: Coeffect -> Coeffect -> Bool @@ -581,30 +657,27 @@ trivialUnsatisfiableConstraints -- neqC lb1 lb2 || neqC ub1 ub2 neqC _ _ = False -data SolverResult = - QED +data SolverResult + = QED | NotValid String | NotValidTrivial [Constraint] | Timeout - | Error CheckerError + | SolverProofError String + | OtherSolverError String -provePredicate :: (?globals :: Globals) => - Span - -> Pred -- Predicate +provePredicate + :: (?globals :: Globals) + => Pred -- Predicate -> Ctxt (Type, Quantifier) -- Free variable quantifiers - -> Ctxt Type -- Free variable kinds -> IO SolverResult -provePredicate s predicate vars kvars = - if isTrivial predicate - then do +provePredicate predicate vars + | isTrivial predicate = do debugM "solveConstraints" "Skipping solver because predicate is trivial." return QED - - else do - let (sbvTheorem, _, unsats) = compileToSBV predicate vars kvars - + | otherwise = do + let (sbvTheorem, _, unsats) = compileToSBV predicate vars ThmResult thmRes <- prove $ do -- proveWith defaultSMTCfg {verbose=True} - case solverTimeoutMillis ?globals of + case solverTimeoutMillis of n | n <= 0 -> return () n -> setTimeOut n sbvTheorem @@ -612,14 +685,9 @@ provePredicate s predicate vars kvars = return $ case thmRes of -- we're good: the negation of the theorem is unsatisfiable Unsatisfiable {} -> QED - - ProofError _ msgs -> Error $ CheckerError (Just s) $ "Solver error:" <> unlines msgs - + ProofError _ msgs _ -> SolverProofError $ unlines msgs Unknown _ UnknownTimeOut -> Timeout - - Unknown _ reason -> - Error $ CheckerError (Just s) $ "Solver says unknown: " <> show reason - + Unknown _ reason -> OtherSolverError $ show reason _ -> case getModelAssignment thmRes of -- Main 'Falsifiable' result @@ -638,9 +706,5 @@ provePredicate s predicate vars kvars = Left msg -> print $ show msg -} NotValid $ "is " <> show (ThmResult thmRes) - - Right (True, _) -> - NotValid "returned probable model." - - Left str -> - Error $ GenericError (Just s) str + Right (True, _) -> NotValid "returned probable model." + Left str -> OtherSolverError str diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs index f013f878e..52e7d8103 100644 --- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs +++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs @@ -4,11 +4,10 @@ module Language.Granule.Checker.Constraints.Compile where -import Control.Monad.Trans.Maybe import Language.Granule.Checker.Monad import Language.Granule.Checker.Predicates -import Language.Granule.Checker.Errors + import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Pretty @@ -17,38 +16,39 @@ import Language.Granule.Syntax.Span import Language.Granule.Utils -compileNatKindedTypeToCoeffect :: (?globals :: Globals) => Span -> Type -> MaybeT Checker Coeffect +compileNatKindedTypeToCoeffect :: (?globals :: Globals) => Span -> Type -> Checker Coeffect compileNatKindedTypeToCoeffect s (TyInfix op t1 t2) = do t1' <- compileNatKindedTypeToCoeffect s t1 t2' <- compileNatKindedTypeToCoeffect s t2 case op of - "+" -> return $ CPlus t1' t2' - "*" -> return $ CTimes t1' t2' - "^" -> return $ CExpon t1' t2' - "-" -> return $ CMinus t1' t2' - "∨" -> return $ CJoin t1' t2' - "∧" -> return $ CMeet t1' t2' - _ -> halt $ UnboundVariableError (Just s) $ "Type-level operator " <> op + TyOpPlus -> return $ CPlus t1' t2' + TyOpTimes -> return $ CTimes t1' t2' + TyOpExpon -> return $ CExpon t1' t2' + TyOpMinus -> return $ CMinus t1' t2' + TyOpJoin -> return $ CJoin t1' t2' + TyOpMeet -> return $ CMeet t1' t2' + _ -> undefined + compileNatKindedTypeToCoeffect _ (TyInt n) = return $ CNat n compileNatKindedTypeToCoeffect _ (TyVar v) = return $ CVar v compileNatKindedTypeToCoeffect s t = - halt $ KindError (Just s) $ "Type `" <> pretty t <> "` does not have kind `Nat`" + throw $ KindError{errLoc = s, errTy = t, errK = kNat } compileTypeConstraintToConstraint :: - (?globals :: Globals) => Span -> Type -> MaybeT Checker Pred + (?globals :: Globals) => Span -> Type -> Checker Pred compileTypeConstraintToConstraint s (TyInfix op t1 t2) = do c1 <- compileNatKindedTypeToCoeffect s t1 c2 <- compileNatKindedTypeToCoeffect s t2 case op of - "=" -> return $ Con (Eq s c1 c2 (TyCon $ mkId "Nat")) - "/=" -> return $ Con (Neq s c1 c2 (TyCon $ mkId "Nat")) - "<" -> return $ Con (Lt s c1 c2) - ">" -> return $ Con (Gt s c1 c2) - "<=" -> return $ Disj [Con $ Lt s c1 c2, Con $ Eq s c1 c2 (TyCon $ mkId "Nat")] - ">=" -> return $ Disj [Con $ Gt s c1 c2, Con $ Eq s c1 c2 (TyCon $ mkId "Nat")] - _ -> halt $ GenericError (Just s) $ "I don't know how to compile binary operator " <> op + TyOpEq -> return $ Con (Eq s c1 c2 (TyCon $ mkId "Nat")) + TyOpNotEq -> return $ Con (Neq s c1 c2 (TyCon $ mkId "Nat")) + TyOpLesser -> return $ Con (Lt s c1 c2) + TyOpGreater -> return $ Con (Gt s c1 c2) + TyOpLesserEq -> return $ Con (LtEq s c1 c2) + TyOpGreaterEq -> return $ Con (GtEq s c1 c2) + _ -> error $ pretty s <> ": I don't know how to compile binary operator " <> pretty op compileTypeConstraintToConstraint s t = - halt $ GenericError (Just s) $ "I don't know how to compile a constraint `" <> pretty t <> "`" + error $ pretty s <> ": I don't know how to compile a constraint `" <> pretty t <> "`" diff --git a/frontend/src/Language/Granule/Checker/Constraints/SNatX.hs b/frontend/src/Language/Granule/Checker/Constraints/SNatX.hs index de80be6d7..906ef16fd 100644 --- a/frontend/src/Language/Granule/Checker/Constraints/SNatX.hs +++ b/frontend/src/Language/Granule/Checker/Constraints/SNatX.hs @@ -49,6 +49,14 @@ instance OrdSymbolic SNatX where $ ite (isInf b) sTrue $ xVal a .< xVal b +meetSNatX :: SNatX -> SNatX -> SNatX +meetSNatX a@(SNatX ai) b@(SNatX bi) = + ite (isInf a) b $ ite (isInf b) a $ SNatX (ai `smin` bi) + +joinSNatX :: SNatX -> SNatX -> SNatX +joinSNatX a@(SNatX ai) b@(SNatX bi) = + ite (isInf a) inf $ ite (isInf b) inf $ SNatX (ai `smax` bi) + representationConstraint :: SInteger -> SBool representationConstraint v = v .>= -1 diff --git a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs index 4d9599b8a..e532833fe 100644 --- a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs +++ b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs @@ -10,6 +10,7 @@ import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Type import Language.Granule.Checker.Constraints.SNatX (SNatX(..)) +import qualified Data.Text as T import GHC.Generics (Generic) import Data.SBV hiding (kindOf, name, symbolic) import qualified Data.Set as S @@ -25,8 +26,39 @@ data SGrade = -- Single point coeffect (not exposed at the moment) | SPoint | SProduct { sfst :: SGrade, ssnd :: SGrade } + + -- A kind of embedded uninterpreted sort which can accept some equations + -- Used for doing some limited solving over poly coeffect grades + | SUnknown SynTree + -- but if Nothing then these values are incomparable deriving (Show, Generic) +data SynTree = + SynPlus SynTree SynTree + | SynTimes SynTree SynTree + | SynMeet SynTree SynTree + | SynJoin SynTree SynTree + | SynLeaf (Maybe SInteger) -- Just 0 and Just 1 can be identified + +instance Show SynTree where + show (SynPlus s t) = "(" ++ show s ++ " + " ++ show t ++ ")" + show (SynTimes s t) = show s ++ " * " ++ show t + show (SynJoin s t) = "(" ++ show s ++ " \\/ " ++ show t ++ ")" + show (SynMeet s t) = "(" ++ show s ++ " /\\ " ++ show t ++ ")" + show (SynLeaf Nothing) = "?" + show (SynLeaf (Just n)) = T.unpack $ + T.replace (T.pack $ " :: SInteger") (T.pack "") (T.pack $ show n) + + +sEqTree :: SynTree -> SynTree -> SBool +sEqTree (SynPlus s s') (SynPlus t t') = (sEqTree s t) .&& (sEqTree s' t') +sEqTree (SynTimes s s') (SynTimes t t') = (sEqTree s t) .&& (sEqTree s' t') +sEqTree (SynMeet s s') (SynMeet t t') = (sEqTree s t) .&& (sEqTree s' t') +sEqTree (SynJoin s s') (SynJoin t t') = (sEqTree s t) .&& (sEqTree s' t') +sEqTree (SynLeaf Nothing) (SynLeaf Nothing) = sFalse +sEqTree (SynLeaf (Just n)) (SynLeaf (Just n')) = n .=== n' +sEqTree _ _ = sFalse + -- Work out if two symbolic grades are of the same type match :: SGrade -> SGrade -> Bool match (SNat _) (SNat _) = True @@ -37,6 +69,7 @@ match (SExtNat _) (SExtNat _) = True match (SInterval s1 s2) (SInterval t1 t2) = match s1 t1 && match t1 t2 match SPoint SPoint = True match (SProduct s1 s2) (SProduct t1 t2) = match s1 t1 && match s2 t2 +match (SUnknown _) (SUnknown _) = True match _ _ = False isSProduct :: SGrade -> Bool @@ -90,6 +123,8 @@ instance Mergeable SGrade where symbolicMerge s sb a b | isSProduct a || isSProduct b = applyToProducts (symbolicMerge s sb) SProduct id a b + symbolicMerge s sb (SUnknown (SynLeaf (Just u))) (SUnknown (SynLeaf (Just u'))) = + SUnknown (SynLeaf (Just (symbolicMerge s sb u u'))) symbolicMerge _ _ s t = cannotDo "symbolicMerge" s t instance OrdSymbolic SGrade where @@ -102,6 +137,7 @@ instance OrdSymbolic SGrade where (SExtNat n) .< (SExtNat n') = n .< n' SPoint .< SPoint = sTrue s .< t | isSProduct s || isSProduct t = applyToProducts (.<) (.&&) (const sTrue) s t + (SUnknown (SynLeaf (Just n))) .< (SUnknown (SynLeaf (Just n'))) = n .< n' s .< t = cannotDo ".<" s t instance EqSymbolic SGrade where @@ -114,6 +150,7 @@ instance EqSymbolic SGrade where (SExtNat n) .== (SExtNat n') = n .== n' SPoint .== SPoint = sTrue s .== t | isSProduct s || isSProduct t = applyToProducts (.==) (.&&) (const sTrue) s t + (SUnknown t) .== (SUnknown t') = sEqTree t t' s .== t = cannotDo ".==" s t -- | Meet operation on symbolic grades @@ -128,6 +165,9 @@ symGradeMeet (SInterval lb1 ub1) (SInterval lb2 ub2) = symGradeMeet SPoint SPoint = SPoint symGradeMeet s t | isSProduct s || isSProduct t = applyToProducts symGradeMeet SProduct id s t +symGradeMeet (SUnknown (SynLeaf (Just n))) (SUnknown (SynLeaf (Just n'))) = + SUnknown (SynLeaf (Just (n `smin` n'))) +symGradeMeet (SUnknown t) (SUnknown t') = SUnknown (SynMeet t t') symGradeMeet s t = cannotDo "meet" s t -- | Join operation on symbolic grades @@ -142,13 +182,16 @@ symGradeJoin (SInterval lb1 ub1) (SInterval lb2 ub2) = symGradeJoin SPoint SPoint = SPoint symGradeJoin s t | isSProduct s || isSProduct t = applyToProducts symGradeJoin SProduct id s t +symGradeJoin (SUnknown (SynLeaf (Just n))) (SUnknown (SynLeaf (Just n'))) = + SUnknown (SynLeaf (Just (n `smax` n'))) +symGradeJoin (SUnknown t) (SUnknown t') = SUnknown (SynJoin t t') symGradeJoin s t = cannotDo "join" s t -- | Plus operation on symbolic grades symGradePlus :: SGrade -> SGrade -> SGrade symGradePlus (SNat n1) (SNat n2) = SNat (n1 + n2) symGradePlus (SSet s) (SSet t) = SSet $ S.union s t -symGradePlus (SLevel lev1) (SLevel lev2) = SLevel $ lev1 `smin` lev2 +symGradePlus (SLevel lev1) (SLevel lev2) = SLevel $ lev1 `smax` lev2 symGradePlus (SFloat n1) (SFloat n2) = SFloat $ n1 + n2 symGradePlus (SExtNat x) (SExtNat y) = SExtNat (x + y) symGradePlus (SInterval lb1 ub1) (SInterval lb2 ub2) = @@ -156,20 +199,60 @@ symGradePlus (SInterval lb1 ub1) (SInterval lb2 ub2) = symGradePlus SPoint SPoint = SPoint symGradePlus s t | isSProduct s || isSProduct t = applyToProducts symGradePlus SProduct id s t + +-- Direct encoding of addition unit +symGradePlus (SUnknown t@(SynLeaf (Just u))) (SUnknown t'@(SynLeaf (Just u'))) = + ite (u .== 0) (SUnknown (SynLeaf (Just u'))) + (ite (u' .== 0) (SUnknown (SynLeaf (Just u))) (SUnknown (SynPlus t t'))) + +symGradePlus (SUnknown t@(SynLeaf (Just u))) (SUnknown t') = + ite (u .== 0) (SUnknown t') (SUnknown (SynPlus t t')) + +symGradePlus (SUnknown um) (SUnknown (SynLeaf u)) = + symGradePlus (SUnknown (SynLeaf u)) (SUnknown um) + symGradePlus s t = cannotDo "plus" s t -- | Times operation on symbolic grades symGradeTimes :: SGrade -> SGrade -> SGrade symGradeTimes (SNat n1) (SNat n2) = SNat (n1 * n2) symGradeTimes (SSet s) (SSet t) = SSet $ S.union s t -symGradeTimes (SLevel lev1) (SLevel lev2) = SLevel $ lev1 `smin` lev2 +symGradeTimes (SLevel lev1) (SLevel lev2) = + ite (lev1 .== literal unusedRepresentation) + (SLevel $ literal unusedRepresentation) + $ ite (lev2 .== literal unusedRepresentation) + (SLevel $ literal unusedRepresentation) + (SLevel $ lev1 `smax` lev2) symGradeTimes (SFloat n1) (SFloat n2) = SFloat $ n1 * n2 symGradeTimes (SExtNat x) (SExtNat y) = SExtNat (x * y) symGradeTimes (SInterval lb1 ub1) (SInterval lb2 ub2) = - SInterval (lb1 `symGradeTimes` lb2) (ub1 `symGradeTimes` ub2) + --SInterval (lb1 `symGradeTimes` lb2) (ub1 `symGradeTimes` ub2) + SInterval (comb symGradeMeet) (comb symGradeJoin) + where + comb f = ((lb1lb2 `f` lb1ub2) `f` ub1lb2) `f` ub1ub2 + lb1lb2 = lb1 `symGradeTimes` lb2 + lb1ub2 = lb1 `symGradeTimes` ub2 + ub1lb2 = ub1 `symGradeTimes` lb2 + ub1ub2 = ub1 `symGradeTimes` ub2 symGradeTimes SPoint SPoint = SPoint symGradeTimes s t | isSProduct s || isSProduct t = applyToProducts symGradeTimes SProduct id s t + +-- units and absorption directly encoded +symGradeTimes (SUnknown t@(SynLeaf (Just u))) (SUnknown t'@(SynLeaf (Just u'))) = + ite (u .== 1) (SUnknown (SynLeaf (Just u'))) + (ite (u' .== 1) (SUnknown (SynLeaf (Just u))) + (ite (u .== 0) (SUnknown (SynLeaf (Just 0))) + (ite (u' .== 0) (SUnknown (SynLeaf (Just 0))) + (SUnknown (SynPlus t t'))))) + +symGradeTimes (SUnknown t@(SynLeaf (Just u))) (SUnknown t') = + ite (u .== 1) (SUnknown t') + (ite (u .== 0) (SUnknown (SynLeaf (Just 0))) (SUnknown (SynTimes t t'))) + +symGradeTimes (SUnknown um) (SUnknown (SynLeaf u)) = + symGradeTimes (SUnknown (SynLeaf u)) (SUnknown um) + symGradeTimes s t = cannotDo "times" s t -- | Minus operation on symbolic grades @@ -185,6 +268,13 @@ symGradeMinus s t | isSProduct s || isSProduct t = symGradeMinus s t = cannotDo "minus" s t cannotDo :: String -> SGrade -> SGrade -> a +cannotDo op (SUnknown s) (SUnknown t) = + error $ "It is unknown whether " + <> show s <> " " + <> op <> " " + <> show t + <> " holds for all resource algebras." + cannotDo op s t = error $ "Cannot perform symbolic operation `" <> op <> "` on " diff --git a/frontend/src/Language/Granule/Checker/Errors.hs b/frontend/src/Language/Granule/Checker/Errors.hs deleted file mode 100644 index 38447964e..000000000 --- a/frontend/src/Language/Granule/Checker/Errors.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -module Language.Granule.Checker.Errors where - -import Language.Granule.Utils -import Language.Granule.Syntax.Identifiers -import Language.Granule.Syntax.Span - -{- Helpers for error messages and checker control flow -} -data CheckerError - = CheckerError (Maybe Span) String - | GenericError (Maybe Span) String - | GradingError (Maybe Span) String - | KindError (Maybe Span) String - | LinearityError (Maybe Span) String - | PatternTypingError (Maybe Span) String - | UnboundVariableError (Maybe Span) String - | RefutablePatternError (Maybe Span) String - | NameClashError (Maybe Span) String - | DuplicatePatternError (Maybe Span) String - deriving (Show, Eq) - -instance UserMsg CheckerError where - title CheckerError {} = "Checker error" - title GenericError {} = "Type error" - title GradingError {} = "Grading error" - title KindError {} = "Kind error" - title LinearityError {} = "Linearity error" - title PatternTypingError {} = "Pattern typing error" - title UnboundVariableError {} = "Unbound variable error" - title RefutablePatternError {} = "Pattern is refutable" - title NameClashError {} = "Name clash" - title DuplicatePatternError {} = "Duplicate pattern" - location (CheckerError sp _) = sp - location (GenericError sp _) = sp - location (GradingError sp _) = sp - location (KindError sp _) = sp - location (LinearityError sp _) = sp - location (PatternTypingError sp _) = sp - location (UnboundVariableError sp _) = sp - location (RefutablePatternError sp _) = sp - location (NameClashError sp _) = sp - location (DuplicatePatternError sp _) = sp - msg (CheckerError _ m) = m - msg (GenericError _ m) = m - msg (GradingError _ m) = m - msg (KindError _ m) = m - msg (LinearityError _ m) = m - msg (PatternTypingError _ m) = m - msg (UnboundVariableError _ m) = m - msg (RefutablePatternError _ m) = m - msg (NameClashError _ m) = m - msg (DuplicatePatternError _ m) = m - -data LinearityMismatch = - LinearNotUsed Id - | LinearUsedNonLinearly Id - | NonLinearPattern - deriving Show -- for debugging diff --git a/frontend/src/Language/Granule/Checker/Exhaustivity.hs b/frontend/src/Language/Granule/Checker/Exhaustivity.hs index e2850f606..c3967280c 100644 --- a/frontend/src/Language/Granule/Checker/Exhaustivity.hs +++ b/frontend/src/Language/Granule/Checker/Exhaustivity.hs @@ -3,7 +3,10 @@ module Language.Granule.Checker.Exhaustivity (isIrrefutable) where -import Control.Monad.Trans.Maybe +isIrrefutable :: Applicative f => a -> b -> c -> f Bool +isIrrefutable _ _ _ = pure True + +{- import Control.Monad.State.Strict import Language.Granule.Checker.Monad @@ -12,36 +15,45 @@ import Language.Granule.Syntax.Pattern import Language.Granule.Syntax.Span import Language.Granule.Syntax.Type import Language.Granule.Utils +--import Language.Granule.Syntax.Pretty -- | Check whether a given pattern match will always succeed -- NB: This is work in progress. -isIrrefutable :: (?globals :: Globals) => Span -> Type -> Pattern t -> MaybeT Checker Bool +isIrrefutable :: (?globals :: Globals) => Span -> Type -> Pattern t -> Checker Bool isIrrefutable s t (PVar _ _ _) = return True isIrrefutable s t (PWild _ _) = return True -isIrrefutable s (Box _ t) (PBox _ _ p) = isIrrefutable s t p -isIrrefutable s t@(TyVar _) (PBox _ _ p) = isIrrefutable s t p -isIrrefutable s (TyCon c) _ = checkCardinality c -isIrrefutable s t@(TyApp t1 t2) (PConstr _ _ name ps) = unpeel s t (reverse ps) -isIrrefutable s t@(TyVar _) (PConstr _ _ (internalName -> "(,)") [p1, p2]) = do - i1 <- isIrrefutable s t p1 -- somewhat of a cheat but type information is not important here - i2 <- isIrrefutable s t p2 -- somewhat of a cheat but type info is not important here +isIrrefutable s t (PBox _ _ p) = isIrrefutable s t p + +-- TODO: Get rid of types and lookup cardinality through the +-- environment based on the constructor name +isIrrefutable s (TyCon c) (PConstr _ _ _ ps) = do + irrefutables <- mapM (isIrrefutable s (TyCon c)) ps + singleton <- checkCardinality c + return $ singleton && and irrefutables + +isIrrefutable s t (PConstr _ _ (internalName -> ",") [p1, p2]) = do + i1 <- isIrrefutable s t p1 + i2 <- isIrrefutable s t p2 return (i1 && i2) isIrrefutable s _ _ = return False +{- -- | Check if every sub-pattern of a type application is also irrefutable -- (reverse the patterns coming out of a PConstr before calling this) -unpeel :: (?globals :: Globals) => Span -> Type -> [Pattern t] -> MaybeT Checker Bool +unpeel :: (?globals :: Globals) => Span -> Type -> [Pattern t] -> Checker Bool unpeel s (TyApp t1 t2) (p:ps) = do irrefutable <- isIrrefutable s t2 p if irrefutable then unpeel s t1 ps else return False unpeel _ (TyCon c) _ = checkCardinality c unpeel _ _ _ = return False +-} -- | Get the number of data constructors, only irrefutable if = `Just 1` -checkCardinality :: (?globals :: Globals) => Id -> MaybeT Checker Bool +checkCardinality :: Id -> Checker Bool checkCardinality tyCon = do st <- get case lookup tyCon (typeConstructors st) of Just (_,Just 1) -> return True _ -> return False +-} \ No newline at end of file diff --git a/frontend/src/Language/Granule/Checker/Kinds.hs b/frontend/src/Language/Granule/Checker/Kinds.hs index 4ade19540..f574a1609 100644 --- a/frontend/src/Language/Granule/Checker/Kinds.hs +++ b/frontend/src/Language/Granule/Checker/Kinds.hs @@ -1,27 +1,25 @@ -- Mainly provides a kind checker on types -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ViewPatterns #-} -module Language.Granule.Checker.Kinds (kindCheckDef - , inferKindOfType - , inferKindOfType' +module Language.Granule.Checker.Kinds ( + inferKindOfType + , inferKindOfTypeInContext , joinCoeffectTypes , hasLub , joinKind , inferCoeffectType + , inferCoeffectTypeInContext , inferCoeffectTypeAssumption , mguCoeffectTypes , promoteTypeToKind , demoteKindToType) where import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import Language.Granule.Checker.Errors import Language.Granule.Checker.Monad import Language.Granule.Checker.Predicates +import Language.Granule.Checker.Primitives (tyOps) +import Language.Granule.Checker.SubstitutionContexts -import Language.Granule.Syntax.Def import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Pretty import Language.Granule.Syntax.Span @@ -29,42 +27,13 @@ import Language.Granule.Syntax.Type import Language.Granule.Context import Language.Granule.Utils - -promoteTypeToKind :: Type -> Kind -promoteTypeToKind (TyVar v) = KVar v -promoteTypeToKind t = KPromote t - -demoteKindToType :: Kind -> Maybe Type -demoteKindToType (KPromote t) = Just t -demoteKindToType (KVar v) = Just (TyVar v) -demoteKindToType _ = Nothing - --- Currently we expect that a type scheme has kind KType -kindCheckDef :: (?globals :: Globals) => Def v t -> MaybeT Checker () -kindCheckDef (Def s _ _ (Forall _ quantifiedVariables constraints ty)) = do - -- Set up the quantified variables in the type variable context - modify (\st -> st { tyVarContext = map (\(n, c) -> (n, (c, ForallQ))) quantifiedVariables}) - - forM constraints (\constraint -> do - kind <- inferKindOfType' s quantifiedVariables constraint - case kind of - KPredicate -> return () - _ -> illKindedNEq s KPredicate kind) - - - kind <- inferKindOfType' s quantifiedVariables ty - case kind of - KType -> modify (\st -> st { tyVarContext = [] }) - KPromote (TyCon k) | internalName k == "Protocol" -> modify (\st -> st { tyVarContext = [] }) - _ -> illKindedNEq s KType kind - -inferKindOfType :: (?globals :: Globals) => Span -> Type -> MaybeT Checker Kind +inferKindOfType :: (?globals :: Globals) => Span -> Type -> Checker Kind inferKindOfType s t = do checkerState <- get - inferKindOfType' s (stripQuantifiers $ tyVarContext checkerState) t + inferKindOfTypeInContext s (stripQuantifiers $ tyVarContext checkerState) t -inferKindOfType' :: (?globals :: Globals) => Span -> Ctxt Kind -> Type -> MaybeT Checker Kind -inferKindOfType' s quantifiedVariables t = +inferKindOfTypeInContext :: (?globals :: Globals) => Span -> Ctxt Kind -> Type -> Checker Kind +inferKindOfTypeInContext s quantifiedVariables t = typeFoldM (TypeFold kFun kCon kBox kDiamond kVar kApp kInt kInfix) t where kFun (KPromote (TyCon c)) (KPromote (TyCon c')) @@ -72,60 +41,67 @@ inferKindOfType' s quantifiedVariables t = kFun KType KType = return KType kFun KType (KPromote (TyCon (internalName -> "Protocol"))) = return $ KPromote (TyCon (mkId "Protocol")) - kFun KType y = illKindedNEq s KType y - kFun x _ = illKindedNEq s KType x + kFun KType y = throw KindMismatch{ errLoc = s, kExpected = KType, kActual = y } + kFun x _ = throw KindMismatch{ errLoc = s, kExpected = KType, kActual = x } kCon conId = do st <- get case lookup conId (typeConstructors st) of Just (kind,_) -> return kind - Nothing -> halt $ UnboundVariableError (Just s) (pretty conId <> " constructor.") + Nothing -> case lookup conId (dataConstructors st) of + Just (Forall _ [] [] t, _) -> return $ KPromote t + Just _ -> error $ pretty s <> "I'm afraid I can't yet promote the polymorphic data constructor:" <> pretty conId + Nothing -> throw UnboundTypeConstructor{ errLoc = s, errId = conId } kBox c KType = do -- Infer the coeffect (fails if that is ill typed) _ <- inferCoeffectType s c return KType - kBox _ x = illKindedNEq s KType x + kBox _ x = throw KindMismatch{ errLoc = s, kExpected = KType, kActual = x } kDiamond _ KType = return KType - kDiamond _ x = illKindedNEq s KType x + kDiamond _ x = throw KindMismatch{ errLoc = s, kExpected = KType, kActual = x } kVar tyVar = case lookup tyVar quantifiedVariables of Just kind -> return kind Nothing -> do st <- get - case lookup tyVar (kVarContext st) of - Just kind -> return kind - Nothing -> - halt $ UnboundVariableError (Just s) $ - "Type variable `" <> pretty tyVar - <> "` is unbound (not quantified)." - show quantifiedVariables + case lookup tyVar (tyVarContext st) of + Just (kind, _) -> return kind + Nothing -> throw UnboundTypeVariable{ errLoc = s, errId = tyVar } kApp (KFun k1 k2) kArg | k1 `hasLub` kArg = return k2 - kApp k kArg = illKindedNEq s (KFun kArg (KVar $ mkId "....")) k + kApp k kArg = throw KindMismatch + { errLoc = s + , kExpected = (KFun kArg (KVar $ mkId "...")) + , kActual = k + } kInt _ = return $ kConstr $ mkId "Nat" - kInfix op k1 k2 = do - st <- get - case lookup (mkId op) (typeConstructors st) of - Just (KFun k1' (KFun k2' kr), _) -> - if k1 `hasLub` k1' - then if k2 `hasLub` k2' - then return kr - else illKindedNEq s k2' k2 - else illKindedNEq s k1' k1 - Just (k, _) -> illKindedNEq s (KFun k1 (KFun k2 (KVar $ mkId "?"))) k - Nothing -> halt $ UnboundVariableError (Just s) (pretty op <> " operator.") + kInfix (tyOps -> (k1exp, k2exp, kret)) k1act k2act + | not (k1act `hasLub` k1exp) = throw + KindMismatch{ errLoc = s, kExpected = k1exp, kActual = k1act} + | not (k2act `hasLub` k2exp) = throw + KindMismatch{ errLoc = s, kExpected = k2exp, kActual = k2act} + | otherwise = pure kret -- | Compute the join of two kinds, if it exists -joinKind :: Kind -> Kind -> Maybe Kind -joinKind k1 k2 | k1 == k2 = Just k1 +joinKind :: Kind -> Kind -> Maybe (Kind, Substitution) +joinKind k1 k2 | k1 == k2 = Just (k1, []) +joinKind (KVar v) k = Just (k, [(v, SubstK k)]) +joinKind k (KVar v) = Just (k, [(v, SubstK k)]) joinKind (KPromote t1) (KPromote t2) = - fmap KPromote (joinCoeffectTypes t1 t2) + fmap (\k -> (KPromote k, [])) (joinCoeffectTypes t1 t2) joinKind _ _ = Nothing +-- | Predicate on whether two kinds have a leasy upper bound +hasLub :: Kind -> Kind -> Bool +hasLub k1 k2 = + case joinKind k1 k2 of + Nothing -> False + Just _ -> True + -- | Some coeffect types can be joined (have a least-upper bound). This -- | function computes the join if it exists. joinCoeffectTypes :: Type -> Type -> Maybe Type @@ -151,96 +127,93 @@ joinCoeffectTypes t1 t2 = case (t1, t2) of _ -> Nothing --- | Predicate on whether two kinds have a leasy upper bound -hasLub :: Kind -> Kind -> Bool -hasLub k1 k2 = - case joinKind k1 k2 of - Nothing -> False - Just _ -> True - - -- | Infer the type of ta coeffect term (giving its span as well) -inferCoeffectType :: (?globals :: Globals) => Span -> Coeffect -> MaybeT Checker Type +inferCoeffectType :: (?globals :: Globals) => Span -> Coeffect -> Checker Type +inferCoeffectType s c = do + st <- get + inferCoeffectTypeInContext s (map (\(id, (k, _)) -> (id, k)) (tyVarContext st)) c +inferCoeffectTypeInContext :: (?globals :: Globals) => Span -> Ctxt Kind -> Coeffect -> Checker Type -- Coeffect constants have an obvious kind -inferCoeffectType _ (Level _) = return $ TyCon $ mkId "Level" -inferCoeffectType _ (CNat _) = return $ TyCon $ mkId "Nat" -inferCoeffectType _ (CFloat _) = return $ TyCon $ mkId "Q" -inferCoeffectType _ (CSet _) = return $ TyCon $ mkId "Set" -inferCoeffectType s (CProduct c1 c2) = do - k1 <- inferCoeffectType s c1 - k2 <- inferCoeffectType s c2 +inferCoeffectTypeInContext _ _ (Level _) = return $ TyCon $ mkId "Level" +inferCoeffectTypeInContext _ _ (CNat _) = return $ TyCon $ mkId "Nat" +inferCoeffectTypeInContext _ _ (CFloat _) = return $ TyCon $ mkId "Q" +inferCoeffectTypeInContext _ _ (CSet _) = return $ TyCon $ mkId "Set" +inferCoeffectTypeInContext s ctxt (CProduct c1 c2) = do + k1 <- inferCoeffectTypeInContext s ctxt c1 + k2 <- inferCoeffectTypeInContext s ctxt c2 return $ TyApp (TyApp (TyCon $ mkId "×") k1) k2 -inferCoeffectType s (CInterval c1 c2) = do - k1 <- inferCoeffectType s c1 - k2 <- inferCoeffectType s c2 +inferCoeffectTypeInContext s ctxt (CInterval c1 c2) = do + k1 <- inferCoeffectTypeInContext s ctxt c1 + k2 <- inferCoeffectTypeInContext s ctxt c2 case joinCoeffectTypes k1 k2 of Just k -> return $ TyApp (TyCon $ mkId "Interval") k - Nothing -> - halt $ KindError (Just s) $ "Interval grades do not match: `" <> pretty k1 - <> "` does not match with `" <> pretty k2 <> "`" + Nothing -> throw IntervalGradeKindError{ errLoc = s, errTy1 = k1, errTy2 = k2 } -- Take the join for compound coeffect epxressions -inferCoeffectType s (CPlus c c') = mguCoeffectTypes s c c' -inferCoeffectType s (CMinus c c') = mguCoeffectTypes s c c' -inferCoeffectType s (CTimes c c') = mguCoeffectTypes s c c' -inferCoeffectType s (CMeet c c') = mguCoeffectTypes s c c' -inferCoeffectType s (CJoin c c') = mguCoeffectTypes s c c' -inferCoeffectType s (CExpon c c') = mguCoeffectTypes s c c' +inferCoeffectTypeInContext s _ (CPlus c c') = mguCoeffectTypes s c c' +inferCoeffectTypeInContext s _ (CMinus c c') = mguCoeffectTypes s c c' +inferCoeffectTypeInContext s _ (CTimes c c') = mguCoeffectTypes s c c' +inferCoeffectTypeInContext s _ (CMeet c c') = mguCoeffectTypes s c c' +inferCoeffectTypeInContext s _ (CJoin c c') = mguCoeffectTypes s c c' +inferCoeffectTypeInContext s _ (CExpon c c') = mguCoeffectTypes s c c' -- Coeffect variables should have a type in the cvar->kind context -inferCoeffectType s (CVar cvar) = do +inferCoeffectTypeInContext s ctxt (CVar cvar) = do st <- get - case lookup cvar (tyVarContext st) of - Nothing -> do - halt $ UnboundVariableError (Just s) $ "Tried to look up kind of `" <> pretty cvar <> "`" - show (cvar,(tyVarContext st)) --- state <- get --- let newType = TyVar $ "ck" <> show (uniqueVarId state) - -- We don't know what it is yet though, so don't update the coeffect kind ctxt --- put (state { uniqueVarId = uniqueVarId state + 1 }) --- return newType - - - Just (KVar name, _) -> return $ TyVar name - Just (KPromote t, _) -> checkKindIsCoeffect s t - Just (k, _) -> illKindedNEq s KCoeffect k - -inferCoeffectType s (CZero t) = checkKindIsCoeffect s t -inferCoeffectType s (COne t) = checkKindIsCoeffect s t -inferCoeffectType s (CInfinity (Just t)) = checkKindIsCoeffect s t + case lookup cvar ctxt of + Nothing -> do + throw UnboundTypeVariable{ errLoc = s, errId = cvar } +-- state <- get +-- let newType = TyVar $ "ck" <> show (uniqueVarId state) + -- We don't know what it is yet though, so don't update the coeffect kind ctxt +-- put (state { uniqueVarId = uniqueVarId state + 1 }) +-- return newType + + Just (KVar name) -> return $ TyVar name + Just (KPromote t) -> checkKindIsCoeffect s ctxt t + Just k -> throw + KindMismatch{ errLoc = s, kExpected = KPromote (TyVar $ mkId "coeffectType"), kActual = k } + +inferCoeffectTypeInContext s ctxt (CZero t) = checkKindIsCoeffect s ctxt t +inferCoeffectTypeInContext s ctxt (COne t) = checkKindIsCoeffect s ctxt t +inferCoeffectTypeInContext s ctxt (CInfinity (Just t)) = checkKindIsCoeffect s ctxt t -- Unknown infinity defaults to the interval of extended nats version -inferCoeffectType s (CInfinity Nothing) = return (TyApp (TyCon $ mkId "Interval") extendedNat) -inferCoeffectType s (CSig _ t) = checkKindIsCoeffect s t +inferCoeffectTypeInContext s ctxt (CInfinity Nothing) = return (TyApp (TyCon $ mkId "Interval") extendedNat) +inferCoeffectTypeInContext s ctxt (CSig _ t) = checkKindIsCoeffect s ctxt t inferCoeffectTypeAssumption :: (?globals :: Globals) - => Span -> Assumption -> MaybeT Checker (Maybe Type) + => Span -> Assumption -> Checker (Maybe Type) inferCoeffectTypeAssumption _ (Linear _) = return Nothing inferCoeffectTypeAssumption s (Discharged _ c) = do t <- inferCoeffectType s c return $ Just t -checkKindIsCoeffect :: (?globals :: Globals) => Span -> Type -> MaybeT Checker Type -checkKindIsCoeffect span ty = do - kind <- inferKindOfType span ty +checkKindIsCoeffect :: (?globals :: Globals) => Span -> Ctxt Kind -> Type -> Checker Type +checkKindIsCoeffect span ctxt ty = do + kind <- inferKindOfTypeInContext span ctxt ty case kind of KCoeffect -> return ty -- Came out as a promoted type, check that this is a coeffect KPromote k -> do - kind' <- inferKindOfType span k + kind' <- inferKindOfTypeInContext span ctxt k case kind' of KCoeffect -> return ty - _ -> illKindedNEq span KCoeffect kind + _ -> throw KindMismatch{ errLoc = span, kExpected = KCoeffect, kActual = kind } + KVar v -> + case lookup v ctxt of + Just KCoeffect -> return ty + _ -> throw KindMismatch{ errLoc = span, kExpected = KCoeffect, kActual = kind } - _ -> illKindedNEq span KCoeffect kind + _ -> throw KindMismatch{ errLoc = span, kExpected = KCoeffect, kActual = kind } -- Find the most general unifier of two coeffects -- This is an effectful operation which can update the coeffect-kind -- contexts if a unification resolves a variable -mguCoeffectTypes :: (?globals :: Globals) => Span -> Coeffect -> Coeffect -> MaybeT Checker Type +mguCoeffectTypes :: (?globals :: Globals) => Span -> Coeffect -> Coeffect -> Checker Type mguCoeffectTypes s c1 c2 = do ck1 <- inferCoeffectType s c1 ck2 <- inferCoeffectType s c2 @@ -273,19 +246,16 @@ mguCoeffectTypes s c1 c2 = do (t, isProduct -> Just (t1, t2)) | t1 == t -> return $ ck2 (t, isProduct -> Just (t1, t2)) | t2 == t -> return $ ck2 - (k1, k2) -> halt $ KindError (Just s) $ "Cannot unify coeffect types '" - <> pretty k1 <> "' and '" <> pretty k2 - <> "' for coeffects `" <> pretty c1 <> "` and `" <> pretty c2 <> "`" + (k1, k2) -> throw CoeffectUnificationError + { errLoc = s, errTy1 = k1, errTy2 = k2, errC1 = c1, errC2 = c2 } -- Given a coeffect type variable and a coeffect kind, --- replace any occurence of that variable in an context --- and update the current solver predicate as well -updateCoeffectType :: Id -> Kind -> MaybeT Checker () +-- replace any occurence of that variable in a context +updateCoeffectType :: Id -> Kind -> Checker () updateCoeffectType tyVar k = do modify (\checkerState -> checkerState - { tyVarContext = rewriteCtxt (tyVarContext checkerState), - kVarContext = replace (kVarContext checkerState) tyVar k }) + { tyVarContext = rewriteCtxt (tyVarContext checkerState) }) where rewriteCtxt :: Ctxt (Kind, Quantifier) -> Ctxt (Kind, Quantifier) rewriteCtxt [] = [] diff --git a/frontend/src/Language/Granule/Checker/KindsImplicit.hs b/frontend/src/Language/Granule/Checker/KindsImplicit.hs new file mode 100644 index 000000000..ddef5ec1a --- /dev/null +++ b/frontend/src/Language/Granule/Checker/KindsImplicit.hs @@ -0,0 +1,141 @@ + +module Language.Granule.Checker.KindsImplicit where + +import Control.Monad.State.Strict + +import Language.Granule.Checker.Monad +import Language.Granule.Checker.Predicates +import Language.Granule.Checker.Primitives (tyOps) +import Language.Granule.Checker.SubstitutionContexts +import Language.Granule.Checker.Substitution +import Language.Granule.Checker.Kinds +import Language.Granule.Checker.Variables + +import Language.Granule.Syntax.Def +import Language.Granule.Syntax.Identifiers +import Language.Granule.Syntax.Pretty +import Language.Granule.Syntax.Span +import Language.Granule.Syntax.Type +import Language.Granule.Context +import Language.Granule.Utils + +-- | Check the kind of a definition +-- Currently we expect that a type scheme has kind KType +kindCheckDef :: (?globals :: Globals) => Def v t -> Checker (Def v t) +kindCheckDef (Def s id eqs (Forall s' quantifiedVariables constraints ty)) = do + -- Set up the quantified variables in the type variable context + modify (\st -> st { tyVarContext = map (\(n, c) -> (n, (c, ForallQ))) quantifiedVariables}) + + forM_ constraints $ \constraint -> do + (kind, _) <- inferKindOfTypeImplicits s quantifiedVariables constraint + case kind of + KPredicate -> return () + _ -> throw KindMismatch{ errLoc = s, kExpected = KPredicate, kActual = kind } + + (kind, unifiers) <- inferKindOfTypeImplicits s quantifiedVariables ty + case kind of + KType -> do + -- Rewrite the quantified variables with their possibly updated kinds (inferred) + qVars <- mapM (\(v, a) -> substitute unifiers a >>= (\b -> return (v, b))) + quantifiedVariables + modify (\st -> st { tyVarContext = [] }) + -- Update the def with the resolved quantifications + return (Def s id eqs (Forall s' qVars constraints ty)) + + --KPromote (TyCon k) | internalName k == "Protocol" -> modify (\st -> st { tyVarContext = [] }) + _ -> throw KindMismatch{ errLoc = s, kExpected = KType, kActual = kind } + +kindIsKind :: Kind -> Bool +kindIsKind (KPromote (TyCon (internalName -> "Kind"))) = True +kindIsKind _ = False + +-- Infers the kind of a type, but also allows some of the type variables to have poly kinds +-- which get automatically resolved +inferKindOfTypeImplicits :: (?globals :: Globals) => Span -> Ctxt Kind -> Type -> Checker (Kind, Substitution) + +inferKindOfTypeImplicits s ctxt (FunTy t1 t2) = do + (k1, u1) <- inferKindOfTypeImplicits s ctxt t1 + (k2, u2) <- inferKindOfTypeImplicits s ctxt t2 + case joinKind k1 KType of + Just (k1, u1') -> + case joinKind k2 KType of + Just (k2, u2') -> do + u <- combineManySubstitutions s [u1, u2, u1', u2'] + return (KType, u) + _ -> throw KindMismatch{ errLoc = s, kExpected = KType, kActual = k2 } + _ -> throw KindMismatch{ errLoc = s, kExpected = KType, kActual = k2 } + +-- kFun KType (KPromote (TyCon (internalName -> "Protocol"))) = return $ KPromote (TyCon (mkId "Protocol")) + +inferKindOfTypeImplicits s ctxt (TyCon conId) = do + st <- get + case lookup conId (typeConstructors st) of + Just (kind,_) -> return (kind, []) + Nothing -> case lookup conId (dataConstructors st) of + Just (Forall _ [] [] t, _) -> return (KPromote t, []) + Just _ -> error $ pretty s <> "I'm afraid I can't yet promote the polymorphic data constructor:" <> pretty conId + Nothing -> throw UnboundTypeConstructor{ errLoc = s, errId = conId } + +inferKindOfTypeImplicits s ctxt (Box c t) = do + _ <- inferCoeffectTypeInContext s ctxt c + (k, u) <- inferKindOfTypeImplicits s ctxt t + case joinKind k KType of + Just (k, u') -> do + u'' <- combineSubstitutions s u u' + return (KType, u'') + _ -> throw KindMismatch{ errLoc = s, kExpected = KType, kActual = k } + +inferKindOfTypeImplicits s ctxt (Diamond e t) = do + (k, u) <- inferKindOfTypeImplicits s ctxt t + case joinKind k KType of + Just (k, u') -> do + u'' <- combineSubstitutions s u u' + return (KType, u'') + _ -> throw KindMismatch{ errLoc = s, kExpected = KType, kActual = k } + +inferKindOfTypeImplicits s ctxt (TyVar tyVar) = + case lookup tyVar ctxt of + Just kind -> return (kind, []) + Nothing -> do + st <- get + case lookup tyVar (tyVarContext st) of + Just (kind, _) -> return (kind, []) + Nothing -> + throw UnboundTypeVariable{ errLoc = s, errId = tyVar } + +inferKindOfTypeImplicits s ctxt (TyApp t1 t2) = do + (k1, u1) <- inferKindOfTypeImplicits s ctxt t1 + case k1 of + KFun k1 k2 -> do + (kArg, u2) <- inferKindOfTypeImplicits s ctxt t2 + case (joinKind k1 kArg) of + Just (k, uk) -> do + u <- combineManySubstitutions s [u1, u2, uk] + k2' <- substitute u k2 + return (k2', u) + Nothing -> throw KindMismatch{ errLoc = s, kExpected = k1, kActual = kArg } + KVar v -> do + (kArg, u2) <- inferKindOfTypeImplicits s ctxt t2 + kResVar <- freshIdentifierBase $ "_kres" + let u = [(v, SubstK $ KFun (KVar $ mkId kResVar) kArg)] + uOut <- combineSubstitutions s u2 u + return (KVar $ mkId kResVar, uOut) + + _ -> throw KindMismatch{ errLoc = s, kExpected = KFun (KVar $ mkId "..") (KVar $ mkId ".."), kActual = k1 } + +inferKindOfTypeImplicits s ctxt (TyInt _) = return $ (kConstr $ mkId "Nat", []) + +inferKindOfTypeImplicits s ctxt (TyInfix (tyOps -> (k1exp, k2exp, kret)) t1 t2) = do + (k1act, u1) <- inferKindOfTypeImplicits s ctxt t1 + (k2act, u2) <- inferKindOfTypeImplicits s ctxt t2 + case joinKind k1act k1exp of + Just (k1, u3) -> + case joinKind k2act k2exp of + Just (k2, u4) -> do + u <- combineManySubstitutions s [u1, u2, u3, u4] + kret' <- substitute u kret + return (kret', u) + + Nothing -> throw KindMismatch{ errLoc = s, kExpected = k2exp, kActual = k2act} + Nothing -> throw KindMismatch{ errLoc = s, kExpected = k1exp, kActual = k1act} + diff --git a/frontend/src/Language/Granule/Checker/LaTeX.hs b/frontend/src/Language/Granule/Checker/LaTeX.hs index 4ed0449db..b27fd0396 100644 --- a/frontend/src/Language/Granule/Checker/LaTeX.hs +++ b/frontend/src/Language/Granule/Checker/LaTeX.hs @@ -11,6 +11,7 @@ instance Show Derivation where show (Node c premises) = "\\dfrac{" <> intercalate " \\quad " (map show premises) <> "}{" <> c <> "}" +mkDocument :: String -> String mkDocument doc = "\\documentclass{article}\ \\\usepackage{amsmath}\ diff --git a/frontend/src/Language/Granule/Checker/Monad.hs b/frontend/src/Language/Granule/Checker/Monad.hs index 321bd8c97..cf59c3e62 100644 --- a/frontend/src/Language/Granule/Checker/Monad.hs +++ b/frontend/src/Language/Granule/Checker/Monad.hs @@ -1,25 +1,37 @@ -- Defines the 'Checker' monad used in the type checker -- and various interfaces for working within this monad -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +{-# options_ghc -fno-warn-incomplete-uni-patterns #-} module Language.Granule.Checker.Monad where +import Data.Either (partitionEithers) +import Data.Foldable (toList) import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M +import Data.Semigroup (sconcat) import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Control.Monad.Fail (MonadFail) import Control.Monad.Identity -import Language.Granule.Checker.Errors +import Language.Granule.Checker.SubstitutionContexts import Language.Granule.Checker.LaTeX import Language.Granule.Checker.Predicates import qualified Language.Granule.Checker.Primitives as Primitives import Language.Granule.Context import Language.Granule.Syntax.Def +import Language.Granule.Syntax.Expr (Operator, Expr) import Language.Granule.Syntax.Helpers (FreshenerState(..), freshen) import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Type @@ -29,20 +41,47 @@ import Language.Granule.Syntax.Span import Language.Granule.Utils -- State of the check/synth functions -newtype Checker a = - Checker { unwrap :: StateT CheckerState IO a } - -evalChecker :: CheckerState -> Checker a -> IO a -evalChecker initialState = - flip evalStateT initialState . unwrap - -runChecker :: CheckerState -> Checker a -> IO (a, CheckerState) -runChecker initialState = - flip runStateT initialState . unwrap +newtype Checker a = Checker + { unChecker :: ExceptT (NonEmpty CheckerError) (StateT CheckerState IO) a } + deriving + ( Functor + , Applicative + , Monad + , MonadState CheckerState + , MonadError (NonEmpty CheckerError) + , MonadIO + , MonadFail + ) + +type CheckerResult r = Either (NonEmpty CheckerError) r + +evalChecker :: CheckerState -> Checker a -> IO (CheckerResult a) +evalChecker initialState (Checker k) = evalStateT (runExceptT k) initialState + +runChecker :: CheckerState -> Checker a -> IO (CheckerResult a, CheckerState) +runChecker initialState (Checker k) = runStateT (runExceptT k) initialState + +-- | Repeat a checker action for every input value and only fail at the end if +-- any action failed. +runAll :: (a -> Checker b) -> [a] -> Checker [b] +runAll f xs = do + st <- get + (results, st) <- liftIO $ runAllCheckers st (map f xs) + case partitionEithers results of + ([], successes) -> put st *> pure successes + -- everything succeeded, so `put` the state and carry on + (err:errs, _) -> throwError $ sconcat (err:|errs) + -- combine all errors and fail + where + runAllCheckers st [] = pure ([], st) + runAllCheckers st (c:cs) = do + (r, st) <- runChecker st c + (rs,st) <- runAllCheckers st cs + pure (r:rs, st) -- | Types of discharged coeffects -data Assumption = - Linear Type +data Assumption + = Linear Type | Discharged Type Coeffect deriving (Eq, Show) @@ -60,7 +99,7 @@ instance {-# OVERLAPS #-} Pretty (Id, Assumption) where -- foo _ = .. -- can be typed as foo : Int -> because the first means -- consumption is linear -data Consumption = Full | NotFull deriving (Eq, Show) +data Consumption = Full | NotFull | Empty deriving (Eq, Show) -- Given a set of equations, creates an intial vector to describe -- the consumption behaviour of the patterns (assumes that) @@ -74,6 +113,7 @@ initialisePatternConsumptions ((Equation _ _ pats _):_) = -- Join information about consumption between branches joinConsumption :: Consumption -> Consumption -> Consumption joinConsumption Full _ = Full +joinConsumption Empty Empty = Empty joinConsumption _ _ = NotFull -- Meet information about consumption, across patterns @@ -81,6 +121,10 @@ meetConsumption :: Consumption -> Consumption -> Consumption meetConsumption NotFull _ = NotFull meetConsumption _ NotFull = NotFull meetConsumption Full Full = Full +meetConsumption Empty Empty = Empty +meetConsumption Empty Full = NotFull +meetConsumption Full Empty = NotFull + data CheckerState = CS { -- Fresh variable id state @@ -97,10 +141,6 @@ data CheckerState = CS -- Type variable context, maps type variables to their kinds -- and their quantification , tyVarContext :: Ctxt (Kind, Quantifier) - -- Context of kind variables and their resolved kind - -- (used just before solver, to resolve any kind - -- variables that appear in constraints) - , kVarContext :: Ctxt Kind -- Guard contexts (all the guards in scope) -- which get promoted by branch promotions @@ -113,11 +153,14 @@ data CheckerState = CS -- Data type information , typeConstructors :: Ctxt (Kind, Cardinality) -- the kind of the and number of data constructors - , dataConstructors :: Ctxt TypeScheme + , dataConstructors :: Ctxt (TypeScheme, Substitution) -- LaTeX derivation , deriv :: Maybe Derivation , derivStack :: [Derivation] + + -- Warning accumulator + -- , warnings :: [Warning] } deriving (Show, Eq) -- for debugging @@ -127,8 +170,7 @@ initState = CS { uniqueVarIdCounterMap = M.empty , uniqueVarIdCounter = 0 , predicateStack = [] , guardPredicates = [[]] - , tyVarContext = emptyCtxt - , kVarContext = emptyCtxt + , tyVarContext = [] , guardContexts = [] , patternConsumption = [] , typeConstructors = Primitives.typeConstructors @@ -136,87 +178,74 @@ initState = CS { uniqueVarIdCounterMap = M.empty , deriv = Nothing , derivStack = [] } - where emptyCtxt = [] -- *** Various helpers for manipulating the context -{- | Useful if a checking procedure is needed which - may get discarded within a wider checking, e.g., for - resolving overloaded types via type equality. - The returned result is stateful but contains no - updates to the environment: it comprises a pair of - a pure result (i.e., evaluated and state discarded, and - a reification of the full state (with updates) should this - local checking be applied -} -localChecking :: MaybeT Checker b - -> MaybeT Checker (Maybe b, MaybeT Checker b) -localChecking k = do +{- | Given a computation in the checker monad, peek the result without +actually affecting the current checker environment. Unless the value is +discarded, the rhs result computation must be run! This is useful for +example when resolving overloaded operators, where we don't want to report +unification errors that arise during operator resultion to the user. +-} +peekChecker :: Checker a -> Checker (CheckerResult a, Checker ()) +peekChecker k = do checkerState <- get - (out, localState) <- liftIO $ runChecker checkerState (runMaybeT k) - let reified = do - put localState - MaybeT $ return out - return (out, reified) + (result, localState) <- liftIO $ runChecker checkerState k + pure (result, put localState) -pushGuardContext :: Ctxt Assumption -> MaybeT Checker () +pushGuardContext :: Ctxt Assumption -> Checker () pushGuardContext ctxt = do modify (\state -> state { guardContexts = ctxt : guardContexts state }) -popGuardContext :: MaybeT Checker (Ctxt Assumption) +popGuardContext :: Checker (Ctxt Assumption) popGuardContext = do state <- get - let (c:cs) = guardContexts state + let (c, cs) = case guardContexts state of + (c:cs) -> (c,cs) + [] -> error "Internal error. Empty guard context." put (state { guardContexts = cs }) return c -allGuardContexts :: MaybeT Checker (Ctxt Assumption) +allGuardContexts :: Checker (Ctxt Assumption) allGuardContexts = concat . guardContexts <$> get -- | Start a new conjunction frame on the predicate stack -newConjunct :: MaybeT Checker () +newConjunct :: Checker () newConjunct = do checkerState <- get put (checkerState { predicateStack = Conj [] : predicateStack checkerState }) -- | Creates a new "frame" on the stack of information about failed cases -- | This happens when we start a case expression -newCaseFrame :: MaybeT Checker () +newCaseFrame :: Checker () newCaseFrame = modify (\st -> st { guardPredicates = [] : guardPredicates st } ) -- | Pop (and don't return) the top of the failed case knowledge stack -- | This happens when we finish a case expression -popCaseFrame :: MaybeT Checker () +popCaseFrame :: Checker () popCaseFrame = modify (\st -> st { guardPredicates = tail (guardPredicates st) }) -- | Takes the top two conjunction frames and turns them into an --- impliciation +-- implication -- The first parameter is a list of any -- existential variables being introduced in this implication -concludeImplication :: (?globals :: Globals) => Span -> [Id] -> MaybeT Checker () -concludeImplication s localVars = do +concludeImplication :: Span -> Ctxt Kind -> Checker () +concludeImplication s localCtxt = do checkerState <- get case predicateStack checkerState of (p' : p : stack) -> do - -- Get all the kinds for the local variables - localCtxt <- forM localVars $ \v -> - case lookup v (tyVarContext checkerState) of - Just (k, _) -> return (v, k) - Nothing -> error $ "I don't know the kind of " - <> pretty v <> " in " - <> pretty (tyVarContext checkerState) - case guardPredicates checkerState of [] -> error "Internal bug: Guard predicate is [] and should not be" -- No previous guards in the current frame to provide additional information [] : knowledgeStack -> do - let impl = Impl localVars p p' + let impl = Impl localCtxt p p' -- Add the implication to the predicate stack modify (\st -> st { predicateStack = pushPred impl stack @@ -229,16 +258,18 @@ concludeImplication s localVars = do let previousGuardCtxt = concatMap (fst . fst) previousGuards let prevGuardPred = Conj (map (snd . fst) previousGuards) - -- negation of the previous guard - let guard' = foldr (uncurry Exists) (NegPred prevGuardPred) previousGuardCtxt - guard <- freshenPred guard' + freshenedPrevGuardPred <- freshenPred $ Impl previousGuardCtxt (Conj []) (NegPred prevGuardPred) + let (Impl freshPrevGuardCxt _ freshPrevGuardPred) = freshenedPrevGuardPred -- Implication of p .&& negated previous guards => p' - let impl = if (isTrivial prevGuardPred) - then Impl localVars p p' - else Impl localVars (Conj [p, guard]) p' + let impl@(Impl implCtxt implAntecedent _) = + -- TODO: turned off this feature for now by putting True in the guard here + if True -- isTrivial freshPrevGuardPred + then (Impl localCtxt p p') + else (Impl (localCtxt <> freshPrevGuardCxt) + (Conj [p, freshPrevGuardPred]) p') - let knowledge = ((localCtxt, p), s) : previousGuards + let knowledge = ((implCtxt, implAntecedent), s) : previousGuards -- Store `p` (impliciation antecedent) to use in later cases -- on the top of the guardPredicates stack @@ -249,22 +280,12 @@ concludeImplication s localVars = do _ -> error "Predicate: not enough conjunctions on the stack" -freshenPred :: Pred -> MaybeT Checker Pred -freshenPred pred = do - st <- get - -- Run the freshener using the checkers unique variable id - let (pred', freshenerState) = - runIdentity $ runStateT (freshen pred) - (FreshenerState { counter = 1 + uniqueVarIdCounter st, varMap = [], tyMap = []}) - -- Update the unique counter in the checker - put (st { uniqueVarIdCounter = counter freshenerState }) - return pred' {- -- Create a local existential scope -- NOTE: leaving this here, but this approach is not used and is incompataible -- with the way that existential variables are generated in the solver -- -existential :: (?globals :: Globals) => Id -> Kind -> MaybeT Checker () +existential :: (?globals :: Globals) => Id -> Kind -> Checker () existential var k = do case k of -- No need to add variables of kind Type to the predicate @@ -285,7 +306,7 @@ appendPred p (Conj ps) = Conj (p : ps) appendPred p (Exists var k ps) = Exists var k (appendPred p ps) appendPred _ p = error $ "Cannot append a predicate to " <> show p -addPredicate :: Pred -> MaybeT Checker () +addPredicate :: Pred -> Checker () addPredicate p = do checkerState <- get case predicateStack checkerState of @@ -295,7 +316,7 @@ addPredicate p = do put (checkerState { predicateStack = Conj [p] : stack }) -- | A helper for adding a constraint to the context -addConstraint :: Constraint -> MaybeT Checker () +addConstraint :: Constraint -> Checker () addConstraint c = do checkerState <- get case predicateStack checkerState of @@ -306,7 +327,7 @@ addConstraint c = do -- | A helper for adding a constraint to the previous frame (i.e.) -- | if I am in a local context, push it to the global -addConstraintToPreviousFrame :: Constraint -> MaybeT Checker () +addConstraintToPreviousFrame :: Constraint -> Checker () addConstraintToPreviousFrame c = do checkerState <- get case predicateStack checkerState of @@ -317,83 +338,408 @@ addConstraintToPreviousFrame c = do stack -> put (checkerState { predicateStack = Conj [Con c] : stack }) -illKindedUnifyVar :: (?globals :: Globals) => Span -> Type -> Kind -> Type -> Kind -> MaybeT Checker a -illKindedUnifyVar sp t1 k1 t2 k2 = - halt $ KindError (Just sp) $ - "Trying to unify a type `" - <> pretty t1 <> "` of kind " <> pretty k1 - <> " with a type `" - <> pretty t2 <> "` of kind " <> pretty k2 - -illKindedNEq :: (?globals :: Globals) => Span -> Kind -> Kind -> MaybeT Checker a -illKindedNEq sp k1 k2 = - halt $ KindError (Just sp) $ - "Expected kind `" <> pretty k1 <> "` but got `" <> pretty k2 <> "`" - -illLinearityMismatch :: (?globals :: Globals) => Span -> [LinearityMismatch] -> MaybeT Checker a -illLinearityMismatch sp mismatches = - halt $ LinearityError (Just sp) $ intercalate "\n " $ map mkMsg mismatches - where - mkMsg (LinearNotUsed v) = +-- | Convenience function for throwing a single error +throw :: CheckerError -> Checker a +throw = throwError . pure + +illLinearityMismatch :: Span -> NonEmpty LinearityMismatch -> Checker a +illLinearityMismatch sp ms = throwError $ fmap (LinearityError sp) ms + +{- Helpers for error messages and checker control flow -} +data CheckerError + = TypeError + { errLoc :: Span, tyExpected :: Type, tyActual :: Type } + | GradingError + { errLoc :: Span, errConstraint :: Neg Constraint } + | KindMismatch + { errLoc :: Span, kExpected :: Kind, kActual :: Kind } + | KindError + { errLoc :: Span, errTy :: Type, errK :: Kind } + | IntervalGradeKindError + { errLoc :: Span, errTy1 :: Type, errTy2 :: Type } + | LinearityError + { errLoc :: Span, linearityMismatch :: LinearityMismatch } + | PatternTypingError + { errLoc :: Span, errPat :: Pattern (), tyExpected :: Type } + | PatternTypingMismatch + { errLoc :: Span, errPat :: Pattern (), tyExpected :: Type, tyActual :: Type } + | PatternArityError + { errLoc :: Span, errId :: Id } + | UnboundVariableError + { errLoc :: Span, errId :: Id } + | UnboundTypeVariable + { errLoc :: Span, errId :: Id } + | RefutablePatternError + { errLoc :: Span, errPat :: Pattern () } + | TypeConstructorNameClash -- TODO: duplicate? + { errLoc :: Span, errId :: Id } + | DuplicateBindingError + { errLoc :: Span, duplicateBinding :: String } + | UnificationError + { errLoc :: Span, errTy1 :: Type, errTy2 :: Type } + | UnificationKindError + { errLoc :: Span, errTy1 :: Type, errK1 :: Kind, errTy2 :: Type, errK2 :: Kind } + | TypeVariableMismatch + { errLoc :: Span, errVar :: Id, errTy1 :: Type, errTy2 :: Type } + | UndefinedEqualityKindError + { errLoc :: Span, errTy1 :: Type, errK1 :: Kind, errTy2 :: Type, errK2 :: Kind } + | CoeffectUnificationError + { errLoc :: Span, errTy1 :: Type, errTy2 :: Type, errC1 :: Coeffect, errC2 :: Coeffect } + | DataConstructorTypeVariableNameClash + { errLoc :: Span, errDataConstructorId :: Id, errTypeConstructor :: Id, errVar :: Id } + | DataConstructorNameClashError + { errLoc :: Span, errId :: Id } + | EffectMismatch + { errLoc :: Span, effExpected :: Effect, effActual :: Effect } + | UnificationDisallowed + { errLoc :: Span, errTy1 :: Type, errTy2 :: Type } + | UnificationFail + { errLoc :: Span, errVar :: Id, errTy :: Type, errKind :: Kind } + | UnificationFailGeneric + { errLoc :: Span, errSubst1 :: Substitutors, errSubst2 :: Substitutors } + | OccursCheckFail + { errLoc :: Span, errVar :: Id, errTy :: Type } + | SessionDualityError + { errLoc :: Span, errTy1 :: Type, errTy2 :: Type } + | NoUpperBoundError + { errLoc :: Span, errTy1 :: Type, errTy2 :: Type } + | DisallowedCoeffectNesting + { errLoc :: Span, errTyOuter :: Type, errTyInner :: Type } + | UnboundDataConstructor + { errLoc :: Span, errId :: Id } + | UnboundTypeConstructor + { errLoc :: Span, errId :: Id } + | TooManyPatternsError + { errLoc :: Span, errPats :: NonEmpty (Pattern ()), tyExpected :: Type, tyActual :: Type } + | DataConstructorReturnTypeError + { errLoc :: Span, idExpected :: Id, idActual :: Id } + | MalformedDataConstructorType + { errLoc :: Span, errTy :: Type } + | ExpectedEffectType + { errLoc :: Span, errTy :: Type } + | LhsOfApplicationNotAFunction + { errLoc :: Span, errTy :: Type } + | FailedOperatorResolution + { errLoc :: Span, errOp :: Operator, errTy :: Type } + | NeedTypeSignature + { errLoc :: Span, errExpr :: Expr () () } + | SolverErrorCounterExample + { errLoc :: Span, errDefId :: Id, errPred :: Pred } + | SolverErrorFalsifiableTheorem + { errLoc :: Span, errDefId :: Id, errPred :: Pred } + | SolverError + { errLoc :: Span, errMsg :: String } + | SolverTimeout + { errLoc :: Span, errSolverTimeoutMillis :: Integer, errDefId :: Id, errContext :: String, errPred :: Pred } + | UnifyGradedLinear + { errLoc :: Span, errGraded :: Id, errLinear :: Id } + | ImpossiblePatternMatch + { errLoc :: Span, errId :: Id, errPred :: Pred } + | ImpossiblePatternMatchTrivial + { errLoc :: Span, errId :: Id, errUnsats :: [Constraint] } + | NameClashTypeConstructors -- we arbitrarily use the second thing that clashed as the error location + { errLoc :: Span, errDataDecl :: DataDecl, otherDataDecls :: NonEmpty DataDecl } + | NameClashDataConstructors -- we arbitrarily use the second thing that clashed as the error location + { errLoc :: Span, errDataConstructor :: DataConstr, otherDataConstructors :: NonEmpty DataConstr } + | NameClashDefs -- we arbitrarily use the second thing that clashed as the error location + { errLoc :: Span, errDef :: Def () (), otherDefs :: NonEmpty (Def () ()) } + | UnexpectedTypeConstructor + { errLoc :: Span, tyConExpected :: Id, tyConActual :: Id } + | InvalidTypeDefinition + { errLoc :: Span, errTy :: Type } + deriving (Show, Eq) + + +instance UserMsg CheckerError where + location = errLoc + + title TypeError{} = "Type error" + title GradingError{} = "Grading error" + title KindMismatch{} = "Kind mismatch" + title KindError{} = "Kind error" + title IntervalGradeKindError{} = "Interval kind error" + title LinearityError{} = "Linearity error" + title PatternTypingError{} = "Pattern typing error" + title PatternTypingMismatch{} = "Pattern typing mismatch" + title PatternArityError{} = "Pattern arity error" + title UnboundVariableError{} = "Unbound variable error" + title UnboundTypeVariable{} = "Unbound type variable" + title RefutablePatternError{} = "Pattern is refutable" + title TypeConstructorNameClash{} = "Type constructor name clash" + title DataConstructorTypeVariableNameClash{} = "Type variable name clash" + title DuplicateBindingError{} = "Duplicate binding" + title UnificationError{} = "Unification error" + title UnificationKindError{} = "Unification kind error" + title TypeVariableMismatch{} = "Type variable mismatch" + title UndefinedEqualityKindError{} = "Undefined kind equality" + title CoeffectUnificationError{} = "Coeffect unification error" + title DataConstructorNameClashError{} = "Data constructor name clash" + title EffectMismatch{} = "Effect mismatch" + title UnificationDisallowed{} = "Unification disallowed" + title UnificationFail{} = "Unification failed" + title UnificationFailGeneric{} = "Unification failed" + title OccursCheckFail{} = "Unification failed" + title SessionDualityError{} = "Session duality error" + title NoUpperBoundError{} = "Type upper bound" + title DisallowedCoeffectNesting{} = "Bad coeffect nesting" + title UnboundDataConstructor{} = "Unbound data constructor" + title UnboundTypeConstructor{} = "Unbound type constructor" + title TooManyPatternsError{} = "Too many patterns" + title DataConstructorReturnTypeError{} = "Wrong return type in data constructor" + title MalformedDataConstructorType{} = "Malformed data constructor type" + title ExpectedEffectType{} = "Type error" + title LhsOfApplicationNotAFunction{} = "Type error" + title FailedOperatorResolution{} = "Operator resolution failed" + title NeedTypeSignature{} = "Type signature needed" + title SolverErrorCounterExample{} = "Counter example" + title SolverErrorFalsifiableTheorem{} = "Falsifiable theorem" + title SolverError{} = "Solver error" + title SolverTimeout{} = "Solver timeout" + title UnifyGradedLinear{} = "Type error" + title ImpossiblePatternMatch{} = "Impossible pattern match" + title ImpossiblePatternMatchTrivial{} = "Impossible pattern match" + title NameClashTypeConstructors{} = "Type constructor name clash" + title NameClashDataConstructors{} = "Data constructor name clash" + title NameClashDefs{} = "Definition name clash" + title UnexpectedTypeConstructor{} = "Wrong return type in value constructor" + title InvalidTypeDefinition{} = "Invalid type definition" + + msg TypeError{..} = if pretty tyExpected == pretty tyActual + then "Expected `" <> pretty tyExpected <> "` but got `" <> pretty tyActual <> "` coming from a different binding" + else "Expected `" <> pretty tyExpected <> "` but got `" <> pretty tyActual <> "`" + + msg GradingError{ errConstraint } = pretty errConstraint + + msg KindMismatch{..} + = "Expected kind `" <> pretty kExpected <> "` but got `" <> pretty kActual <> "`" + + msg KindError{..} + = "Type `" <> pretty errTy + <> "` does not have expected kind `" <> pretty errK <> "`" + + msg IntervalGradeKindError{..} + = "Interval grade mismatch `" <> pretty errTy1 <> "` and `" <> pretty errTy2 <> "`" + + msg LinearityError{..} = case linearityMismatch of + LinearUsedMoreThanOnce v -> + "Linear variable `" <> pretty v <> "` is used more than once." + LinearNotUsed v -> "Linear variable `" <> pretty v <> "` is never used." - mkMsg (LinearUsedNonLinearly v) = - "Variable `" <> pretty v <> "` is promoted but its binding is linear; its binding should be under a box." - mkMsg NonLinearPattern = - "Wildcard pattern `_` allowing a value to be discarded in a position which requires linear use." - --- | A helper for raising an illtyped pattern (does pretty printing for you) -illTypedPattern :: (?globals :: Globals) => Span -> Type -> Pattern t -> MaybeT Checker a -illTypedPattern sp ty pat = - halt $ PatternTypingError (Just sp) $ - pretty pat <> " does not have expected type " <> pretty ty - --- | A helper for refutable pattern errors -refutablePattern :: (?globals :: Globals) => Span -> Pattern t -> MaybeT Checker a -refutablePattern sp p = - halt $ RefutablePatternError (Just sp) $ - "Pattern match " <> pretty p <> " can fail; only \ - \irrefutable patterns allowed in this context" - --- | A helper for non unifiable types -nonUnifiable :: (?globals :: Globals) => Span -> Type -> Type -> MaybeT Checker a -nonUnifiable s t1 t2 = - halt $ GenericError (Just s) $ - if pretty t1 == pretty t2 - then "Type `" <> pretty t1 <> "` is not unifiable with the type `" <> pretty t2 <> "` coming from a different binding" - else "Type `" <> pretty t1 <> "` is not unifiable with the type `" <> pretty t2 <> "`" - -typeClash :: (?globals :: Globals) => Span -> Type -> Type -> MaybeT Checker a -typeClash s t1 t2 = - halt $ GenericError (Just s) $ - if pretty t1 == pretty t2 - then "Expected `" <> pretty t1 <> "` but got `" <> pretty t2 <> "` coming from a different binding" - else "Expected `" <> pretty t1 <> "` but got `" <> pretty t2 <> "`" - --- | Helper for constructing error handlers -halt :: (?globals :: Globals) => CheckerError -> MaybeT Checker a -halt err = liftIO (printErr err) >> MaybeT (return Nothing) - -typeClashForVariable :: (?globals :: Globals) => Span -> Id -> Type -> Type -> MaybeT Checker a -typeClashForVariable s var t1 t2 = - halt $ GenericError (Just s) - $ "Variable " <> pretty var <> " is being used at two conflicting types " - <> "`" <> pretty t1 <> "` and `" <> pretty t2 <> "`" - --- Various interfaces for the checker -instance Monad Checker where - return = Checker . return - (Checker x) >>= f = Checker (x >>= (unwrap . f)) - -instance Functor Checker where - fmap f (Checker x) = Checker (fmap f x) - -instance Applicative Checker where - pure = return - f <*> x = f >>= \f' -> x >>= \x' -> return (f' x') - -instance MonadState CheckerState Checker where - get = Checker get - put s = Checker (put s) - -instance MonadIO Checker where - liftIO = Checker . lift + LinearUsedNonLinearly v -> + "Variable `" <> pretty v + <> "` is promoted but its binding is linear; its binding should be under a box." + NonLinearPattern -> + "Wildcard pattern `_` allowing a value to be discarded" + + msg PatternTypingError{..} + = "Pattern match `" + <> pretty errPat + <> "` does not have expected type `" + <> pretty tyExpected + <> "`" + + msg PatternTypingMismatch{..} + = "Expected type `" + <> pretty tyExpected + <> "` but got `" + <> pretty tyActual + <> "` in pattern `" + <> pretty errPat + <> "`" + + msg PatternArityError{..} + = "Data constructor `" + <> pretty errId + <> "` is applied to too many arguments." + + msg UnboundVariableError{..} = "`" <> pretty errId <> "`" + + msg UnboundTypeVariable{..} + = "`" <> pretty errId <> "` is not quantified" + + msg RefutablePatternError{..} + = "Pattern match " <> pretty errPat + <> " can fail; only irrefutable patterns allowed in this context" + + msg TypeConstructorNameClash{..} + = "Type constructor `" <> pretty errId <> "` already defined" + + msg DataConstructorTypeVariableNameClash{..} = mconcat + [ "Type variable " + , pretty errVar + , " in data constructor `" + , pretty errDataConstructorId + , "` are already bound by the associated type constructor `" + , pretty errTypeConstructor + , "`. Choose different, unbound names." + ] + + msg DuplicateBindingError { errLoc, duplicateBinding } + = "Variable `" <> duplicateBinding <> "` bound more than once." + + msg UnificationError{..} = if pretty errTy1 == pretty errTy2 + then "Type `" <> pretty errTy1 <> "` is not unifiable with the type `" <> pretty errTy2 <> "` coming from a different binding" + else "Type `" <> pretty errTy1 <> "` is not unifiable with the type `" <> pretty errTy2 <> "`" + + msg (OccursCheckFail _ var t) = + "Type variable `" <> pretty var <> "` cannot be unified with type `" + <> pretty t <> "` (occurs check failure; implies infinite type)." + + msg (UnificationKindError _ t1 k1 t2 k2) + = "Trying to unify a type `" + <> pretty t1 <> "` of kind " <> pretty k1 + <> " with a type `" + <> pretty t2 <> "` of kind " <> pretty k2 + + msg TypeVariableMismatch{..} + = "Variable " <> pretty errVar <> " is being used at two conflicting types " + <> "`" <> pretty errTy1 <> "` and `" <> pretty errTy2 <> "`" + + msg UndefinedEqualityKindError{..} + = "Equality is not defined between kinds " + <> pretty errK1 <> " and " <> pretty errK2 + <> "\t\n from equality " + <> "'" <> pretty errTy2 <> "' and '" <> pretty errTy1 <> "' equal." + + msg CoeffectUnificationError{..} + = "Cannot unify coeffect types '" + <> pretty errTy1 <> "' and '" <> pretty errTy2 + <> "' for coeffects `" <> pretty errC1 <> "` and `" <> pretty errC2 <> "`" + + msg DataConstructorNameClashError{..} + = "Data constructor `" <> pretty errId <> "` already defined." + + msg EffectMismatch{..} + = "Expected `" <> pretty effExpected + <> "`, but got `" <> pretty effActual <> "`" + + msg UnificationDisallowed{..} + = "Trying to unify `" + <> pretty errTy1 <> "` and `" + <> pretty errTy2 <> "` but in a context where unification is not allowed." + + msg UnificationFailGeneric{..} + = "Trying to unify `" <> pretty errSubst1 <> "` and `" <> pretty errSubst2 <> "`" + + msg UnificationFail{..} + = "Cannot unify universally quantified type variable `" <> pretty errVar <> "`" + <> "` of kind `" <> pretty errKind <> "` with a concrete type `" <> pretty errTy <> "`" + + msg SessionDualityError{..} + = "Session type `" <> pretty errTy1 <> "` is not dual to `" <> pretty errTy2 <> "`" + + msg NoUpperBoundError{..} + = "Types `" <> pretty errTy1 <> "` and `" + <> pretty errTy2 <> "` have no upper bound" + + msg DisallowedCoeffectNesting{..} + = "Graded modalities of outer index type `" <> pretty errTyOuter + <> "` and inner type `" <> pretty errTyInner <> "` cannot be nested" + + msg UnboundDataConstructor{..} + = "`" <> pretty errId <> "`" + + msg UnboundTypeConstructor{..} + = "`" <> pretty errId <> "`" + + msg TooManyPatternsError{..} + = "Couldn't match expected type `" + <> pretty tyExpected + <> "` against a type of the form `" + <> pretty tyActual + <> "` implied by the remaining pattern(s)\n\t" + <> (intercalate "\n\t" . map (ticks . pretty) . toList) errPats + + msg DataConstructorReturnTypeError{..} + = "Expected type constructor `" <> pretty idExpected + <> "`, but got `" <> pretty idActual <> "`" + + msg MalformedDataConstructorType{..} + = "`" <> pretty errTy <> "` not valid in a data constructor definition" + + msg ExpectedEffectType{..} + = "Expected a type of the form `a ` but got `" + <> pretty errTy <> "` in subject of let" + + msg LhsOfApplicationNotAFunction{..} + = "Expected a function type on the left-hand side of an application, but got `" + <> pretty errTy <> "`" + + msg FailedOperatorResolution{..} + = "Could not resolve operator `" <> pretty errOp + <> "` at type `" <> pretty errTy <> "`" + + msg NeedTypeSignature{..} + = "The type could not be inferred, please add a type signature to expression `" + <> pretty errExpr <> "`" + + msg SolverErrorCounterExample{..} + = "The following theorem associated with `" <> pretty errDefId + <> "` is falsifiable:\n\t" + <> pretty errPred + + msg SolverErrorFalsifiableTheorem{..} + = "The following theorem associated with `" <> pretty errDefId + <> "` is falsifiable:\n\t" + <> pretty errPred + + msg SolverError{..} = errMsg + + msg SolverTimeout{errSolverTimeoutMillis, errDefId, errContext, errPred} + = "Solver timed out with limit of " <> show errSolverTimeoutMillis + <> "ms while checking the " <> errContext <> " of definition `" <> pretty errDefId + <> "` with the following theorem:\n" + <> pretty errPred + <> "\nYou may want to increase the timeout (see --help)." + + msg UnifyGradedLinear{..} + = "Can't unify free-variable types:\n\t" + <> "(graded) " <> pretty errGraded + <> "\n with\n\t(linear) " <> pretty errLinear + + msg ImpossiblePatternMatch{ errId, errPred } + = "Pattern match in an equation of `" <> pretty errId + <> "` is impossible as it implies the unsatisfiable condition " + <> pretty errPred + + msg ImpossiblePatternMatchTrivial{ errId, errUnsats } + = "Pattern match in an equation of `" <> pretty errId + <> "` is impossible as it implies the unsatisfiable condition " + <> unlines (map pretty errUnsats) + + msg NameClashTypeConstructors{..} + = "`" <> pretty (dataDeclId errDataDecl) <> "` already defined at\n\t" + <> (intercalate "\n\t" . map (pretty . dataDeclSpan) . toList) otherDataDecls + + msg NameClashDataConstructors{..} + = "`" <> pretty (dataConstrId errDataConstructor) <> "` already defined at\n\t" + <> (intercalate "\n\t" . map (pretty . dataConstrSpan) . toList) otherDataConstructors + + msg NameClashDefs{..} + = "`" <> pretty (defId errDef) <> "` already defined at\n\t" + <> (intercalate "\n\t" . map (pretty . defSpan) . toList) otherDefs + + msg UnexpectedTypeConstructor{ tyConActual, tyConExpected } + = "Expected type constructor `" <> pretty tyConExpected + <> "`, but got `" <> pretty tyConActual <> "`" + + msg InvalidTypeDefinition{ errTy } + = "The type `" <> pretty errTy <> "` is not valid in a datatype definition." + +data LinearityMismatch + = LinearNotUsed Id + | LinearUsedNonLinearly Id + | NonLinearPattern + | LinearUsedMoreThanOnce Id + deriving (Eq, Show) -- for debugging + +freshenPred :: Pred -> Checker Pred +freshenPred pred = do + st <- get + -- Run the freshener using the checkers unique variable id + let (pred', freshenerState) = + runIdentity $ runStateT (freshen pred) + (FreshenerState { counter = 1 + uniqueVarIdCounter st, varMap = [], tyMap = []}) + -- Update the unique counter in the checker + put (st { uniqueVarIdCounter = counter freshenerState }) + return pred' \ No newline at end of file diff --git a/frontend/src/Language/Granule/Checker/NameClash.hs b/frontend/src/Language/Granule/Checker/NameClash.hs new file mode 100644 index 000000000..41e05c8a0 --- /dev/null +++ b/frontend/src/Language/Granule/Checker/NameClash.hs @@ -0,0 +1,52 @@ +module Language.Granule.Checker.NameClash where + +import Control.Monad.Except (throwError) +import Data.List.NonEmpty (NonEmpty(..)) +import Language.Granule.Checker.Monad +import Language.Granule.Syntax.Def +import Language.Granule.Syntax.Identifiers +import Language.Granule.Utils + +-- | Check if there are name clashes within namespaces +checkNameClashes :: AST () () -> Checker () +checkNameClashes (AST dataDecls defs _) = + case concat [typeConstructorErrs, dataConstructorErrs, defErrs] of + [] -> pure () + (d:ds) -> throwError (d:|ds) + where + typeConstructorErrs + = fmap mkTypeConstructorErr + . duplicatesBy (sourceName . dataDeclId) + $ dataDecls + + mkTypeConstructorErr (x2, xs) + = NameClashTypeConstructors + { errLoc = dataDeclSpan x2 + , errDataDecl = x2 + , otherDataDecls = xs + } + + dataConstructorErrs + = fmap mkDataConstructorErr -- make errors for duplicates + . duplicatesBy (sourceName . dataConstrId) -- get the duplicates by source id + . concatMap dataDeclDataConstrs -- get data constructor definitions + $ dataDecls -- from data declarations + + mkDataConstructorErr (x2, xs) + = NameClashDataConstructors + { errLoc = dataConstrSpan x2 + , errDataConstructor = x2 + , otherDataConstructors = xs + } + + defErrs + = fmap mkDuplicateDefErr + . duplicatesBy (sourceName . defId) + $ defs + + mkDuplicateDefErr (x2, xs) + = NameClashDefs + { errLoc = defSpan x2 + , errDef = x2 + , otherDefs = xs + } \ No newline at end of file diff --git a/frontend/src/Language/Granule/Checker/Patterns.hs b/frontend/src/Language/Granule/Checker/Patterns.hs index a72a8177a..331a128b5 100644 --- a/frontend/src/Language/Granule/Checker/Patterns.hs +++ b/frontend/src/Language/Granule/Checker/Patterns.hs @@ -1,19 +1,21 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ViewPatterns #-} +{-# options_ghc -fno-warn-incomplete-uni-patterns #-} module Language.Granule.Checker.Patterns where -import Control.Monad.Trans.Maybe +import Control.Monad.Except (throwError) import Control.Monad.State.Strict -import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty(..)) -import Language.Granule.Checker.Errors +import Language.Granule.Checker.Constraints.Compile import Language.Granule.Checker.Types (equalTypesRelatedCoeffectsAndUnify, SpecIndicator(..)) import Language.Granule.Checker.Coeffects import Language.Granule.Checker.Monad import Language.Granule.Checker.Predicates import Language.Granule.Checker.Kinds -import Language.Granule.Checker.Substitutions +import Language.Granule.Checker.SubstitutionContexts +import Language.Granule.Checker.Substitution import Language.Granule.Checker.Variables import Language.Granule.Context @@ -30,15 +32,15 @@ definiteUnification :: (?globals :: Globals) => Span -> Maybe (Coeffect, Type) -- Outer coeffect -> Type -- Type of the pattern - -> MaybeT Checker () + -> Checker () definiteUnification _ Nothing _ = return () definiteUnification s (Just (coeff, coeffTy)) ty = do isPoly <- polyShaped ty - when isPoly $ - addConstraintToPreviousFrame $ ApproximatedBy s (COne coeffTy) coeff coeffTy + when isPoly $ -- Used to be: addConstraintToPreviousFrame, but paper showed this was not a good idea + addConstraint $ ApproximatedBy s (COne coeffTy) coeff coeffTy -- | Predicate on whether a type has more than 1 shape (constructor) -polyShaped :: (?globals :: Globals) => Type -> MaybeT Checker Bool +polyShaped :: (?globals :: Globals) => Type -> Checker Bool polyShaped t = case leftmostOfApplication t of TyCon k -> do mCardinality <- lookup k <$> gets typeConstructors @@ -61,28 +63,28 @@ polyShaped t = case leftmostOfApplication t of -- | Given a pattern and its type, construct Just of the binding context -- for that pattern, or Nothing if the pattern is not well typed -- Returns also: --- - a list of any variables bound by the pattern --- (e.g. for dependent matching) +-- - a context of any variables bound by the pattern +-- (e.g. for dependent matching) with their kinds -- - a substitution for variables -- caused by pattern matching (e.g., from unification), -- - a consumption context explaining usage triggered by pattern matching -ctxtFromTypedPattern :: (?globals :: Globals, Show t) => +ctxtFromTypedPattern :: (?globals :: Globals) => Span -> Type - -> Pattern t + -> Pattern () -> Consumption -- Consumption behaviour of the patterns in this position so far - -> MaybeT Checker (Ctxt Assumption, [Id], Substitution, Pattern Type, Consumption) + -> Checker (Ctxt Assumption, Ctxt Kind, Substitution, Pattern Type, Consumption) ctxtFromTypedPattern = ctxtFromTypedPattern' Nothing -- | Inner helper, which takes information about the enclosing coeffect -ctxtFromTypedPattern' :: (?globals :: Globals, Show t) => +ctxtFromTypedPattern' :: (?globals :: Globals) => Maybe (Coeffect, Type) -- enclosing coeffect -> Span -> Type - -> Pattern t + -> Pattern () -> Consumption -- Consumption behaviour of the patterns in this position so far - -> MaybeT Checker (Ctxt Assumption, [Id], Substitution, Pattern Type, Consumption) + -> Checker (Ctxt Assumption, Ctxt Kind, Substitution, Pattern Type, Consumption) -- Pattern matching on wild cards and variables (linear) ctxtFromTypedPattern' outerCoeff _ t (PWild s _) cons = @@ -98,8 +100,13 @@ ctxtFromTypedPattern' outerCoeff _ t (PWild s _) cons = -- add a constraint that 0 approaximates the effect of the enclosing -- box patterns. case outerCoeff of - -- Cannot have a wildcard not under a box - Nothing -> illLinearityMismatch s [NonLinearPattern] + -- Can only have a wildcard under a box if the type of the pattern is unishaped + Nothing -> do + isPoly <- polyShaped t + if isPoly + then illLinearityMismatch s (pure NonLinearPattern) + else return ([], [], [], PWild s t, Full) + Just (coeff, coeffTy) -> do -- Must approximate zero addConstraint $ ApproximatedBy s (CZero coeffTy) coeff coeffTy @@ -140,16 +147,16 @@ ctxtFromTypedPattern' outerBoxTy s t@(Box coeff ty) (PBox sp _ p) _ = do innerBoxTy <- inferCoeffectType s coeff (coeff, coeffTy) <- case outerBoxTy of - -- Case: no enclosing [ ] pattern - Nothing -> return (coeff, innerBoxTy) - -- Case: there is an enclosing [ ] pattern of type outerBoxTy - Just (outerCoeff, outerBoxTy) -> - -- Therefore try and flatten at this point - case flattenable outerBoxTy innerBoxTy of - Just (flattenOp, ty) -> return (flattenOp outerCoeff coeff, ty) - Nothing -> halt $ GenericError (Just s) - $ "Graded modalities of index type `" <> pretty outerBoxTy - <> "` and `" <> pretty innerBoxTy <> "` cannot be nested." + -- Case: no enclosing [ ] pattern + Nothing -> return (coeff, innerBoxTy) + -- Case: there is an enclosing [ ] pattern of type outerBoxTy + Just (outerCoeff, outerBoxTy) -> + -- Therefore try and flatten at this point + case flattenable outerBoxTy innerBoxTy of + Just (flattenOp, ty) -> return (flattenOp outerCoeff coeff, ty) + Nothing -> throw DisallowedCoeffectNesting + { errLoc = s, errTyOuter = outerBoxTy, errTyInner = innerBoxTy } + (ctxt, eVars, subst, elabPinner, consumption) <- ctxtFromTypedPattern' (Just (coeff, coeffTy)) s ty p Full @@ -161,82 +168,120 @@ ctxtFromTypedPattern' outerBoxTy _ ty p@(PConstr s _ dataC ps) cons = do st <- get case lookup dataC (dataConstructors st) of - Nothing -> - halt $ UnboundVariableError (Just s) $ - "Data constructor `" <> pretty dataC <> "`" show (dataConstructors st) - Just tySch -> do - definiteUnification s outerBoxTy ty + Nothing -> throw UnboundDataConstructor{ errLoc = s, errId = dataC } + Just (tySch, coercions) -> do - (dataConstructorTypeFresh, freshTyVars, []) <- - freshPolymorphicInstance BoundQ True tySch - -- TODO: don't allow constraints in data constructors yet + definiteUnification s outerBoxTy ty - areEq <- equalTypesRelatedCoeffectsAndUnify s Eq True PatternCtxt (resultType dataConstructorTypeFresh) ty + (dataConstructorTypeFresh, freshTyVarsCtxt, freshTyVarSubst, constraints, coercions') <- + freshPolymorphicInstance BoundQ True tySch coercions + + mapM_ (\ty -> do + pred <- compileTypeConstraintToConstraint s ty + addPredicate pred) constraints + + -- Debugging + debugM "ctxt" $ "### DATA CONSTRUCTOR (" <> pretty dataC <> ")" + <> "\n###\t tySch = " <> pretty tySch + <> "\n###\t coercions = " <> show coercions + <> "\n###\n" + debugM "ctxt" $ "\n### FRESH POLY ###\n####\t dConTyFresh = " + <> show dataConstructorTypeFresh + <> "\n###\t ctxt = " <> show freshTyVarsCtxt + <> "\n###\t freshTyVarSubst = " <> show freshTyVarSubst + <> "\n###\t coercions' = " <> show coercions' + + dataConstructorTypeFresh <- substitute (flipSubstitution coercions') dataConstructorTypeFresh + + st <- get + debugM "ctxt" $ "### tyVarContext = " <> show (tyVarContext st) + debugM "ctxt" $ "\t### eqL (res dCfresh) = " <> show (resultType dataConstructorTypeFresh) <> "\n" + debugM "ctxt" $ "\t### eqR (ty) = " <> show ty <> "\n" + + debugM "Patterns.ctxtFromTypedPattern" $ pretty dataConstructorTypeFresh <> "\n" <> pretty ty + areEq <- equalTypesRelatedCoeffectsAndUnify s Eq PatternCtxt (resultType dataConstructorTypeFresh) ty case areEq of (True, _, unifiers) -> do - dataConstrutorSpecialised <- substitute unifiers dataConstructorTypeFresh + -- Register coercions as equalities + mapM_ (\(var, SubstT ty) -> + equalTypesRelatedCoeffectsAndUnify s Eq PatternCtxt (TyVar var) ty) coercions' - (t,(as, bs, us, elabPs, consumptionOut)) <- unpeel ps dataConstrutorSpecialised - subst <- combineSubstitutions s unifiers us - (ctxtSubbed, ctxtUnsubbed) <- substCtxt subst as + dataConstructorIndexRewritten <- substitute unifiers dataConstructorTypeFresh + dataConstructorIndexRewrittenAndSpecialised <- substitute coercions' dataConstructorIndexRewritten - let elabP = PConstr s ty dataC elabPs - return (ctxtSubbed <> ctxtUnsubbed, freshTyVars<>bs, subst, elabP, consumptionOut) + -- Debugging + debugM "ctxt" $ "\n\t### unifiers = " <> show unifiers <> "\n" + debugM "ctxt" $ "### dfresh = " <> show dataConstructorTypeFresh + debugM "ctxt" $ "### drewrit = " <> show dataConstructorIndexRewritten + debugM "ctxt" $ "### drewritAndSpec = " <> show dataConstructorIndexRewrittenAndSpecialised <> "\n" + + (as, bs, us, elabPs, consumptionOut) <- unpeel ps dataConstructorIndexRewrittenAndSpecialised - _ -> halt $ PatternTypingError (Just s) $ - "Expected type `" <> pretty ty <> "` but got `" <> pretty dataConstructorTypeFresh <> "`" + -- Combine the substitutions + subst <- combineSubstitutions s (flipSubstitution unifiers) us + subst <- combineSubstitutions s coercions' subst + debugM "ctxt" $ "\n\t### outSubst = " <> show subst <> "\n" + + -- (ctxtSubbed, ctxtUnsubbed) <- substCtxt subst as + + let elabP = PConstr s ty dataC elabPs + return (as, -- ctxtSubbed <> ctxtUnsubbed, -- concatenate the contexts + freshTyVarsCtxt <> bs, -- concat the context of new type variables + subst, -- returned the combined substitution + elabP, -- elaborated pattern + consumptionOut) -- final consumption effect + + _ -> throw PatternTypingMismatch + { errLoc = s + , errPat = p + , tyExpected = dataConstructorTypeFresh + , tyActual = ty + } where - unpeel :: Show t - -- A list of patterns for each part of a data constructor pattern - => [Pattern t] - -- The remaining type of the constructor - -> Type - -> MaybeT Checker (Type, ([(Id, Assumption)], [Id], Substitution, [Pattern Type], Consumption)) + unpeel :: [Pattern ()] -- A list of patterns for each part of a data constructor pattern + -> Type -- The remaining type of the constructor + -> Checker (Ctxt Assumption, Ctxt Kind, Substitution, [Pattern Type], Consumption) unpeel = unpeel' ([],[],[],[],Full) - -- Tail recursive version of unpell - unpeel' acc [] t = return (t,acc) + -- Tail recursive version of unpeel + unpeel' acc [] t = return acc unpeel' (as,bs,us,elabPs,consOut) (p:ps) (FunTy t t') = do (as',bs',us',elabP, consOut') <- ctxtFromTypedPattern' outerBoxTy s t p cons us <- combineSubstitutions s us us' unpeel' (as<>as', bs<>bs', us, elabP:elabPs, consOut `meetConsumption` consOut') ps t' - unpeel' _ (p:_) t = halt $ PatternTypingError (Just s) $ - "Have you applied constructor `" <> sourceName dataC <> - "` to too many arguments?" - + unpeel' _ (p:_) t = throw PatternArityError{ errLoc = s, errId = dataC } ctxtFromTypedPattern' _ s t p _ = do st <- get debugM "ctxtFromTypedPattern" $ "Type: " <> show t <> "\nPat: " <> show p debugM "dataConstructors in checker state" $ show $ dataConstructors st - halt $ PatternTypingError (Just s) - $ "Pattern match `" <> pretty p <> "` does not match expected type `" <> pretty t <> "`" - -ctxtFromTypedPatterns :: (?globals :: Globals, Show t) + throw PatternTypingError{ errLoc = s, errPat = p, tyExpected = t } +ctxtFromTypedPatterns :: (?globals :: Globals) => Span -> Type - -> [Pattern t] + -> [Pattern ()] -> [Consumption] - -> MaybeT Checker (Ctxt Assumption, Type, [Id], Substitution, [Pattern Type], [Consumption]) + -> Checker (Ctxt Assumption, Type, Ctxt Kind, Substitution, [Pattern Type], [Consumption]) ctxtFromTypedPatterns sp ty [] _ = do - debugM "Patterns.ctxtFromTypedPatterns" $ "Called with span: " <> show sp <> "\ntype: " <> show ty return ([], ty, [], [], [], []) ctxtFromTypedPatterns s (FunTy t1 t2) (pat:pats) (cons:consumptionsIn) = do - -- TODO: when we have dependent matching at the function clause - -- level, we will need to pay attention to the bound variables here + + -- Match a pattern (localGam, eVars, subst, elabP, consumption) <- ctxtFromTypedPattern s t1 pat cons + -- Match the rest (localGam', ty, eVars', substs, elabPs, consumptions) <- ctxtFromTypedPatterns s t2 pats consumptionsIn + -- Combine the results substs' <- combineSubstitutions s subst substs return (localGam <> localGam', ty, eVars ++ eVars', substs', elabP : elabPs, consumption : consumptions) -ctxtFromTypedPatterns s ty ps _ = do +ctxtFromTypedPatterns s ty (p:ps) _ = do -- This means we have patterns left over, but the type is not a -- function type, so we need to throw a type error @@ -245,15 +290,14 @@ ctxtFromTypedPatterns s ty ps _ = do -- p0 -> p1 -> ? psTyVars <- mapM (\_ -> freshIdentifierBase "?" >>= return . TyVar . mkId) ps let spuriousType = foldr FunTy (TyVar $ mkId "?") psTyVars - halt $ GenericError (Just s) - $ "Too many patterns.\n Therefore, couldn't match expected type '" - <> pretty ty - <> "'\n against a type of the form '" <> pretty spuriousType - <> "' implied by the remaining patterns" - -duplicateBinderCheck :: (?globals::Globals) => Span -> [Pattern a] -> MaybeT Checker () -duplicateBinderCheck s ps = unless (null duplicateBinders) $ - halt $ DuplicatePatternError (Just s) $ intercalate ", " duplicateBinders + throw TooManyPatternsError + { errLoc = s, errPats = p :| ps, tyExpected = ty, tyActual = spuriousType } + +duplicateBinderCheck :: Span -> [Pattern a] -> Checker () +duplicateBinderCheck s ps = case duplicateBinders of + [] -> pure () + (d:ds) -> + throwError $ fmap (DuplicateBindingError s) (d :| ds) where duplicateBinders = duplicates . concatMap getBinders $ ps getBinders = patternFold diff --git a/frontend/src/Language/Granule/Checker/Predicates.hs b/frontend/src/Language/Granule/Checker/Predicates.hs index 88856c930..ce6139577 100644 --- a/frontend/src/Language/Granule/Checker/Predicates.hs +++ b/frontend/src/Language/Granule/Checker/Predicates.hs @@ -62,6 +62,8 @@ data Constraint = -- Used for arbitrary predicates (not from the rest of type checking) | Lt Span Coeffect Coeffect -- Must be Nat kinded | Gt Span Coeffect Coeffect -- Must be Nat kinded + | LtEq Span Coeffect Coeffect -- Must be Nat kinded + | GtEq Span Coeffect Coeffect -- Must be Nat kinded deriving (Show, Eq, Generic) @@ -74,6 +76,8 @@ normaliseConstraint (ApproximatedBy s c1 c2 t) = ApproximatedBy s (normalise c1) normaliseConstraint (NonZeroPromotableTo s x c t) = NonZeroPromotableTo s x (normalise c) t normaliseConstraint (Lt s c1 c2) = Lt s (normalise c1) (normalise c2) normaliseConstraint (Gt s c1 c2) = Gt s (normalise c1) (normalise c2) +normaliseConstraint (LtEq s c1 c2) = LtEq s (normalise c1) (normalise c2) +normaliseConstraint (GtEq s c1 c2) = GtEq s (normalise c1) (normalise c2) instance Monad m => Freshenable m Constraint where freshen (Eq s' c1 c2 k) = do @@ -106,9 +110,12 @@ instance Monad m => Freshenable m Constraint where c2 <- freshen c2 return $ Gt s c1 c2 + freshen (LtEq s c1 c2) = LtEq s <$> freshen c1 <*> freshen c2 + freshen (GtEq s c1 c2) = GtEq s <$> freshen c1 <*> freshen c2 + -- Used to negate constraints -data Neg a = Neg a - deriving Show +newtype Neg a = Neg a + deriving (Eq, Show) instance Pretty (Neg Constraint) where prettyL l (Neg (Neq _ c1 c2 _)) = @@ -133,6 +140,12 @@ instance Pretty (Neg Constraint) where prettyL l (Neg (Gt _ c1 c2)) = "Trying to prove false statement: (" <> prettyL l c1 <> " > " <> prettyL l c2 <> ")" + prettyL l (Neg (LtEq _ c1 c2)) = + "Trying to prove false statement: (" <> prettyL l c1 <> " ≤ " <> prettyL l c2 <> ")" + + prettyL l (Neg (GtEq _ c1 c2)) = + "Trying to prove false statement: (" <> prettyL l c1 <> " ≥ " <> prettyL l c2 <> ")" + instance Pretty [Constraint] where prettyL l constr = "---\n" <> (intercalate "\n" . map (prettyL l) $ constr) @@ -144,8 +157,11 @@ instance Pretty Constraint where prettyL l (Neq _ c1 c2 _) = "(" <> prettyL l c1 <> " ≠ " <> prettyL l c2 <> ")" -- @" <> show s - prettyL l (ApproximatedBy _ c1 c2 _) = - "(" <> prettyL l c1 <> " ≤ " <> prettyL l c2 <> ")" -- @" <> show s + prettyL l (ApproximatedBy _ c1 c2 k) = + case k of + -- Nat is discrete + TyCon (internalName -> "Nat") -> "(" <> prettyL l c1 <> " = " <> prettyL l c2 <> ")" + _ -> "(" <> prettyL l c1 <> " ≤ " <> prettyL l c2 <> ")" -- @" <> show s prettyL l (Lt _ c1 c2) = "(" <> prettyL l c1 <> " < " <> prettyL l c2 <> ")" @@ -153,6 +169,12 @@ instance Pretty Constraint where prettyL l (Gt _ c1 c2) = "(" <> prettyL l c1 <> " > " <> prettyL l c2 <> ")" + prettyL l (LtEq _ c1 c2) = + "(" <> prettyL l c1 <> " ≤ " <> prettyL l c2 <> ")" + + prettyL l (GtEq _ c1 c2) = + "(" <> prettyL l c1 <> " ≥ " <> prettyL l c2 <> ")" + prettyL l (NonZeroPromotableTo _ _ c _) = "TODO" @@ -163,24 +185,26 @@ varsConstraint (ApproximatedBy _ c1 c2 _) = freeVars c1 <> freeVars c2 varsConstraint (NonZeroPromotableTo _ _ c _) = freeVars c varsConstraint (Lt _ c1 c2) = freeVars c1 <> freeVars c2 varsConstraint (Gt _ c1 c2) = freeVars c1 <> freeVars c2 +varsConstraint (LtEq _ c1 c2) = freeVars c1 <> freeVars c2 +varsConstraint (GtEq _ c1 c2) = freeVars c1 <> freeVars c2 -- Represents a predicate generated by the type checking algorithm data Pred where Conj :: [Pred] -> Pred Disj :: [Pred] -> Pred - Impl :: [Id] -> Pred -> Pred -> Pred + Impl :: Ctxt Kind -> Pred -> Pred -> Pred Con :: Constraint -> Pred NegPred :: Pred -> Pred Exists :: Id -> Kind -> Pred -> Pred -vars :: Pred -> [Id] -vars (Conj ps) = concatMap vars ps -vars (Disj ps) = concatMap vars ps -vars (Impl bounds p1 p2) = (vars p1 <> vars p2) \\ bounds -vars (Con c) = varsConstraint c -vars (NegPred p) = vars p -vars (Exists x _ p) = vars p \\ [x] +instance Term Pred where + freeVars (Conj ps) = concatMap freeVars ps + freeVars (Disj ps) = concatMap freeVars ps + freeVars (Impl bounds p1 p2) = (freeVars p1 <> freeVars p2) \\ map fst bounds + freeVars (Con c) = varsConstraint c + freeVars (NegPred p) = freeVars p + freeVars (Exists x _ p) = freeVars p \\ [x] instance (Monad m, MonadFail m) => Freshenable m Pred where freshen (Conj ps) = do @@ -217,7 +241,7 @@ instance (Monad m, MonadFail m) => Freshenable m Pred where p2' <- freshen p2 return $ Impl [] p1' p2' - freshen (Impl (v:vs) p p') = do + freshen (Impl ((v, kind):vs) p p') = do st <- get -- Freshen the variable bound here @@ -230,7 +254,7 @@ instance (Monad m, MonadFail m) => Freshenable m Pred where -- Freshening now out of scope removeFreshenings [Id (internalName v) v'] - return $ Impl ((Id (internalName v) v'):vs') pf pf' + return $ Impl ((Id (internalName v) v', kind):vs') pf pf' freshen (Con cons) = do cons' <- freshen cons @@ -243,7 +267,7 @@ deriving instance Eq Pred predFold :: ([a] -> a) -> ([a] -> a) - -> ([Id] -> a -> a -> a) + -> (Ctxt Kind -> a -> a -> a) -> (Constraint -> a) -> (a -> a) -> (Id -> Kind -> a -> a) @@ -251,7 +275,7 @@ predFold :: -> a predFold c d i a n e (Conj ps) = c (map (predFold c d i a n e) ps) predFold c d i a n e (Disj ps) = d (map (predFold c d i a n e) ps) -predFold c d i a n e (Impl eVar p p') = i eVar (predFold c d i a n e p) (predFold c d i a n e p') +predFold c d i a n e (Impl ctxt p p') = i ctxt (predFold c d i a n e p) (predFold c d i a n e p') predFold _ _ _ a _ _ (Con cons) = a cons predFold c d i a n e (NegPred p) = n (predFold c d i a n e p) predFold c d i a n e (Exists x t p) = e x t (predFold c d i a n e p) @@ -260,7 +284,7 @@ predFold c d i a n e (Exists x t p) = e x t (predFold c d i a n e p) predFoldM :: Monad m => ([a] -> m a) -> ([a] -> m a) - -> ([Id] -> a -> a -> m a) + -> (Ctxt Kind -> a -> a -> m a) -> (Constraint -> m a) -> (a -> m a) -> (Id -> Kind -> a -> m a) @@ -298,13 +322,15 @@ instance Pretty Pred where predFold (intercalate " ∧ ") (intercalate " ∨ ") - (\s p q -> - (if null s then "" else "∀ " <> intercalate "," (map sourceName s) <> " . ") + (\ctxt p q -> + (if null ctxt then "" else "∀ " <> pretty' ctxt <> " . ") <> "(" <> p <> " -> " <> q <> ")") (prettyL l) (\p -> "¬(" <> p <> ")") (\x t p -> "∃ " <> pretty x <> " : " <> pretty t <> " . " <> p) + where pretty' = + intercalate "," . map (\(id, k) -> pretty id <> " : " <> pretty k) -- | Whether the predicate is empty, i.e. contains no constraints isTrivial :: Pred -> Bool -isTrivial = predFold and or (\_ lhs rhs -> lhs && rhs) (const False) id (\_ _ p -> p) +isTrivial = predFold and or (\_ lhs rhs -> rhs) (const False) id (\_ _ p -> p) diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs index 48074549f..e1eb52a7e 100644 --- a/frontend/src/Language/Granule/Checker/Primitives.hs +++ b/frontend/src/Language/Granule/Checker/Primitives.hs @@ -1,27 +1,28 @@ -- Provides all the type information for built-ins +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} module Language.Granule.Checker.Primitives where import Data.List (genericLength) +import Data.List.NonEmpty (NonEmpty(..)) import Text.RawString.QQ (r) +import Language.Granule.Checker.SubstitutionContexts + import Language.Granule.Syntax.Def import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Parser (parseDefs) import Language.Granule.Syntax.Type import Language.Granule.Syntax.Span +import Language.Granule.Syntax.Expr (Operator(..)) - -kNat = kConstr $ mkId "Nat" -protocol = kConstr $ mkId "Protocol" - +nullSpanBuiltin :: Span nullSpanBuiltin = Span (0, 0) (0, 0) "Builtin" typeConstructors :: [(Id, (Kind, Cardinality))] -- TODO Cardinality is not a good term typeConstructors = - [ (mkId "()", (KType, Just 1)) - , (mkId "ArrayStack", (KFun kNat (KFun kNat (KFun KType KType)), Nothing)) + [ (mkId "ArrayStack", (KFun kNat (KFun kNat (KFun KType KType)), Nothing)) , (mkId ",", (KFun KType (KFun KType KType), Just 1)) , (mkId "×", (KFun KCoeffect (KFun KCoeffect KCoeffect), Just 1)) , (mkId "Int", (KType, Nothing)) @@ -36,20 +37,7 @@ typeConstructors = , (mkId "Level", (KCoeffect, Nothing)) -- Security level , (mkId "Interval", (KFun KCoeffect KCoeffect, Nothing)) , (mkId "Set", (KFun (KVar $ mkId "k") (KFun (kConstr $ mkId "k") KCoeffect), Nothing)) - , (mkId "+", (KFun kNat (KFun kNat kNat), Nothing)) - , (mkId "-", (KFun kNat (KFun kNat kNat), Nothing)) - , (mkId "*", (KFun kNat (KFun kNat kNat), Nothing)) - , (mkId "<", (KFun kNat (KFun kNat KPredicate), Nothing)) - , (mkId ">", (KFun kNat (KFun kNat KPredicate), Nothing)) - , (mkId "=", (KFun kNat (KFun kNat KPredicate), Nothing)) - , (mkId "/=", (KFun kNat (KFun kNat KPredicate), Nothing)) - , (mkId "<=", (KFun kNat (KFun kNat KPredicate), Nothing)) - , (mkId ">=", (KFun kNat (KFun kNat KPredicate), Nothing)) - , (mkId "∧", (KFun kNat (KFun kNat kNat), Nothing)) - , (mkId "∨", (KFun kNat (KFun kNat kNat), Nothing)) -- File stuff - , (mkId "Handle", (KType, Nothing)) - , (mkId "IOMode", (KType, Nothing)) -- Channels and protocol types , (mkId "Send", (KFun KType (KFun protocol protocol), Nothing)) , (mkId "Recv", (KFun KType (KFun protocol protocol), Nothing)) @@ -61,125 +49,232 @@ typeConstructors = , (mkId "Ext", (KFun KCoeffect KCoeffect, Nothing)) ] ++ builtinTypeConstructors -dataConstructors :: [(Id, TypeScheme)] +tyOps :: TypeOperator -> (Kind, Kind, Kind) +tyOps = \case + TyOpLesser -> (kNat, kNat, KPredicate) + TyOpLesserEq -> (kNat, kNat, KPredicate) + TyOpGreater -> (kNat, kNat, KPredicate) + TyOpGreaterEq -> (kNat, kNat, KPredicate) + TyOpEq -> (kNat, kNat, KPredicate) + TyOpNotEq -> (kNat, kNat, KPredicate) + TyOpPlus -> (kNat, kNat, kNat) + TyOpTimes -> (kNat, kNat, kNat) + TyOpMinus -> (kNat, kNat, kNat) + TyOpExpon -> (kNat, kNat, kNat) + TyOpMeet -> (kNat, kNat, kNat) + TyOpJoin -> (kNat, kNat, kNat) + +dataConstructors :: [(Id, (TypeScheme, Substitution))] dataConstructors = - [ (mkId "()", Forall nullSpanBuiltin [] [] (TyCon $ mkId "()")) - , (mkId ",", Forall nullSpanBuiltin [((mkId "a"),KType),((mkId "b"),KType)] [] + [ ( mkId ",", (Forall nullSpanBuiltin [((mkId "a"),KType),((mkId "b"),KType)] [] (FunTy (TyVar (mkId "a")) (FunTy (TyVar (mkId "b")) - (TyApp (TyApp (TyCon (mkId ",")) (TyVar (mkId "a"))) (TyVar (mkId "b")))))) - - , (mkId "ReadMode", Forall nullSpanBuiltin [] [] (TyCon $ mkId "IOMode")) - , (mkId "WriteMode", Forall nullSpanBuiltin [] [] (TyCon $ mkId "IOMode")) - , (mkId "AppendMode", Forall nullSpanBuiltin [] [] (TyCon $ mkId "IOMode")) - , (mkId "ReadWriteMode", Forall nullSpanBuiltin [] [] (TyCon $ mkId "IOMode")) + (TyApp (TyApp (TyCon (mkId ",")) (TyVar (mkId "a"))) (TyVar (mkId "b"))))), []) + ) ] ++ builtinDataConstructors -builtins :: [(Id, TypeScheme)] -builtins = - [ (mkId "div", Forall nullSpanBuiltin [] [] - (FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int")))) - -- Graded monad unit operation - , (mkId "pure", Forall nullSpanBuiltin [(mkId "a", KType)] [] - $ (FunTy (TyVar $ mkId "a") (Diamond [] (TyVar $ mkId "a")))) - - -- String stuff - , (mkId "stringAppend", Forall nullSpanBuiltin [] [] - $ (FunTy (TyCon $ mkId "String") (FunTy (TyCon $ mkId "String") (TyCon $ mkId "String")))) - , (mkId "showChar", Forall nullSpanBuiltin [] [] - $ (FunTy (TyCon $ mkId "Char") (TyCon $ mkId "String"))) - - -- Effectful primitives - , (mkId "read", Forall nullSpanBuiltin [] [] $ Diamond ["R"] (TyCon $ mkId "String")) - , (mkId "write", Forall nullSpanBuiltin [] [] $ - FunTy (TyCon $ mkId "String") (Diamond ["W"] (TyCon $ mkId "()"))) - , (mkId "readInt", Forall nullSpanBuiltin [] [] $ Diamond ["R"] (TyCon $ mkId "Int")) - -- Other primitives - , (mkId "intToFloat", Forall nullSpanBuiltin [] [] $ FunTy (TyCon $ mkId "Int") - (TyCon $ mkId "Float")) - - , (mkId "showInt", Forall nullSpanBuiltin [] [] $ FunTy (TyCon $ mkId "Int") - (TyCon $ mkId "String")) +binaryOperators :: Operator -> NonEmpty Type +binaryOperators = \case + OpPlus -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Float"))] + OpMinus -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Float"))] + OpTimes -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Float"))] + OpEq -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))] + OpNotEq -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))] + OpLesserEq -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))] + OpLesser -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))] + OpGreater -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))] + OpGreaterEq -> + FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool")) + :| [FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))] + +-- TODO make a proper quasi quoter that parses this at compile time +builtinSrc :: String +builtinSrc = [r| - -- File stuff - , (mkId "openFile", Forall nullSpanBuiltin [] [] $ - FunTy (TyCon $ mkId "String") - (FunTy (TyCon $ mkId "IOMode") - (Diamond ["O"] (TyCon $ mkId "Handle")))) - , (mkId "hGetChar", Forall nullSpanBuiltin [] [] $ - FunTy (TyCon $ mkId "Handle") - (Diamond ["RW"] - (TyApp (TyApp (TyCon $ mkId ",") - (TyCon $ mkId "Handle")) - (TyCon $ mkId "Char")))) - , (mkId "hPutChar", Forall nullSpanBuiltin [] [] $ - FunTy (TyCon $ mkId "Handle") - (FunTy (TyCon $ mkId "Char") - (Diamond ["W"] (TyCon $ mkId "Handle")))) - , (mkId "isEOF", Forall nullSpanBuiltin [] [] $ - FunTy (TyCon $ mkId "Handle") - (Diamond ["R"] - (TyApp (TyApp (TyCon $ mkId ",") - (TyCon $ mkId "Handle")) - (TyCon $ mkId "Bool")))) - , (mkId "hClose", Forall nullSpanBuiltin [] [] $ - FunTy (TyCon $ mkId "Handle") - (Diamond ["C"] (TyCon $ mkId "()"))) - -- protocol typed primitives - , (mkId "send", Forall nullSpanBuiltin [(mkId "a", KType), (mkId "s", protocol)] [] - $ ((con "Chan") .@ (((con "Send") .@ (var "a")) .@ (var "s"))) - .-> ((var "a") - .-> (Diamond ["Com"] ((con "Chan") .@ (var "s"))))) - - , (mkId "recv", Forall nullSpanBuiltin [(mkId "a", KType), (mkId "s", protocol)] [] - $ ((con "Chan") .@ (((con "Recv") .@ (var "a")) .@ (var "s"))) - .-> (Diamond ["Com"] ((con "," .@ (var "a")) .@ ((con "Chan") .@ (var "s"))))) - - , (mkId "close", Forall nullSpanBuiltin [] [] $ - ((con "Chan") .@ (con "End")) .-> (Diamond ["Com"] (con "()"))) - - -- fork : (c -> Diamond ()) -> Diamond c' - , (mkId "fork", Forall nullSpanBuiltin [(mkId "s", protocol)] [] $ - (((con "Chan") .@ (TyVar $ mkId "s")) .-> (Diamond ["Com"] (con "()"))) - .-> - (Diamond ["Com"] ((con "Chan") .@ ((TyCon $ mkId "Dual") .@ (TyVar $ mkId "s"))))) - - -- forkRep : (c |n| -> Diamond ()) -> Diamond (c' |n|) - , (mkId "forkRep", Forall nullSpanBuiltin [(mkId "s", protocol), (mkId "n", kNat)] [] $ - (Box (CVar $ mkId "n") - ((con "Chan") .@ (TyVar $ mkId "s")) .-> (Diamond ["Com"] (con "()"))) - .-> - (Diamond ["Com"] - (Box (CVar $ mkId "n") - ((con "Chan") .@ ((TyCon $ mkId "Dual") .@ (TyVar $ mkId "s")))))) - , (mkId "unpack", Forall nullSpanBuiltin [(mkId "s", protocol)] [] - (FunTy ((con "Chan") .@ (var "s")) (var "s"))) - ] ++ builtins' - -binaryOperators :: [(Operator, Type)] -binaryOperators = - [ ("+", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int"))) - ,("+", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Float"))) - ,("-", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int"))) - ,("-", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Float"))) - ,("*", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Int"))) - ,("*", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Float"))) - ,("≡", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool"))) - ,("≤", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool"))) - ,("<", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool"))) - ,(">", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool"))) - ,("≥", FunTy (TyCon $ mkId "Int") (FunTy (TyCon $ mkId "Int") (TyCon $ mkId "Bool"))) - ,("≡", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))) - ,("≤", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))) - ,("<", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))) - ,(">", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))) - ,("≥", FunTy (TyCon $ mkId "Float") (FunTy (TyCon $ mkId "Float") (TyCon $ mkId "Bool"))) - ] +import Prelude +data () = () +-------------------------------------------------------------------------------- +-- Arithmetic +-------------------------------------------------------------------------------- -builtinSrc :: String -builtinSrc = [r| +div : Int -> Int -> Int +div = BUILTIN + +-------------------------------------------------------------------------------- +-- Graded Possiblity +-------------------------------------------------------------------------------- + +pure + : forall {a : Type} + . a -> a <> +pure = BUILTIN + +-------------------------------------------------------------------------------- +-- I/O +-------------------------------------------------------------------------------- + +fromStdin : String +fromStdin = BUILTIN + +toStdout : String -> () +toStdout = BUILTIN + +toStderr : String -> () +toStderr = BUILTIN + +readInt : Int +readInt = BUILTIN + +-------------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------------- + +showChar : Char -> String +showChar = BUILTIN + +intToFloat : Int -> Float +intToFloat = BUILTIN + +showInt : Int -> String +showInt = BUILTIN + +-------------------------------------------------------------------------------- +-- Thread / Sessions +-------------------------------------------------------------------------------- + +fork + : forall {s : Protocol, k : Coeffect, c : k} + . ((Chan s) [c] -> () ) -> ((Chan (Dual s)) [c]) +fork = BUILTIN + +forkLinear + : forall {s : Protocol} + . (Chan s -> () ) -> (Chan (Dual s)) +forkLinear = BUILTIN + +send + : forall {a : Type, s : Protocol} + . Chan (Send a s) -> a -> (Chan s) +send = BUILTIN + +recv + : forall {a : Type, s : Protocol} + . Chan (Recv a s) -> (a, Chan s) +recv = BUILTIN + +close : Chan End -> () +close = BUILTIN + +unpackChan + : forall {s : Protocol} + . Chan s -> s +unpackChan = BUILTIN + +-------------------------------------------------------------------------------- +-- File Handles +-------------------------------------------------------------------------------- + +data Handle : HandleType -> Type + = BUILTIN + +-- TODO: with type level sets we could index a handle by a set of capabilities +-- then we wouldn't need readChar and readChar' etc. +data IOMode : HandleType -> Type where + ReadMode : IOMode R; + WriteMode : IOMode W; + AppendMode : IOMode A; + ReadWriteMode : IOMode RW + +data HandleType = R | W | A | RW + +openHandle + : forall {m : HandleType} + . IOMode m + -> String + -> (Handle m) +openHandle = BUILTIN + +readChar : Handle R -> (Handle R, Char) +readChar = BUILTIN + +readChar' : Handle RW -> (Handle RW, Char) +readChar' = BUILTIN + +appendChar : Handle A -> Char -> (Handle A) +appendChar = BUILTIN + +writeChar : Handle W -> Char -> (Handle W) +writeChar = BUILTIN + +writeChar' : Handle RW -> Char -> (Handle RW) +writeChar' = BUILTIN + +closeHandle : forall {m : HandleType} . Handle m -> () +closeHandle = BUILTIN + +isEOF : Handle R -> (Handle R, Bool) +isEOF = BUILTIN + +isEOF' : Handle RW -> (Handle RW, Bool) +isEOF' = BUILTIN + +-- ??? +-- evalIO : forall {a : Type, e : Effect} . (a [0..1]) -> (Maybe a) +-- catch = BUILTIN +-------------------------------------------------------------------------------- +-- Char +-------------------------------------------------------------------------------- + +-- module Char + +charToInt : Char -> Int +charToInt = BUILTIN + +charFromInt : Int -> Char +charFromInt = BUILTIN + + + +-------------------------------------------------------------------------------- +-- String manipulation +-------------------------------------------------------------------------------- + +stringAppend : String → String → String +stringAppend = BUILTIN + +stringUncons : String → Maybe (Char, String) +stringUncons = BUILTIN + +stringCons : Char → String → String +stringCons = BUILTIN + +stringUnsnoc : String → Maybe (String, Char) +stringUnsnoc = BUILTIN + +stringSnoc : String → Char → String +stringSnoc = BUILTIN + +-------------------------------------------------------------------------------- +-- Arrays +-------------------------------------------------------------------------------- data ArrayStack @@ -194,21 +289,21 @@ push ⇒ ArrayStack cap maxIndex a → a → ArrayStack cap (maxIndex + 1) a -push = builtin +push = BUILTIN pop : ∀ {a : Type, cap : Nat, maxIndex : Nat} . {maxIndex > 0} ⇒ ArrayStack cap maxIndex a → a × ArrayStack cap (maxIndex - 1) a -pop = builtin +pop = BUILTIN -- Boxed array, so we allocate cap words allocate : ∀ {a : Type, cap : Nat} . N cap → ArrayStack cap 0 a -allocate = builtin +allocate = BUILTIN swap : ∀ {a : Type, cap : Nat, maxIndex : Nat} @@ -216,35 +311,37 @@ swap → Fin (maxIndex + 1) → a → a × ArrayStack cap (maxIndex + 1) a -swap = builtin +swap = BUILTIN copy : ∀ {a : Type, cap : Nat, maxIndex : Nat} . ArrayStack cap maxIndex (a [2]) → ArrayStack cap maxIndex a × ArrayStack cap maxIndex a -copy = builtin +copy = BUILTIN |] builtinTypeConstructors :: [(Id, (Kind, Cardinality))] -builtinDataConstructors :: [(Id, TypeScheme)] -builtins' :: [(Id, TypeScheme)] -(builtinTypeConstructors, builtinDataConstructors, builtins') = +builtinDataConstructors :: [(Id, (TypeScheme, Substitution))] +builtins :: [(Id, TypeScheme)] +(builtinTypeConstructors, builtinDataConstructors, builtins) = (map fst datas, concatMap snd datas, map unDef defs) where - Right (AST types defs) = parseDefs "builtins" builtinSrc + AST types defs _ = case parseDefs "builtins" builtinSrc of + Right ast -> ast + Left err -> error err datas = map unData types unDef :: Def () () -> (Id, TypeScheme) unDef (Def _ name _ (Forall _ bs cs t)) = (name, Forall nullSpanBuiltin bs cs t) - unData :: DataDecl -> ((Id, (Kind, Cardinality)), [(Id, TypeScheme)]) + unData :: DataDecl -> ((Id, (Kind, Cardinality)), [(Id, (TypeScheme, Substitution))]) unData (DataDecl _ tyConName tyVars kind dataConstrs) - = ( (tyConName, (maybe KType id kind, Just $ genericLength dataConstrs)) + = (( tyConName, (maybe KType id kind, (Just $ genericLength dataConstrs))) , map unDataConstr dataConstrs ) where - unDataConstr :: DataConstr -> (Id, TypeScheme) - unDataConstr (DataConstrIndexed _ name tysch) = (name, tysch) + unDataConstr :: DataConstr -> (Id, (TypeScheme, Substitution)) + unDataConstr (DataConstrIndexed _ name tysch) = (name, (tysch, [])) unDataConstr d = unDataConstr (nonIndexedToIndexedDataConstr tyConName tyVars d) diff --git a/frontend/src/Language/Granule/Checker/Simplifier.hs b/frontend/src/Language/Granule/Checker/Simplifier.hs index ceff9beaf..da2e3714b 100644 --- a/frontend/src/Language/Granule/Checker/Simplifier.hs +++ b/frontend/src/Language/Granule/Checker/Simplifier.hs @@ -2,10 +2,10 @@ module Language.Granule.Checker.Simplifier where -import Control.Monad.Trans.Maybe - import Language.Granule.Syntax.Type -import Language.Granule.Checker.Substitutions +import Language.Granule.Syntax.Helpers (freeVars) +import Language.Granule.Checker.SubstitutionContexts +import Language.Granule.Checker.Substitution import Language.Granule.Checker.Predicates import Language.Granule.Checker.Monad @@ -18,23 +18,33 @@ allCons :: [Pred] -> Bool allCons = all (\p -> case p of Con _ -> True; _ -> False) simplifyPred :: (?globals :: Globals) - => Pred -> MaybeT Checker Pred -simplifyPred p = do - p <- simplifyPred' p - return $ flatten $ normalisePred p + => Pred -> Checker Pred +simplifyPred p = go 10 p where + -- Bounded fixed-point (don't go for ever, in case things are non-converging somehow) + go 0 p = return p + go n p = do + p <- simplifyPred' p + let p' = flatten $ normalisePred p + if (p == p') then return p' else go (n-1) p' + normalisePred = predFold Conj Disj Impl (Con . normaliseConstraint) NegPred Exists simplifyPred' :: (?globals :: Globals) - => Pred -> MaybeT Checker Pred -simplifyPred' c@(Conj ps) | allCons ps = - simpl subst c where subst = collectSubst c + => Pred -> Checker Pred simplifyPred' (Conj ps) = do - ps <- mapM simplifyPred' ps - let ps' = nub ps - return $ Conj ps' + -- Collect any substitutions implied by the constraints + let subst = collectSubst (Conj ps) + -- Apply these subsitutions to the conjunction + (Conj ps') <- simpl subst (Conj ps) + -- Then recursively apply the simplification to each subpart + ps' <- mapM simplifyPred' ps' + -- Remove any duplications + let ps'' = nub ps' + -- Output the final conjunction + return $ Conj ps'' simplifyPred' (Disj ps) = do ps <- mapM simplifyPred' ps @@ -48,8 +58,12 @@ simplifyPred' c@(Impl ids p1 p2) = do p2'' <- simpl subst' p2' return $ removeTrivialImpls . removeTrivialIds $ (Impl ids p1' p2'') -simplifyPred' c@(Exists id k p) = - simplifyPred' p >>= return . Exists id k +simplifyPred' c@(Exists id k p) = do + p' <- simplifyPred' p + -- Strip quantifications that are no longer used + if id `elem` (freeVars p') + then return $ Exists id k p' + else return p' simplifyPred' c@(NegPred p) = simplifyPred' p >>= return . NegPred @@ -75,7 +89,7 @@ flatten (Con c) = Con c simpl :: (?globals :: Globals) - => Substitution -> Pred -> MaybeT Checker Pred + => Substitution -> Pred -> Checker Pred simpl subst p = substitute subst p >>= (return . removeTrivialImpls . removeTrivialIds) removeTrivialImpls :: Pred -> Pred @@ -89,6 +103,7 @@ removeTrivialIds :: Pred -> Pred removeTrivialIds = predFold conj disj Impl conRemove NegPred Exists where removeTrivialIdCon (Con (Eq _ c c' _)) | c == c' = Nothing + -- removeTrivialIdCon (Con (ApproximatedBy _ c c' _)) | c == c' = Nothing removeTrivialIdCon c = Just c conj ps = Conj $ catMaybes (map removeTrivialIdCon ps) @@ -104,8 +119,8 @@ removeTrivialIds = collectSubst :: Pred -> Substitution collectSubst (Conj ps) = concatMap collectSubst ps --- For a pair of variables, make a two way substitution (unification which is symmetric) -collectSubst (Con (Eq _ (CVar v) (CVar v') _)) = [(v, SubstC (CVar v')), (v', SubstC (CVar v))] +-- For a pair of variables, substitute the right for the left +collectSubst (Con (Eq _ (CVar v1) (CVar v2) _)) = [(v1, SubstC (CVar v2))] collectSubst (Con (Eq _ (CVar v) c _)) = [(v, SubstC c)] collectSubst (Con (Eq _ c (CVar v) _)) = [(v, SubstC c)] collectSubst _ = [] diff --git a/frontend/src/Language/Granule/Checker/Substitution.hs b/frontend/src/Language/Granule/Checker/Substitution.hs new file mode 100644 index 000000000..c3f245c7e --- /dev/null +++ b/frontend/src/Language/Granule/Checker/Substitution.hs @@ -0,0 +1,677 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.Granule.Checker.Substitution where + +import Control.Monad +import Control.Monad.State.Strict +import Data.Maybe (mapMaybe) +import Data.Bifunctor.Foldable (bicataM) + +import Language.Granule.Context +import Language.Granule.Syntax.Def +import Language.Granule.Syntax.Expr hiding (Substitutable) +import Language.Granule.Syntax.Pattern +import Language.Granule.Syntax.Helpers +import Language.Granule.Syntax.Identifiers +import Language.Granule.Syntax.Span +import Language.Granule.Syntax.Type + +import Language.Granule.Checker.SubstitutionContexts +import Language.Granule.Checker.Constraints.Compile +import Language.Granule.Checker.Monad +import Language.Granule.Checker.Kinds +import Language.Granule.Checker.Predicates +import Language.Granule.Checker.Variables (freshTyVarInContextWithBinding) + +import Language.Granule.Utils + +class Substitutable t where + -- | Rewrite a 't' using a substitution + substitute :: (?globals :: Globals) + => Substitution -> t -> Checker t + +-- Instances for the main representation of things in the types + +instance Substitutable Substitutors where + + substitute subst s = + case s of + SubstT t -> do + t <- substitute subst t + return $ SubstT t + + SubstC c -> do + c <- substitute subst c + return $ SubstC c + + SubstK k -> do + k <- substitute subst k + return $ SubstK k + + SubstE e -> do + e <- substitute subst e + return $ SubstE e + +-- Speciale case of substituting a substition +instance Substitutable Substitution where + substitute subst [] = return [] + substitute subst ((var , s) : subst') = do + s <- substitute subst s + subst' <- substitute subst subst' + case lookup var subst of + Just (SubstT (TyVar var')) -> return $ (var', s) : subst' + Nothing -> return subst' + -- Shouldn't happen + t -> error + $ "Granule bug. Cannot rewrite a substitution `s` as the substitution map `s'` = " + <> show subst <> " maps variable `" <> show var + <> "` to a non variable type: `" <> show t <> "`" + +instance Substitutable Type where + substitute subst = typeFoldM (baseTypeFold + { tfTyVar = varSubst + , tfBox = box + , tfDiamond = dia }) + where + box c t = do + c <- substitute subst c + mBox c t + + dia e t = do + e <- substitute subst e + mDiamond e t + + varSubst v = + case lookup v subst of + Just (SubstT t) -> return t + _ -> mTyVar v + +instance Substitutable Coeffect where + + substitute subst (CPlus c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CPlus c1' c2' + + substitute subst (CJoin c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CJoin c1' c2' + + substitute subst (CMeet c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CMeet c1' c2' + + substitute subst (CTimes c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CTimes c1' c2' + + substitute subst (CMinus c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CMinus c1' c2' + + substitute subst (CExpon c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CExpon c1' c2' + + substitute subst (CInterval c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CInterval c1' c2' + + substitute subst (CProduct c1 c2) = do + c1' <- substitute subst c1 + c2' <- substitute subst c2 + return $ CProduct c1' c2' + + substitute subst (CVar v) = + case lookup v subst of + Just (SubstC c) -> do + checkerState <- get + case lookup v (tyVarContext checkerState) of + -- If the coeffect variable has a poly kind then update it with the + -- kind of c + Just ((KVar kv), q) -> do + k' <- inferCoeffectType nullSpan c + put $ checkerState { tyVarContext = replace (tyVarContext checkerState) + v (promoteTypeToKind k', q) } + _ -> return () + return c + -- Convert a single type substitution (type variable, type pair) into a + -- coeffect substituion + Just (SubstT t) -> do + k <- inferKindOfType nullSpan t + k' <- inferCoeffectType nullSpan (CVar v) + case joinKind k (promoteTypeToKind k') of + Just (KPromote (TyCon (internalName -> "Nat")), _) -> + compileNatKindedTypeToCoeffect nullSpan t + _ -> return (CVar v) + + _ -> return $ CVar v + + substitute subst (CInfinity k) = do + k <- substitute subst k + return $ CInfinity k + + substitute subst (COne k) = do + k <- substitute subst k + return $ COne k + + substitute subst (CZero k) = do + k <- substitute subst k + return $ CZero k + + substitute subst (CSet tys) = do + tys <- mapM (\(v, t) -> substitute subst t >>= (\t' -> return (v, t'))) tys + return $ CSet tys + + substitute subst (CSig c k) = do + c <- substitute subst c + k <- substitute subst k + return $ CSig c k + + substitute _ c@CNat{} = return c + substitute _ c@CFloat{} = return c + substitute _ c@Level{} = return c + +instance Substitutable Effect where + -- {TODO: Make effects richer} + substitute subst = pure + +instance Substitutable Kind where + + substitute subst (KPromote t) = do + t <- substitute subst t + return $ KPromote t + + substitute subst KType = return KType + substitute subst KCoeffect = return KCoeffect + substitute subst KPredicate = return KPredicate + substitute subst (KFun c1 c2) = do + c1 <- substitute subst c1 + c2 <- substitute subst c2 + return $ KFun c1 c2 + substitute subst (KVar v) = + case lookup v subst of + Just (SubstK k) -> return k + Just (SubstT t) -> return $ KPromote t + _ -> return $ KVar v + +instance Substitutable t => Substitutable (Maybe t) where + substitute s Nothing = return Nothing + substitute s (Just t) = substitute s t >>= return . Just + +-- | Combine substitutions wrapped in Maybe +(<<>>) :: (?globals :: Globals) + => Maybe Substitution -> Maybe Substitution -> Checker (Maybe Substitution) +xs <<>> ys = + case (xs, ys) of + (Just xs', Just ys') -> + combineSubstitutions nullSpan xs' ys' >>= (return . Just) + _ -> return Nothing + +combineManySubstitutions :: (?globals :: Globals) + => Span -> [Substitution] -> Checker Substitution +combineManySubstitutions s [] = return [] +combineManySubstitutions s (subst:ss) = do + ss' <- combineManySubstitutions s ss + combineSubstitutions s subst ss' + +removeReflexivePairs :: Substitution -> Substitution +removeReflexivePairs [] = [] +removeReflexivePairs ((v, SubstT (TyVar v')):subst) | v == v' = removeReflexivePairs subst +removeReflexivePairs ((v, SubstC (CVar v')):subst) | v == v' = removeReflexivePairs subst +removeReflexivePairs ((v, SubstK (KVar v')):subst) | v == v' = removeReflexivePairs subst +removeReflexivePairs ((v, e):subst) = (v, e) : removeReflexivePairs subst + +-- | Combines substitutions which may fail if there are conflicting +-- | substitutions +combineSubstitutions :: + (?globals :: Globals) + => Span -> Substitution -> Substitution -> Checker Substitution +combineSubstitutions sp u1 u2 = do + -- Remove any substitutions that say things like `a |-> a`. This leads to infite loops + u1 <- return $ removeReflexivePairs u1 + u2 <- return $ removeReflexivePairs u2 + + -- For all things in the (possibly empty) intersection of contexts `u1` and `u2`, + -- check whether things can be unified, i.e. exactly + uss1 <- forM u1 $ \(v, s) -> + case lookupMany v u2 of + -- Unifier in u1 but not in u2 + [] -> return [(v, s)] + -- Possible unifications in each part + alts -> do + unifs <- + forM alts $ \s' -> do + --(us, t) <- unifiable v t t' t t' + us <- unify s s' + case us of + Nothing -> throw UnificationFailGeneric { errLoc = sp, errSubst1 = s, errSubst2 = s' } + Just us -> do + sUnified <- substitute us s + combineSubstitutions sp [(v, sUnified)] us + + return $ concat unifs + -- Any remaining unifiers that are in u2 but not u1 + uss2 <- forM u2 $ \(v, s) -> + case lookup v u1 of + Nothing -> return [(v, s)] + _ -> return [] + let uss = concat uss1 <> concat uss2 + return $ reduceByTransitivity uss + +reduceByTransitivity :: Substitution -> Substitution +reduceByTransitivity ctxt = reduceByTransitivity' [] ctxt + where + reduceByTransitivity' :: Substitution -> Substitution -> Substitution + reduceByTransitivity' subst [] = subst + + reduceByTransitivity' substLeft (subst@(var, SubstT (TyVar var')):substRight) = + case lookupAndCutout var' (substLeft ++ substRight) of + Just (substRest, t) -> (var, t) : reduceByTransitivity ((var', t) : substRest) + Nothing -> reduceByTransitivity' (subst : substLeft) substRight + + reduceByTransitivity' substLeft (subst:substRight) = + reduceByTransitivity' (subst:substLeft) substRight + +{-| Take a context of 'a' and a subhstitution for 'a's (also a context) + apply the substitution returning a pair of contexts, one for parts + of the context where a substitution occurred, and one where substitution + did not occur +>>> let ?globals = mempty in evalChecker initState (runMaybeT $ substCtxt [(mkId "y", SubstT $ TyInt 0)] [(mkId "x", Linear (TyVar $ mkId "x")), (mkId "y", Linear (TyVar $ mkId "y")), (mkId "z", Discharged (TyVar $ mkId "z") (CVar $ mkId "b"))]) +Just ([((Id "y" "y"),Linear (TyInt 0))],[((Id "x" "x"),Linear (TyVar (Id "x" "x"))),((Id "z" "z"),Discharged (TyVar (Id "z" "z")) (CVar (Id "b" "b")))]) +-} + +instance Substitutable (Ctxt Assumption) where + + substitute subst ctxt = do + (ctxt0, ctxt1) <- substCtxt subst ctxt + return (ctxt0 <> ctxt1) + +substCtxt :: (?globals :: Globals) => Substitution -> Ctxt Assumption + -> Checker (Ctxt Assumption, Ctxt Assumption) +substCtxt _ [] = return ([], []) +substCtxt subst ((v, x):ctxt) = do + (substituteds, unsubstituteds) <- substCtxt subst ctxt + (v', x') <- substAssumption subst (v, x) + + if (v', x') == (v, x) + then return (substituteds, (v, x) : unsubstituteds) + else return ((v, x') : substituteds, unsubstituteds) + +substAssumption :: (?globals :: Globals) => Substitution -> (Id, Assumption) + -> Checker (Id, Assumption) +substAssumption subst (v, Linear t) = do + t <- substitute subst t + return (v, Linear t) +substAssumption subst (v, Discharged t c) = do + t <- substitute subst t + c <- substitute subst c + return (v, Discharged t c) + + +-- | Apply a name map to a type to rename the type variables +renameType :: (?globals :: Globals) => [(Id, Id)] -> Type -> Checker Type +renameType subst = typeFoldM $ baseTypeFold + { tfBox = renameBox subst + , tfTyVar = renameTyVar subst + } + where + renameBox renameMap c t = do + c' <- substitute (map (\(v, var) -> (v, SubstC $ CVar var)) renameMap) c + t' <- renameType renameMap t + return $ Box c' t' + renameTyVar renameMap v = + case lookup v renameMap of + Just v' -> return $ TyVar v' + -- Shouldn't happen + Nothing -> return $ TyVar v + +-- | Get a fresh polymorphic instance of a type scheme and list of instantiated type variables +-- and their new names. +freshPolymorphicInstance :: (?globals :: Globals) + => Quantifier -- ^ Variety of quantifier to resolve universals into (InstanceQ or BoundQ) + -> Bool -- ^ Flag on whether this is a data constructor-- if true, then be careful with existentials + -> TypeScheme -- ^ Type scheme to freshen + -> Substitution -- ^ A substitution associated with this type scheme (e.g., for + -- data constructors of indexed types) that also needs freshening + + -> Checker (Type, Ctxt Kind, Substitution, [Type], Substitution) + -- Returns the type (with new instance variables) + -- a context of all the instance variables kinds (and the ids they replaced) + -- a substitution from the visible instance variable to their originals + -- a list of the (freshened) constraints for this scheme + -- a correspondigly freshened version of the parameter substitution +freshPolymorphicInstance quantifier isDataConstructor (Forall s kinds constr ty) ixSubstitution = do + -- Universal becomes an existential (via freshCoeffeVar) + -- since we are instantiating a polymorphic type + + renameMap <- mapM instantiateVariable kinds + ty <- renameType (ctxtMap snd $ elideEither renameMap) ty + + let subst = map (\(v, (_, var)) -> (v, SubstT $ TyVar var)) $ elideEither renameMap + constr' <- mapM (substitute subst) constr + + -- Return the type and all instance variables + let newTyVars = map (\(_, (k, v')) -> (v', k)) $ elideEither renameMap + let substitution = ctxtMap (SubstT . TyVar . snd) $ justLefts renameMap + + ixSubstitution' <- substitute substitution ixSubstitution + + return (ty, newTyVars, substitution, constr', ixSubstitution') + + where + -- Freshen variables, create instance variables + -- Left of id means a succesful instance variable created + -- Right of id means that this is an existential and so an (externally visisble) + -- instance variable is not generated + instantiateVariable :: (Id, Kind) -> Checker (Id, Either (Kind, Id) (Kind, Id)) + instantiateVariable (var, k) = + if isDataConstructor && (var `notElem` freeVars (resultType ty)) + && (var `notElem` freeVars (ixSubstitution)) + then do + -- Signals an existential + var' <- freshTyVarInContextWithBinding var k ForallQ + -- Don't return this as a fresh skolem variable + return (var, Right (k, var')) + + else do + var' <- freshTyVarInContextWithBinding var k quantifier + return (var, Left (k, var')) + -- Forget the Either + elideEither = map proj + where proj (v, Left a) = (v, a) + proj (v, Right a) = (v, a) + -- Get just the lefts (used to extract just the skolems) + justLefts = mapMaybe conv + where conv (v, Left a) = Just (v, a) + conv (v, Right _) = Nothing + +instance Substitutable Pred where + substitute ctxt = + predFoldM + (return . Conj) + (return . Disj) + (\ids p1 p2 -> return $ Impl ids p1 p2) + (\c -> substitute ctxt c >>= return . Con) + (return . NegPred) + (\ids k p -> substitute ctxt k >>= \k' -> return $ Exists ids k' p) + +instance Substitutable Constraint where + substitute ctxt (Eq s c1 c2 k) = do + c1 <- substitute ctxt c1 + c2 <- substitute ctxt c2 + k <- substitute ctxt k + return $ Eq s c1 c2 k + + substitute ctxt (Neq s c1 c2 k) = do + c1 <- substitute ctxt c1 + c2 <- substitute ctxt c2 + k <- substitute ctxt k + return $ Neq s c1 c2 k + + substitute ctxt (ApproximatedBy s c1 c2 k) = do + c1 <- substitute ctxt c1 + c2 <- substitute ctxt c2 + k <- substitute ctxt k + return $ ApproximatedBy s c1 c2 k + + substitute ctxt (NonZeroPromotableTo s v c k) = do + c <- substitute ctxt c + k <- substitute ctxt k + return $ NonZeroPromotableTo s v c k + + substitute ctxt (Lt s c1 c2) = do + c1 <- substitute ctxt c1 + c2 <- substitute ctxt c2 + return $ Lt s c1 c2 + + substitute ctxt (Gt s c1 c2) = do + c1 <- substitute ctxt c1 + c2 <- substitute ctxt c2 + return $ Gt s c1 c2 + + substitute ctxt (LtEq s c1 c2) = LtEq s <$> substitute ctxt c1 <*> substitute ctxt c2 + substitute ctxt (GtEq s c1 c2) = GtEq s <$> substitute ctxt c1 <*> substitute ctxt c2 + +instance Substitutable (Equation () Type) where + substitute ctxt (Equation sp ty patterns expr) = + do ty' <- substitute ctxt ty + pat' <- mapM (substitute ctxt) patterns + expr' <- substitute ctxt expr + return $ Equation sp ty' pat' expr' + +substituteValue :: (?globals::Globals) + => Substitution + -> ValueF ev Type (Value ev Type) (Expr ev Type) + -> Checker (Value ev Type) +substituteValue ctxt (AbsF ty arg mty expr) = + do ty' <- substitute ctxt ty + arg' <- substitute ctxt arg + mty' <- mapM (substitute ctxt) mty + return $ Abs ty' arg' mty' expr +substituteValue ctxt (PromoteF ty expr) = + do ty' <- substitute ctxt ty + return $ Promote ty' expr +substituteValue ctxt (PureF ty expr) = + do ty' <- substitute ctxt ty + return $ Pure ty' expr +substituteValue ctxt (ConstrF ty ident vs) = + do ty' <- substitute ctxt ty + return $ Constr ty' ident vs +substituteValue ctxt (ExtF ty ev) = + do ty' <- substitute ctxt ty + return $ Ext ty' ev +substituteValue _ other = return (ExprFix2 other) + +substituteExpr :: (?globals::Globals) + => Substitution + -> ExprF ev Type (Expr ev Type) (Value ev Type) + -> Checker (Expr ev Type) +substituteExpr ctxt (AppF sp ty fn arg) = + do ty' <- substitute ctxt ty + return $ App sp ty' fn arg +substituteExpr ctxt (BinopF sp ty op lhs rhs) = + do ty' <- substitute ctxt ty + return $ Binop sp ty' op lhs rhs +substituteExpr ctxt (LetDiamondF sp ty pattern mty value expr) = + do ty' <- substitute ctxt ty + pattern' <- substitute ctxt pattern + mty' <- mapM (substitute ctxt) mty + return $ LetDiamond sp ty' pattern' mty' value expr +substituteExpr ctxt (ValF sp ty value) = + do ty' <- substitute ctxt ty + return $ Val sp ty' value +substituteExpr ctxt (CaseF sp ty expr arms) = + do ty' <- substitute ctxt ty + arms' <- mapM (mapFstM (substitute ctxt)) arms + return $ Case sp ty' expr arms' + +mapFstM :: (Monad m) => (a -> m b) -> (a, c) -> m (b, c) +mapFstM fn (f, r) = do + f' <- fn f + return (f', r) + +instance Substitutable (Expr () Type) where + substitute ctxt = bicataM (substituteExpr ctxt) (substituteValue ctxt) + +instance Substitutable (Value () Type) where + substitute ctxt = bicataM (substituteValue ctxt) (substituteExpr ctxt) + +instance Substitutable (Pattern Type) where + substitute ctxt = patternFoldM + (\sp ann nm -> do + ann' <- substitute ctxt ann + return $ PVar sp ann' nm) + (\sp ann -> do + ann' <- substitute ctxt ann + return $ PWild sp ann') + (\sp ann pat -> do + ann' <- substitute ctxt ann + return $ PBox sp ann' pat) + (\sp ann int -> do + ann' <- substitute ctxt ann + return $ PInt sp ann' int) + (\sp ann doub -> do + ann' <- substitute ctxt ann + return $ PFloat sp ann' doub) + (\sp ann nm pats -> do + ann' <- substitute ctxt ann + return $ PConstr sp ann' nm pats) + +class Unifiable t where + unify :: (?globals :: Globals) => t -> t -> Checker (Maybe Substitution) + +instance Unifiable Substitutors where + unify (SubstT t) (SubstT t') = unify t t' + unify (SubstT t) (SubstC c') = do + -- We can unify a type with a coeffect, if the type is actually a Nat + k <- inferKindOfType nullSpan t + k' <- inferCoeffectType nullSpan c' + case joinKind k (KPromote k') of + Just (KPromote (TyCon k), _) | internalName k == "Nat" -> do + c <- compileNatKindedTypeToCoeffect nullSpan t + unify c c' + _ -> return Nothing + + unify (SubstC c') (SubstT t) = unify (SubstT t) (SubstC c') + unify (SubstC c) (SubstC c') = unify c c' + unify (SubstK k) (SubstK k') = unify k k' + unify (SubstE e) (SubstE e') = unify e e' + unify _ _ = return Nothing + +instance Unifiable Type where + unify (TyVar v) t = return $ Just [(v, SubstT t)] + unify t (TyVar v) = return $ Just [(v, SubstT t)] + unify (FunTy t1 t2) (FunTy t1' t2') = do + u1 <- unify t1 t1' + u2 <- unify t2 t2' + u1 <<>> u2 + unify (TyCon c) (TyCon c') | c == c' = return $ Just [] + unify (Box c t) (Box c' t') = do + u1 <- unify c c' + u2 <- unify t t' + u1 <<>> u2 + unify (Diamond e t) (Diamond e' t') = do + u1 <- unify e e' + u2 <- unify t t' + u1 <<>> u2 + unify (TyApp t1 t2) (TyApp t1' t2') = do + u1 <- unify t1 t1' + u2 <- unify t2 t2' + u1 <<>> u2 + unify (TyInt i) (TyInt j) | i == j = return $ Just [] + unify t@(TyInfix o t1 t2) t'@(TyInfix o' t1' t2') = do + k <- inferKindOfType nullSpan t + k' <- inferKindOfType nullSpan t + case joinKind k k' of + Just (KPromote (TyCon (internalName -> "Nat")), _) -> do + c <- compileNatKindedTypeToCoeffect nullSpan t + c' <- compileNatKindedTypeToCoeffect nullSpan t' + addConstraint $ Eq nullSpan c c' (TyCon $ mkId "Nat") + return $ Just [] + + _ | o == o' -> do + u1 <- unify t1 t1' + u2 <- unify t2 t2' + u1 <<>> u2 + -- No unification + _ -> return $ Nothing + -- No unification + unify _ _ = return $ Nothing + +instance Unifiable Coeffect where + unify (CVar v) c = do + checkerState <- get + case lookup v (tyVarContext checkerState) of + -- If the coeffect variable has a poly kind then update it with the + -- kind of c + Just ((KVar kv), q) -> do + k' <- inferCoeffectType nullSpan c + put $ checkerState { tyVarContext = replace (tyVarContext checkerState) + v (promoteTypeToKind k', q) } + Just (k, q) -> + case c of + CVar v' -> + case lookup v' (tyVarContext checkerState) of + Just (KVar _, q) -> + -- The type of v is known and c is a variable with a poly kind + put $ checkerState + { tyVarContext = replace (tyVarContext checkerState) v' (k, q) } + _ -> return () + _ -> return () + Nothing -> return () + -- Standard result of unifying with a variable + return $ Just [(v, SubstC c)] + + unify c (CVar v) = unify (CVar v) c + unify (CPlus c1 c2) (CPlus c1' c2') = do + u1 <- unify c1 c1' + u2 <- unify c2 c2' + u1 <<>> u2 + + unify (CTimes c1 c2) (CTimes c1' c2') = do + u1 <- unify c1 c1' + u2 <- unify c2 c2' + u1 <<>> u2 + + unify (CMeet c1 c2) (CMeet c1' c2') = do + u1 <- unify c1 c1' + u2 <- unify c2 c2' + u1 <<>> u2 + + unify (CJoin c1 c2) (CJoin c1' c2') = do + u1 <- unify c1 c1' + u2 <- unify c2 c2' + u1 <<>> u2 + + unify (CInfinity k) (CInfinity k') = do + unify k k' + + unify (CZero k) (CZero k') = do + unify k k' + + unify (COne k) (COne k') = do + unify k k' + + unify (CSet tys) (CSet tys') = do + ums <- zipWithM (\x y -> unify (snd x) (snd y)) tys tys' + foldM (<<>>) (Just []) ums + + unify (CSig c ck) (CSig c' ck') = do + u1 <- unify c c' + u2 <- unify ck ck' + u1 <<>> u2 + + unify c c' = + if c == c' then return $ Just [] else return Nothing + +instance Unifiable Effect where + unify e e' = + if e == e' then return $ Just [] + else return $ Nothing + +instance Unifiable Kind where + unify (KVar v) k = + return $ Just [(v, SubstK k)] + unify k (KVar v) = + return $ Just [(v, SubstK k)] + unify (KFun k1 k2) (KFun k1' k2') = do + u1 <- unify k1 k1' + u2 <- unify k2 k2' + u1 <<>> u2 + unify k k' = return $ if k == k' then Just [] else Nothing + +instance Unifiable t => Unifiable (Maybe t) where + unify Nothing _ = return (Just []) + unify _ Nothing = return (Just []) + unify (Just x) (Just y) = unify x y diff --git a/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs b/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs new file mode 100644 index 000000000..037b8241a --- /dev/null +++ b/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Granule.Checker.SubstitutionContexts where + +import Language.Granule.Context +import Language.Granule.Syntax.Type +import Language.Granule.Syntax.Pretty +import Language.Granule.Syntax.Helpers + +{-| Substitutions map from variables to type-level things as defined by + substitutors -} +type Substitution = Ctxt Substitutors + +{-| Substitutors are things we want to substitute in... they may be one + of several things... -} +data Substitutors = + SubstT Type + | SubstC Coeffect + | SubstK Kind + | SubstE Effect + deriving (Eq, Show) + +instance Pretty Substitutors where + prettyL l (SubstT t) = prettyL l t + prettyL l (SubstC c) = prettyL l c + prettyL l (SubstK k) = prettyL l k + prettyL l (SubstE e) = prettyL l e + +instance Term Substitution where + freeVars [] = [] + freeVars ((v, SubstT t):subst) = + freeVars t ++ freeVars subst + freeVars ((v, SubstC c):subst) = + freeVars c ++ freeVars subst + freeVars ((v, SubstK k):subst) = + freeVars k ++ freeVars subst + freeVars ((v, SubstE e):subst) = + -- freeVars e ++ + -- TODO: when effects become terms we can do something here + freeVars subst + + +-- | For substitutions which are just renaminings +-- allow the substitution to be inverted +flipSubstitution :: Substitution -> Substitution +flipSubstitution [] = [] +flipSubstitution ((var, SubstT (TyVar var')):subst) = + (var', SubstT (TyVar var)) : flipSubstitution subst + +-- Can't flip the substitution so ignore it +flipSubstitution (s:subst) = flipSubstitution subst diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs index c1bf51018..3c8d360db 100644 --- a/frontend/src/Language/Granule/Checker/Types.hs +++ b/frontend/src/Language/Granule/Checker/Types.hs @@ -7,17 +7,18 @@ module Language.Granule.Checker.Types where import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe import Data.List import Language.Granule.Checker.Constraints.Compile -import Language.Granule.Checker.Errors + import Language.Granule.Checker.Kinds import Language.Granule.Checker.Monad import Language.Granule.Checker.Predicates -import Language.Granule.Checker.Substitutions +import Language.Granule.Checker.SubstitutionContexts +import Language.Granule.Checker.Substitution import Language.Granule.Checker.Variables +import Language.Granule.Syntax.Helpers import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Pretty import Language.Granule.Syntax.Span @@ -26,24 +27,24 @@ import Language.Granule.Syntax.Type import Language.Granule.Utils lEqualTypesWithPolarity :: (?globals :: Globals) - => Span -> SpecIndicator ->Type -> Type -> MaybeT Checker (Bool, Type, Substitution) -lEqualTypesWithPolarity s pol = equalTypesRelatedCoeffectsAndUnify s ApproximatedBy False pol + => Span -> SpecIndicator ->Type -> Type -> Checker (Bool, Type, Substitution) +lEqualTypesWithPolarity s pol = equalTypesRelatedCoeffectsAndUnify s ApproximatedBy pol equalTypesWithPolarity :: (?globals :: Globals) - => Span -> SpecIndicator -> Type -> Type -> MaybeT Checker (Bool, Type, Substitution) -equalTypesWithPolarity s pol = equalTypesRelatedCoeffectsAndUnify s Eq False pol + => Span -> SpecIndicator -> Type -> Type -> Checker (Bool, Type, Substitution) +equalTypesWithPolarity s pol = equalTypesRelatedCoeffectsAndUnify s Eq pol lEqualTypes :: (?globals :: Globals) - => Span -> Type -> Type -> MaybeT Checker (Bool, Type, Substitution) -lEqualTypes s = equalTypesRelatedCoeffectsAndUnify s ApproximatedBy False SndIsSpec + => Span -> Type -> Type -> Checker (Bool, Type, Substitution) +lEqualTypes s = equalTypesRelatedCoeffectsAndUnify s ApproximatedBy SndIsSpec equalTypes :: (?globals :: Globals) - => Span -> Type -> Type -> MaybeT Checker (Bool, Type, Substitution) -equalTypes s = equalTypesRelatedCoeffectsAndUnify s Eq False SndIsSpec + => Span -> Type -> Type -> Checker (Bool, Type, Substitution) +equalTypes s = equalTypesRelatedCoeffectsAndUnify s Eq SndIsSpec equalTypesWithUniversalSpecialisation :: (?globals :: Globals) - => Span -> Type -> Type -> MaybeT Checker (Bool, Type, Substitution) -equalTypesWithUniversalSpecialisation s = equalTypesRelatedCoeffectsAndUnify s Eq True SndIsSpec + => Span -> Type -> Type -> Checker (Bool, Type, Substitution) +equalTypesWithUniversalSpecialisation s = equalTypesRelatedCoeffectsAndUnify s Eq SndIsSpec {- | Check whether two types are equal, and at the same time generate coeffect equality constraints and unify the @@ -57,8 +58,6 @@ equalTypesRelatedCoeffectsAndUnify :: (?globals :: Globals) => Span -- Explain how coeffects should be related by a solver constraint -> (Span -> Coeffect -> Coeffect -> Type -> Constraint) - -- Whether to allow universal specialisation - -> Bool -- Starting spec indication -> SpecIndicator -- Left type (usually the inferred) @@ -69,10 +68,10 @@ equalTypesRelatedCoeffectsAndUnify :: (?globals :: Globals) -- * a boolean of the equality -- * the most specialised type (after the unifier is applied) -- * the unifier - -> MaybeT Checker (Bool, Type, Substitution) -equalTypesRelatedCoeffectsAndUnify s rel allowUniversalSpecialisation spec t1 t2 = do + -> Checker (Bool, Type, Substitution) +equalTypesRelatedCoeffectsAndUnify s rel spec t1 t2 = do - (eq, unif) <- equalTypesRelatedCoeffects s rel allowUniversalSpecialisation t1 t2 spec + (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 spec if eq then do t2 <- substitute unif t2 @@ -82,6 +81,7 @@ equalTypesRelatedCoeffectsAndUnify s rel allowUniversalSpecialisation spec t1 t2 data SpecIndicator = FstIsSpec | SndIsSpec | PatternCtxt deriving (Eq, Show) +flipIndicator :: SpecIndicator -> SpecIndicator flipIndicator FstIsSpec = SndIsSpec flipIndicator SndIsSpec = FstIsSpec flipIndicator PatternCtxt = PatternCtxt @@ -93,62 +93,62 @@ equalTypesRelatedCoeffects :: (?globals :: Globals) => Span -- Explain how coeffects should be related by a solver constraint -> (Span -> Coeffect -> Coeffect -> Type -> Constraint) - -> Bool -- whether to allow universal specialisation -> Type -> Type -- Indicates whether the first type or second type is a specification -> SpecIndicator - -> MaybeT Checker (Bool, Substitution) -equalTypesRelatedCoeffects s rel uS (FunTy t1 t2) (FunTy t1' t2') sp = do + -> Checker (Bool, Substitution) +equalTypesRelatedCoeffects s rel (FunTy t1 t2) (FunTy t1' t2') sp = do -- contravariant position (always approximate) - (eq1, u1) <- equalTypesRelatedCoeffects s ApproximatedBy uS t1' t1 (flipIndicator sp) + (eq1, u1) <- case sp of + FstIsSpec -> equalTypesRelatedCoeffects s ApproximatedBy t1 t1' (flipIndicator sp) + _ -> equalTypesRelatedCoeffects s ApproximatedBy t1' t1 (flipIndicator sp) -- covariant position (depends: is not always over approximated) t2 <- substitute u1 t2 t2' <- substitute u1 t2' - (eq2, u2) <- equalTypesRelatedCoeffects s rel uS t2 t2' sp + (eq2, u2) <- equalTypesRelatedCoeffects s rel t2 t2' sp unifiers <- combineSubstitutions s u1 u2 return (eq1 && eq2, unifiers) -equalTypesRelatedCoeffects _ _ _ (TyCon con1) (TyCon con2) _ = +equalTypesRelatedCoeffects _ _ (TyCon con1) (TyCon con2) _ = return (con1 == con2, []) --- THE FOLLOWING TWO CASES ARE TEMPORARY UNTIL WE MAKE 'Effect' RICHER +-- THE FOLLOWING FOUR CASES ARE TEMPORARY UNTIL WE MAKE 'Effect' RICHER -- Over approximation by 'IO' "monad" -equalTypesRelatedCoeffects s rel uS (Diamond ef t1) (Diamond ["IO"] t2) sp - = equalTypesRelatedCoeffects s rel uS t1 t2 sp +equalTypesRelatedCoeffects s rel (Diamond ef t1) (Diamond ["IO"] t2) sp + = equalTypesRelatedCoeffects s rel t1 t2 sp -- Under approximation by 'IO' "monad" -equalTypesRelatedCoeffects s rel uS (Diamond ["IO"] t1) (Diamond ef t2) sp - = equalTypesRelatedCoeffects s rel uS t1 t2 sp +equalTypesRelatedCoeffects s rel (Diamond ["IO"] t1) (Diamond ef t2) sp + = equalTypesRelatedCoeffects s rel t1 t2 sp -- Over approximation by 'Session' "monad" -equalTypesRelatedCoeffects s rel uS (Diamond ef t1) (Diamond ["Session"] t2) sp - | "Com" `elem` ef || null ef - = equalTypesRelatedCoeffects s rel uS t1 t2 sp +equalTypesRelatedCoeffects s rel (Diamond ef t1) (Diamond ["Session"] t2) sp + | "Session" `elem` ef || null ef + = equalTypesRelatedCoeffects s rel t1 t2 sp -- Under approximation by 'Session' "monad" -equalTypesRelatedCoeffects s rel uS (Diamond ["Session"] t1) (Diamond ef t2) sp - | "Com" `elem` ef || null ef - = equalTypesRelatedCoeffects s rel uS t1 t2 sp +equalTypesRelatedCoeffects s rel (Diamond ["Session"] t1) (Diamond ef t2) sp + | "Session" `elem` ef || null ef + = equalTypesRelatedCoeffects s rel t1 t2 sp -equalTypesRelatedCoeffects s rel uS (Diamond ef1 t1) (Diamond ef2 t2) sp = do - (eq, unif) <- equalTypesRelatedCoeffects s rel uS t1 t2 sp +equalTypesRelatedCoeffects s rel (Diamond ef1 t1) (Diamond ef2 t2) sp = do + (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp if ef1 == ef2 then return (eq, unif) else -- Effect approximation - if (ef1 `isPrefixOf` ef2) + if all (`elem` ef2) ef1 then return (eq, unif) else -- Communication effect analysis is idempotent - if (nub ef1 == ["Com"] && nub ef2 == ["Com"]) + if (nub ef1 == ["Session"] && nub ef2 == ["Session"]) then return (eq, unif) else - halt $ GradingError (Just s) $ - "Effect mismatch: `" <> pretty ef1 <> "` not equal to `" <> pretty ef2 <> "`" + throw EffectMismatch{ errLoc = s, effExpected = ef1, effActual = ef2 } -equalTypesRelatedCoeffects s rel uS x@(Box c t) y@(Box c' t') sp = do +equalTypesRelatedCoeffects s rel x@(Box c t) y@(Box c' t') sp = do -- Debugging messages debugM "equalTypesRelatedCoeffects (pretty)" $ pretty c <> " == " <> pretty c' debugM "equalTypesRelatedCoeffects (show)" $ "[ " <> show c <> " , " <> show c' <> "]" @@ -158,11 +158,9 @@ equalTypesRelatedCoeffects s rel uS x@(Box c t) y@(Box c' t') sp = do case sp of SndIsSpec -> addConstraint (rel s c c' kind) FstIsSpec -> addConstraint (rel s c' c kind) - _ -> halt $ GenericError (Just s) $ "Trying to unify `" - <> pretty x <> "` and `" - <> pretty y <> "` but in a context where unification is not allowed." + _ -> throw UnificationDisallowed { errLoc = s, errTy1 = x, errTy2 = y } - equalTypesRelatedCoeffects s rel uS t t' sp + equalTypesRelatedCoeffects s rel t t' sp --(eq, subst') <- equalTypesRelatedCoeffects s rel uS t t' sp --case subst of -- Just subst -> do @@ -170,13 +168,13 @@ equalTypesRelatedCoeffects s rel uS x@(Box c t) y@(Box c' t') sp = do -- return (eq, substFinal) -- Nothing -> return (False, []) -equalTypesRelatedCoeffects s _ _ (TyVar n) (TyVar m) _ | n == m = do +equalTypesRelatedCoeffects s _ (TyVar n) (TyVar m) _ | n == m = do checkerState <- get case lookup n (tyVarContext checkerState) of Just _ -> return (True, []) - Nothing -> halt $ UnboundVariableError (Just s) ("Type variable " <> pretty n) + Nothing -> throw UnboundTypeVariable { errLoc = s, errId = n } -equalTypesRelatedCoeffects s _ _ (TyVar n) (TyVar m) sp = do +equalTypesRelatedCoeffects s _ (TyVar n) (TyVar m) sp = do checkerState <- get debugM "variable equality" $ pretty n <> " ~ " <> pretty m <> " where " <> pretty (lookup n (tyVarContext checkerState)) <> " and " @@ -190,148 +188,143 @@ equalTypesRelatedCoeffects s _ _ (TyVar n) (TyVar m) sp = do -- We can unify a universal a dependently bound universal (Just (k1, ForallQ), Just (k2, BoundQ)) -> - tyVarConstraint k2 k1 m n + tyVarConstraint (k1, n) (k2, m) (Just (k1, BoundQ), Just (k2, ForallQ)) -> - tyVarConstraint k1 k2 n m + tyVarConstraint (k1, n) (k2, m) + -- We can unify two instance type variables (Just (k1, InstanceQ), Just (k2, BoundQ)) -> - tyVarConstraint k1 k2 n m + tyVarConstraint (k1, n) (k2, m) -- We can unify two instance type variables (Just (k1, BoundQ), Just (k2, InstanceQ)) -> - tyVarConstraint k1 k2 n m + tyVarConstraint (k1, n) (k2, m) -- We can unify two instance type variables (Just (k1, InstanceQ), Just (k2, InstanceQ)) -> - tyVarConstraint k1 k2 n m + tyVarConstraint (k1, n) (k2, m) -- We can unify two instance type variables (Just (k1, BoundQ), Just (k2, BoundQ)) -> - tyVarConstraint k1 k2 n m - + tyVarConstraint (k1, n) (k2, m) -- But we can unify a forall and an instance (Just (k1, InstanceQ), Just (k2, ForallQ)) -> - tyVarConstraint k1 k2 n m + tyVarConstraint (k1, n) (k2, m) -- But we can unify a forall and an instance (Just (k1, ForallQ), Just (k2, InstanceQ)) -> - tyVarConstraint k2 k1 m n - - -- Trying to unify other (existential) variables - -- (Just (KType, _), Just (k, _)) | k /= KType -> do - -- k <- inferKindOfType s (TyVar m) - -- illKindedUnifyVar s (TyVar n) KType (TyVar m) k - - -- (Just (k, _), Just (KType, _)) | k /= KType -> do --- k <- inferKindOfType s (TyVar n) --- illKindedUnifyVar s (TyVar n) k (TyVar m) KType - - -- Otherwise - --(Just (k1, _), Just (k2, _)) -> - -- tyVarConstraint k1 k2 n m + tyVarConstraint (k1, n) (k2, m) (t1, t2) -> error $ pretty s <> "-" <> show sp <> "\n" <> pretty n <> " : " <> show t1 <> "\n" <> pretty m <> " : " <> show t2 where - tyVarConstraint k1 k2 n m = do + tyVarConstraint (k1, n) (k2, m) = do case k1 `joinKind` k2 of - Just (KPromote (TyCon kc)) | internalName kc /= "Protocol" -> do - -- Don't create solver constraints for sessions- deal with before SMT - addConstraint (Eq s (CVar n) (CVar m) (TyCon kc)) + Just (KPromote (TyCon kc), _) -> do + + k <- inferKindOfType s (TyCon kc) + -- Create solver vars for coeffects + case k of + KCoeffect -> addConstraint (Eq s (CVar n) (CVar m) (TyCon kc)) + _ -> return () return (True, [(n, SubstT $ TyVar m)]) Just _ -> - return (True, [(n, SubstT $ TyVar m)]) + return (True, [(m, SubstT $ TyVar n)]) Nothing -> return (False, []) -- Duality is idempotent (left) -equalTypesRelatedCoeffects s rel uS (TyApp (TyCon d') (TyApp (TyCon d) t)) t' sp +equalTypesRelatedCoeffects s rel (TyApp (TyCon d') (TyApp (TyCon d) t)) t' sp | internalName d == "Dual" && internalName d' == "Dual" = - equalTypesRelatedCoeffects s rel uS t t' sp + equalTypesRelatedCoeffects s rel t t' sp -- Duality is idempotent (right) -equalTypesRelatedCoeffects s rel uS t (TyApp (TyCon d') (TyApp (TyCon d) t')) sp +equalTypesRelatedCoeffects s rel t (TyApp (TyCon d') (TyApp (TyCon d) t')) sp | internalName d == "Dual" && internalName d' == "Dual" = - equalTypesRelatedCoeffects s rel uS t t' sp + equalTypesRelatedCoeffects s rel t t' sp -equalTypesRelatedCoeffects s rel allowUniversalSpecialisation (TyVar n) t sp = do +equalTypesRelatedCoeffects s rel (TyVar n) t sp = do checkerState <- get debugM "Types.equalTypesRelatedCoeffects on TyVar" $ "span: " <> show s - <> "\nallowUniversalSpecialisation: " <> show allowUniversalSpecialisation <> "\nTyVar: " <> show n <> " with " <> show (lookup n (tyVarContext checkerState)) <> "\ntype: " <> show t <> "\nspec indicator: " <> show sp + + k2 <- inferKindOfType s t + + -- Do an occurs check for types + case k2 of + KType -> + if n `elem` freeVars t + then throw OccursCheckFail { errLoc = s, errVar = n, errTy = t } + else return () + _ -> return () + case lookup n (tyVarContext checkerState) of -- We can unify an instance with a concrete type - (Just (k1, q)) | q == InstanceQ || q == BoundQ -> do - k2 <- inferKindOfType s t + (Just (k1, q)) | (q == BoundQ) || (q == InstanceQ) -> do -- && sp /= PatternCtxt + case k1 `joinKind` k2 of - Nothing -> illKindedUnifyVar s (TyVar n) k1 t k2 + Nothing -> throw UnificationKindError + { errLoc = s, errTy1 = (TyVar n), errK1 = k1, errTy2 = t, errK2 = k2 } -- If the kind is Nat, then create a solver constraint - Just (KPromote (TyCon (internalName -> "Nat"))) -> do + Just (KPromote (TyCon (internalName -> "Nat")), _) -> do nat <- compileNatKindedTypeToCoeffect s t addConstraint (Eq s (CVar n) nat (TyCon $ mkId "Nat")) return (True, [(n, SubstT t)]) Just _ -> return (True, [(n, SubstT t)]) - -- Unifying a forall with a concrete type may only be possible if the concrete - -- type is exactly equal to the forall-quantified variable - -- This can only happen for nat indexed types at the moment via the - -- additional equations so performa an additional check if they - -- are both of Nat kind + -- NEW + (Just (k1, ForallQ)) -> do - k1 <- inferKindOfType s (TyVar n) - k2 <- inferKindOfType s t - case k1 `joinKind` k2 of - Just (KPromote (TyCon (internalName -> "Nat"))) -> do - c1 <- compileNatKindedTypeToCoeffect s (TyVar n) - c2 <- compileNatKindedTypeToCoeffect s t - addConstraint $ Eq s c1 c2 (TyCon $ mkId "Nat") - return (True, [(n, SubstT t)]) - x -> - if allowUniversalSpecialisation - then - return (True, [(n, SubstT t)]) - else - halt $ GenericError (Just s) - $ case sp of - FstIsSpec -> "Trying to match a polymorphic type '" <> pretty n - <> "' with monomorphic `" <> pretty t <> "`" - SndIsSpec -> pretty t <> " is not unifiable with " <> pretty (TyVar n) - PatternCtxt -> pretty t <> " is not unifiable with " <> pretty (TyVar n) + -- Infer the kind of this equality + k2 <- inferKindOfType s t + let kind = k1 `joinKind` k2 + + -- If the kind if nat then set up and equation as there might be a + -- pausible equation involving the quantified variable + case kind of + Just (KPromote (TyCon (Id "Nat" "Nat")), _) -> do + c1 <- compileNatKindedTypeToCoeffect s (TyVar n) + c2 <- compileNatKindedTypeToCoeffect s t + addConstraint $ Eq s c1 c2 (TyCon $ mkId "Nat") + return (True, [(n, SubstT t)]) + + _ -> throw UnificationFail{ errLoc = s, errVar = n, errKind = k1, errTy = t } (Just (_, InstanceQ)) -> error "Please open an issue at https://github.com/dorchard/granule/issues" (Just (_, BoundQ)) -> error "Please open an issue at https://github.com/dorchard/granule/issues" - Nothing -> halt $ UnboundVariableError (Just s) (pretty n ("Types.equalTypesRelatedCoeffects: " <> show (tyVarContext checkerState))) + Nothing -> throw UnboundTypeVariable { errLoc = s, errId = n } + -equalTypesRelatedCoeffects s rel uS t (TyVar n) sp = - equalTypesRelatedCoeffects s rel uS (TyVar n) t (flipIndicator sp) +equalTypesRelatedCoeffects s rel t (TyVar n) sp = + equalTypesRelatedCoeffects s rel (TyVar n) t (flipIndicator sp) -- Do duality check (left) [special case of TyApp rule] -equalTypesRelatedCoeffects s rel uS (TyApp (TyCon d) t) t' sp - | internalName d == "Dual" = isDualSession s rel uS t t' sp +equalTypesRelatedCoeffects s rel (TyApp (TyCon d) t) t' sp + | internalName d == "Dual" = isDualSession s rel t t' sp -equalTypesRelatedCoeffects s rel uS t (TyApp (TyCon d) t') sp - | internalName d == "Dual" = isDualSession s rel uS t t' sp +equalTypesRelatedCoeffects s rel t (TyApp (TyCon d) t') sp + | internalName d == "Dual" = isDualSession s rel t t' sp -- Equality on type application -equalTypesRelatedCoeffects s rel uS (TyApp t1 t2) (TyApp t1' t2') sp = do - (one, u1) <- equalTypesRelatedCoeffects s rel uS t1 t1' sp +equalTypesRelatedCoeffects s rel (TyApp t1 t2) (TyApp t1' t2') sp = do + (one, u1) <- equalTypesRelatedCoeffects s rel t1 t1' sp t2 <- substitute u1 t2 t2' <- substitute u1 t2' - (two, u2) <- equalTypesRelatedCoeffects s rel uS t2 t2' sp + (two, u2) <- equalTypesRelatedCoeffects s rel t2 t2' sp unifiers <- combineSubstitutions s u1 u2 return (one && two, unifiers) -equalTypesRelatedCoeffects s rel uS t1 t2 t = do +equalTypesRelatedCoeffects s rel t1 t2 t = do debugM "equalTypesRelatedCoeffects" $ "called on: " <> show t1 <> "\nand:\n" <> show t2 equalOtherKindedTypesGeneric s t1 t2 @@ -340,7 +333,7 @@ equalOtherKindedTypesGeneric :: (?globals :: Globals) => Span -> Type -> Type - -> MaybeT Checker (Bool, Substitution) + -> Checker (Bool, Substitution) equalOtherKindedTypesGeneric s t1 t2 = do k1 <- inferKindOfType s t1 k2 <- inferKindOfType s t2 @@ -355,19 +348,17 @@ equalOtherKindedTypesGeneric s t1 t2 = do KPromote (TyCon (internalName -> "Protocol")) -> sessionInequality s t1 t2 - KType -> nonUnifiable s t1 t2 + KType -> throw UnificationError{ errLoc = s, errTy1 = t1, errTy2 = t2} _ -> - halt $ KindError (Just s) $ "Equality is not defined between kinds " - <> pretty k1 <> " and " <> pretty k2 - <> "\t\n from equality " - <> "'" <> pretty t2 <> "' and '" <> pretty t1 <> "' equal." - else nonUnifiable s t1 t2 + throw UndefinedEqualityKindError + { errLoc = s, errTy1 = t1, errK1 = k1, errTy2 = t2, errK2 = k2 } + else throw UnificationError{ errLoc = s, errTy1 = t1, errTy2 = t2} -- Essentially use to report better error messages when two session type -- are not equality sessionInequality :: (?globals :: Globals) - => Span -> Type -> Type -> MaybeT Checker (Bool, Substitution) + => Span -> Type -> Type -> Checker (Bool, Substitution) sessionInequality s (TyApp (TyCon c) t) (TyApp (TyCon c') t') | internalName c == "Send" && internalName c' == "Send" = do (g, _, u) <- equalTypes s t t' @@ -382,45 +373,43 @@ sessionInequality s (TyCon c) (TyCon c') | internalName c == "End" && internalName c' == "End" = return (True, []) -sessionInequality s t1 t2 = - halt $ GenericError (Just s) - $ "Session type '" <> pretty t1 <> "' is not equal to '" <> pretty t2 <> "'" +sessionInequality s t1 t2 = throw TypeError{ errLoc = s, tyExpected = t1, tyActual = t2 } isDualSession :: (?globals :: Globals) => Span -- Explain how coeffects should be related by a solver constraint -> (Span -> Coeffect -> Coeffect -> Type -> Constraint) - -> Bool -- whether to allow universal specialisation -> Type -> Type -- Indicates whether the first type or second type is a specification -> SpecIndicator - -> MaybeT Checker (Bool, Substitution) -isDualSession sp rel uS (TyApp (TyApp (TyCon c) t) s) (TyApp (TyApp (TyCon c') t') s') ind + -> Checker (Bool, Substitution) +isDualSession sp rel (TyApp (TyApp (TyCon c) t) s) (TyApp (TyApp (TyCon c') t') s') ind | (internalName c == "Send" && internalName c' == "Recv") || (internalName c == "Recv" && internalName c' == "Send") = do - (eq1, u1) <- equalTypesRelatedCoeffects sp rel uS t t' ind - (eq2, u2) <- isDualSession sp rel uS s s' ind + (eq1, u1) <- equalTypesRelatedCoeffects sp rel t t' ind + (eq2, u2) <- isDualSession sp rel s s' ind u <- combineSubstitutions sp u1 u2 return (eq1 && eq2, u) -isDualSession _ _ _ (TyCon c) (TyCon c') _ +isDualSession _ _ (TyCon c) (TyCon c') _ | internalName c == "End" && internalName c' == "End" = return (True, []) -isDualSession sp rel uS t (TyVar v) ind = - equalTypesRelatedCoeffects sp rel uS (TyApp (TyCon $ mkId "Dual") t) (TyVar v) ind +isDualSession sp rel t (TyVar v) ind = + equalTypesRelatedCoeffects sp rel (TyApp (TyCon $ mkId "Dual") t) (TyVar v) ind -isDualSession sp rel uS (TyVar v) t ind = - equalTypesRelatedCoeffects sp rel uS (TyVar v) (TyApp (TyCon $ mkId "Dual") t) ind +isDualSession sp rel (TyVar v) t ind = + equalTypesRelatedCoeffects sp rel (TyVar v) (TyApp (TyCon $ mkId "Dual") t) ind -isDualSession sp _ _ t1 t2 _ = - halt $ GenericError (Just sp) - $ "Session type '" <> pretty t1 <> "' is not dual to '" <> pretty t2 <> "'" +isDualSession sp _ t1 t2 _ = throw + SessionDualityError{ errLoc = sp, errTy1 = t1, errTy2 = t2 } -- Essentially equality on types but join on any coeffects -joinTypes :: (?globals :: Globals) => Span -> Type -> Type -> MaybeT Checker Type +joinTypes :: (?globals :: Globals) => Span -> Type -> Type -> Checker Type +joinTypes s t t' | t == t' = return t + joinTypes s (FunTy t1 t2) (FunTy t1' t2') = do t1j <- joinTypes s t1' t1 -- contravariance t2j <- joinTypes s t2 t2' @@ -435,8 +424,7 @@ joinTypes s (Diamond ef t) (Diamond ef' t') = do else if ef' `isPrefixOf` ef then return (Diamond ef tj) - else halt $ GradingError (Just s) $ - "Effect mismatch: " <> pretty ef <> " not equal to " <> pretty ef' + else throw EffectMismatch{ errLoc = s, effExpected = ef, effActual = ef' } joinTypes s (Box c t) (Box c' t') = do coeffTy <- mguCoeffectTypes s c c' @@ -448,8 +436,6 @@ joinTypes s (Box c t) (Box c' t') = do tUpper <- joinTypes s t t' return $ Box (CVar topVar) tUpper -joinTypes _ (TyInt n) (TyInt m) | n == m = return $ TyInt n - joinTypes s (TyInt n) (TyVar m) = do -- Create a fresh coeffect variable let ty = TyCon $ mkId "Nat" @@ -461,23 +447,27 @@ joinTypes s (TyInt n) (TyVar m) = do joinTypes s (TyVar n) (TyInt m) = joinTypes s (TyInt m) (TyVar n) joinTypes s (TyVar n) (TyVar m) = do - -- Create fresh variables for the two tyint variables - -- TODO: how do we know they are tyints? Looks suspicious - --let kind = TyCon $ mkId "Nat" - --nvar <- freshTyVarInContext n kind - --mvar <- freshTyVarInContext m kind - -- Unify the two variables into one - --addConstraint (ApproximatedBy s (CVar nvar) (CVar mvar) kind) - --return $ TyVar n - -- TODO: FIX. The above can't be right. - error $ "Trying to join two type variables: " ++ pretty n ++ " and " ++ pretty m + + kind <- inferKindOfType s (TyVar n) + case kind of + KPromote t -> do + + nvar <- freshTyVarInContextWithBinding n kind BoundQ + -- Unify the two variables into one + addConstraint (ApproximatedBy s (CVar n) (CVar nvar) t) + addConstraint (ApproximatedBy s (CVar m) (CVar nvar) t) + return $ TyVar nvar + + _ -> error $ "Trying to join two type variables: " ++ pretty n ++ " and " ++ pretty m joinTypes s (TyApp t1 t2) (TyApp t1' t2') = do t1'' <- joinTypes s t1 t1' t2'' <- joinTypes s t2 t2' return (TyApp t1'' t2'') -joinTypes s t1 t2 = do - halt $ GenericError (Just s) - $ "Type '" <> pretty t1 <> "' and '" - <> pretty t2 <> "' have no upper bound" +-- TODO: Create proper substitutions +joinTypes s (TyVar _) t = return t +joinTypes s t (TyVar _) = return t + +joinTypes s t1 t2 = throw + NoUpperBoundError{ errLoc = s, errTy1 = t1, errTy2 = t2 } diff --git a/frontend/src/Language/Granule/Checker/Variables.hs b/frontend/src/Language/Granule/Checker/Variables.hs index 73400cd43..c677ccd9b 100644 --- a/frontend/src/Language/Granule/Checker/Variables.hs +++ b/frontend/src/Language/Granule/Checker/Variables.hs @@ -2,7 +2,6 @@ module Language.Granule.Checker.Variables where -import Control.Monad.Trans.Maybe import Control.Monad.State.Strict import qualified Data.Map as M @@ -14,19 +13,18 @@ import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Type import Language.Granule.Context -import Language.Granule.Utils -- | Generate a fresh alphanumeric identifier name string -freshIdentifierBase :: String -> MaybeT Checker String +freshIdentifierBase :: String -> Checker String freshIdentifierBase s = do checkerState <- get let vmap = uniqueVarIdCounterMap checkerState let s' = takeWhile (\c -> c /= '`') s case M.lookup s' vmap of Nothing -> do - let vmap' = M.insert s' 0 vmap + let vmap' = M.insert s' 1 vmap put checkerState { uniqueVarIdCounterMap = vmap' } - return $ s' + return $ s' <> "." <> show 0 Just n -> do let vmap' = M.insert s' (n+1) vmap @@ -35,14 +33,13 @@ freshIdentifierBase s = do -- | Helper for creating a few (existential) coeffect variable of a particular -- coeffect type. -freshTyVarInContext :: (?globals :: Globals) => Id -> Kind -> MaybeT Checker Id +freshTyVarInContext :: Id -> Kind -> Checker Id freshTyVarInContext cvar k = do freshTyVarInContextWithBinding cvar k InstanceQ -- | Helper for creating a few (existential) coeffect variable of a particular -- coeffect type. -freshTyVarInContextWithBinding :: - (?globals :: Globals) => Id -> Kind -> Quantifier -> MaybeT Checker Id +freshTyVarInContextWithBinding :: Id -> Kind -> Quantifier -> Checker Id freshTyVarInContextWithBinding var k q = do freshName <- freshIdentifierBase (internalName var) let var' = mkId freshName @@ -50,8 +47,7 @@ freshTyVarInContextWithBinding var k q = do return var' -- | Helper for registering a new coeffect variable in the checker -registerTyVarInContext :: - (?globals :: Globals) => Id -> Kind -> Quantifier -> MaybeT Checker () +registerTyVarInContext :: Id -> Kind -> Quantifier -> Checker () registerTyVarInContext v k q = do modify (\st -> st { tyVarContext = (v, (k, q)) : tyVarContext st }) diff --git a/frontend/src/Language/Granule/Context.hs b/frontend/src/Language/Granule/Context.hs index 9147d7b39..5ca319415 100644 --- a/frontend/src/Language/Granule/Context.hs +++ b/frontend/src/Language/Granule/Context.hs @@ -8,8 +8,7 @@ module Language.Granule.Context where import Data.Maybe (isJust) import Data.List (sortBy) -import Language.Granule.Syntax.Identifiers (Id, sourceName) -import Language.Granule.Utils +import Language.Granule.Syntax.Identifiers (Id) -- | Type of contexts type Ctxt t = [(Id, t)] @@ -19,10 +18,10 @@ extendShadow :: Ctxt a -> Id -> a -> Ctxt a extendShadow ctxt i v = (i, v) : ctxt -- | Extend an context with a new value, ensure that the name is not in the context -extend :: Ctxt a -> Id -> a -> Result (Ctxt a) +extend :: Ctxt a -> Id -> a -> Maybe (Ctxt a) extend ctxt i v = case lookup i ctxt of - Nothing -> Some $ (i, v) : ctxt - _ -> None ["Name clash: `" <> sourceName i <> "` was already in the context."] + Nothing -> Just ((i, v) : ctxt) + _ -> Nothing -- | Empty context empty :: Ctxt a @@ -37,6 +36,11 @@ replace ((name', _):ctxt) name v | name == name' replace (x : ctxt) name v = x : replace ctxt name v +-- | Map over the just elements of the context (and not the keys (identifiers)) +ctxtMap :: (a -> b) -> Ctxt a -> Ctxt b +ctxtMap f [] = [] +ctxtMap f ((v, x):ctxt) = (v, f x) : ctxtMap f ctxt + -- $setup -- >>> import Language.Granule.Syntax.Identifiers (mkId) {- | Take the intersection of two contexts based on keys @@ -71,3 +75,11 @@ deleteVar x ((y, b) : m) | x == y = deleteVar x m relevantSubCtxt :: [Id] -> Ctxt t -> Ctxt t relevantSubCtxt vars = filter relevant where relevant (var, _) = var `elem` vars + +lookupAndCutout :: Id -> Ctxt t -> Maybe (Ctxt t, t) +lookupAndCutout _ [] = Nothing +lookupAndCutout v ((v', t):ctxt) | v == v' = + Just (ctxt, t) +lookupAndCutout v ((v', t'):ctxt) = do + (ctxt', t) <- lookupAndCutout v ctxt + Just ((v', t') : ctxt', t) diff --git a/frontend/src/Language/Granule/Syntax/Def.hs b/frontend/src/Language/Granule/Syntax/Def.hs index 19e750394..943ad7a8e 100644 --- a/frontend/src/Language/Granule/Syntax/Def.hs +++ b/frontend/src/Language/Granule/Syntax/Def.hs @@ -10,8 +10,10 @@ module Language.Granule.Syntax.Def where import Data.List ((\\), delete) +import Data.Set (Set) import GHC.Generics (Generic) +import Language.Granule.Context (Ctxt) import Language.Granule.Syntax.FirstParameter import Language.Granule.Syntax.Helpers import Language.Granule.Syntax.Identifiers @@ -24,25 +26,21 @@ import Language.Granule.Syntax.Pattern -- | Comprise a list of data type declarations and a list -- | of expression definitions -- | where `v` is the type of values and `a` annotations -data AST v a = AST [DataDecl] [Def v a] +data AST v a = AST [DataDecl] [Def v a] (Set Import) deriving instance (Show (Def v a), Show a) => Show (AST v a) deriving instance (Eq (Def v a), Eq a) => Eq (AST v a) -class Definition d where - definitionSpan :: d -> Span - definitionIdentifier :: d -> Id - definitionTypeScheme :: d -> TypeScheme +type Import = FilePath -- | Function definitions -data Def v a = - Def { - defSpan :: Span, - defIdentifier :: Id, - defEquations :: [Equation v a], - defTypeScheme :: TypeScheme } - deriving Generic +data Def v a = Def + { defSpan :: Span + , defId :: Id + , defEquations :: [Equation v a] + , defTypeScheme :: TypeScheme + } + deriving Generic -instance FirstParameter (Def v a) Span deriving instance (Eq v, Eq a) => Eq (Def v a) deriving instance (Show v, Show a) => Show (Def v a) @@ -59,30 +57,28 @@ deriving instance (Eq v, Eq a) => Eq (Equation v a) deriving instance (Show v, Show a) => Show (Equation v a) instance FirstParameter (Equation v a) Span -instance Definition (Def ev a) where - definitionSpan = getSpan - definitionIdentifier = defIdentifier - definitionTypeScheme = defTypeScheme - -definitionType :: (Definition d) => d -> Type -definitionType def = - ty where (Forall _ _ _ ty) = definitionTypeScheme def +definitionType :: Def v a -> Type +definitionType Def { defTypeScheme = ts } = + ty where (Forall _ _ _ ty) = ts -- | Data type declarations -data DataDecl = DataDecl { - dataDeclSpan :: Span, - dataDeclName :: Id, - dataDeclMembers :: [(Id,Kind)], - dataDeclKind :: (Maybe Kind), - dataDeclConstructors :: [DataConstr] } - deriving (Generic, Show, Eq) +data DataDecl = DataDecl + { dataDeclSpan :: Span + , dataDeclId :: Id + , dataDeclTyVarCtxt :: Ctxt Kind + , dataDeclKindAnn :: Maybe Kind + , dataDeclDataConstrs :: [DataConstr] + } + deriving (Generic, Show, Eq) instance FirstParameter DataDecl Span -- | Data constructors data DataConstr - = DataConstrIndexed Span Id TypeScheme -- ^ GADTs - | DataConstrNonIndexed Span Id [Type] -- ^ ADTs + = DataConstrIndexed + { dataConstrSpan :: Span, dataConstrId :: Id, dataConstrTypeScheme :: TypeScheme } -- ^ GADTs + | DataConstrNonIndexed + { dataConstrSpan :: Span, dataConstrId :: Id, dataConstrParams :: [Type] } -- ^ ADTs deriving (Eq, Show, Generic) nonIndexedToIndexedDataConstr :: Id -> [(Id, Kind)] -> DataConstr -> DataConstr @@ -102,8 +98,8 @@ type Cardinality = Maybe Nat -- | Fresh a whole AST freshenAST :: AST v a -> AST v a -freshenAST (AST dds defs) = - AST dds' defs' +freshenAST (AST dds defs imports) = + AST dds' defs' imports where (dds', defs') = (map runFreshener dds, map runFreshener defs) instance Monad m => Freshenable m DataDecl where diff --git a/frontend/src/Language/Granule/Syntax/Expr.hs b/frontend/src/Language/Granule/Syntax/Expr.hs index f647a90d9..ffe771140 100755 --- a/frontend/src/Language/Granule/Syntax/Expr.hs +++ b/frontend/src/Language/Granule/Syntax/Expr.hs @@ -10,6 +10,8 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} +{-# options_ghc -Wno-missing-pattern-synonym-signatures #-} + module Language.Granule.Syntax.Expr where import GHC.Generics (Generic) @@ -94,6 +96,18 @@ data ExprF ev a expr value = | CaseF Span a expr [(Pattern a, expr)] deriving (Generic, Eq) +data Operator + = OpLesser + | OpLesserEq + | OpGreater + | OpGreaterEq + | OpEq + | OpNotEq + | OpPlus + | OpTimes + | OpMinus + deriving (Generic, Eq, Ord, Show) + deriving instance (Show ev, Show a, Show value, Show expr) => Show (ExprF ev a value expr) @@ -111,7 +125,7 @@ pattern Val sp a val = (ExprFix2 (ValF sp a val)) pattern Case sp a swexp arms = (ExprFix2 (CaseF sp a swexp arms)) {-# COMPLETE App, Binop, LetDiamond, Val, Case #-} -instance (Bifunctor (f ev a), Bifunctor (g ev a)) +instance Bifunctor (f ev a) => Birecursive (ExprFix2 f g ev a) (ExprFix2 g f ev a) where project = unExprFix diff --git a/frontend/src/Language/Granule/Syntax/FirstParameter.hs b/frontend/src/Language/Granule/Syntax/FirstParameter.hs index e3ae80743..420b396c5 100644 --- a/frontend/src/Language/Granule/Syntax/FirstParameter.hs +++ b/frontend/src/Language/Granule/Syntax/FirstParameter.hs @@ -42,7 +42,7 @@ instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :+: b) setFirstParameter' e (L1 a) = L1 $ setFirstParameter' e a setFirstParameter' e (R1 a) = R1 $ setFirstParameter' e a -instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :*: b) e where +instance GFirstParameter a e => GFirstParameter (a :*: b) e where getFirstParameter' (a :*: _) = getFirstParameter' a setFirstParameter' e (a :*: b) = (setFirstParameter' e a :*: b) diff --git a/frontend/src/Language/Granule/Syntax/Helpers.hs b/frontend/src/Language/Granule/Syntax/Helpers.hs index ddaa4aaa6..8d1966555 100644 --- a/frontend/src/Language/Granule/Syntax/Helpers.hs +++ b/frontend/src/Language/Granule/Syntax/Helpers.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# options_ghc -Wno-orphans #-} + module Language.Granule.Syntax.Helpers where import Data.List (delete) diff --git a/frontend/src/Language/Granule/Syntax/Lexer.x b/frontend/src/Language/Granule/Syntax/Lexer.x index 717341eac..46e3d6b4c 100755 --- a/frontend/src/Language/Granule/Syntax/Lexer.x +++ b/frontend/src/Language/Granule/Syntax/Lexer.x @@ -16,7 +16,7 @@ import Data.Text (Text) %wrapper "posn" $digit = 0-9 -$alpha = [a-zA-Z\_\=] +$alpha = [a-zA-Z\_\-\=] $lower = [a-z] $upper = [A-Z] $eol = [\n] @@ -26,8 +26,9 @@ $fruit = [\127815-\127827] -- 🍇🍈🍉🍊🍋🍌🍍🍎🍏🍐🍑🍒 @constr = ($upper ($alphanum | \')* | \(\)) @float = \-? $digit+ \. $digit+ @int = \-? $digit+ -@charLiteral = \' ([\\.] | . ) \' +@charLiteral = \' ([\\.]|[^\']| . ) \' @stringLiteral = \"(\\.|[^\"]|\n)*\" +@importFilePath = ($alphanum | \' | \.)* tokens :- @@ -36,7 +37,7 @@ tokens :- $white+ ; "--".* ; "{-" (\\.|[^\{\-]|\n)* "-}" ; - "import".* ; + import$white+@importFilePath { \p s -> TokenImport p s } @constr { \p s -> TokenConstr p s } forall { \p s -> TokenForall p } ∀ { \p s -> TokenForall p } @@ -61,6 +62,7 @@ tokens :- \; { \p s -> TokenSemicolon p } \= { \p s -> TokenEq p } "/=" { \p s -> TokenNeq p } + "≠" { \p _ -> TokenNeq p } \\ { \p s -> TokenLambda p } "λ" { \p s -> TokenLambda p } \[ { \p s -> TokenBoxLeft p } @@ -82,19 +84,22 @@ tokens :- \_ { \p _ -> TokenUnderscore p } \| { \p s -> TokenPipe p } \/ { \p s -> TokenForwardSlash p } - "≤" { \p s -> TokenOp p s } - \<\= { \p s -> TokenOp p "≤" } - "≥" { \p s -> TokenOp p s } - \>\= { \p s -> TokenOp p "≥" } - "≡" { \p s -> TokenOp p s } - \=\= { \p s -> TokenOp p "≡" } - \` { \p s -> TokenBackTick p } - \^ { \p s -> TokenCaret p } + "≤" { \p s -> TokenLesserEq p } + "<=" { \p s -> TokenLesserEq p } + "≥" { \p s -> TokenGreaterEq p } + ">=" { \p s -> TokenGreaterEq p } + "==" { \p s -> TokenEquiv p } + "≡" { \p s -> TokenEquiv p } + "`" { \p s -> TokenBackTick p } + "^" { \p s -> TokenCaret p } ".." { \p s -> TokenDotDot p } "∨" { \p _ -> TokenJoin p } + "\\/" { \p _ -> TokenJoin p } "∧" { \p _ -> TokenMeet p } + "/\\" { \p _ -> TokenMeet p } "=>" { \p s -> TokenConstrain p } "⇒" { \p s -> TokenConstrain p } + "∘" { \p _ -> TokenRing p } { @@ -147,16 +152,19 @@ data Token | TokenUnderscore AlexPosn | TokenSemicolon AlexPosn | TokenForwardSlash AlexPosn - | TokenOp AlexPosn String + | TokenLesserEq AlexPosn + | TokenGreaterEq AlexPosn + | TokenEquiv AlexPosn | TokenCaret AlexPosn | TokenDotDot AlexPosn | TokenJoin AlexPosn | TokenMeet AlexPosn + | TokenRing AlexPosn + | TokenImport AlexPosn String deriving (Eq, Show, Generic) symString :: Token -> String symString (TokenSym _ x) = x -symString (TokenOp _ x) = x constrString :: Token -> String constrString (TokenConstr _ x) = x diff --git a/frontend/src/Language/Granule/Syntax/Parser.y b/frontend/src/Language/Granule/Syntax/Parser.y index 08a73bfad..3d5239099 100644 --- a/frontend/src/Language/Granule/Syntax/Parser.y +++ b/frontend/src/Language/Granule/Syntax/Parser.y @@ -4,13 +4,15 @@ module Language.Granule.Syntax.Parser where -import Control.Monad (forM) +import Control.Monad (forM, when, unless) import Control.Monad.Trans.Reader import Control.Monad.Trans.Class (lift) -import Data.List ((\\), intercalate, nub, stripPrefix) +import Data.Char (isSpace) +import Data.Foldable (toList) +import Data.List (intercalate, nub, stripPrefix) import Data.Maybe (mapMaybe) +import Data.Set (Set, (\\), fromList, insert, singleton) import Numeric -import System.Exit (die) import System.FilePath (()) import Language.Granule.Syntax.Identifiers @@ -44,6 +46,7 @@ import Language.Granule.Utils hiding (mkSpan) else { TokenElse _ } case { TokenCase _ } of { TokenOf _ } + import { TokenImport _ _ } INT { TokenInt _ _ } FLOAT { TokenFloat _ _} VAR { TokenSym _ _ } @@ -60,6 +63,7 @@ import Language.Granule.Utils hiding (mkSpan) ',' { TokenComma _ } '×' { TokenCross _ } '=' { TokenEq _ } + '==' { TokenEquiv _ } '/=' { TokenNeq _ } '+' { TokenAdd _ } '-' { TokenSub _ } @@ -73,24 +77,25 @@ import Language.Granule.Utils hiding (mkSpan) ']' { TokenBoxRight _ } '<' { TokenLangle _ } '>' { TokenRangle _ } - OP { TokenOp _ _ } - '<=' { TokenOp _ "≤" } - '>=' { TokenOp _ "≥" } + '<=' { TokenLesserEq _ } + '>=' { TokenGreaterEq _ } '|' { TokenPipe _ } '_' { TokenUnderscore _ } ';' { TokenSemicolon _ } '.' { TokenPeriod _ } '`' { TokenBackTick _ } '^' { TokenCaret _ } - ".." { TokenDotDot _ } - "∨" { TokenJoin _ } - "∧" { TokenMeet _ } + '..' { TokenDotDot _ } + "\\/" { TokenJoin _ } + "/\\" { TokenMeet _ } + '∘' { TokenRing _ } +%right '∘' %right in %right '->' %left ':' %right '×' -%left ".." +%left '..' %left '+' '-' %left '*' %left '^' @@ -99,15 +104,21 @@ import Language.Granule.Utils hiding (mkSpan) %% Defs :: { AST () () } - : Def { AST [] [$1] } - | DataDecl { AST [$1] [] } - | DataDecl NL Defs { let (AST dds defs) = $3 in AST ($1 : dds) defs } - | Def NL Defs { let (AST dds defs) = $3 in AST dds ($1 : defs) } - -- | NL { AST [] [] } + : Def { AST [] [$1] mempty } + | DataDecl { AST [$1] [] mempty } + | Import { AST [] [] (singleton $1) } + | DataDecl NL Defs { let (AST dds defs imprts) = $3 in AST ($1 : dds) defs imprts } + | Def NL Defs { let (AST dds defs imprts) = $3 in AST dds ($1 : defs) imprts } + | Import NL Defs { let (AST dds defs imprts) = $3 in AST dds defs (insert $1 imprts) } NL :: { () } - : nl NL { } - | nl { } + : nl NL { } + | nl { } + +Import :: { Import } + : import { let TokenImport _ ('i':'m':'p':'o':'r':'t':path) = $1 + in dropWhile isSpace path <> ".gr" + } Def :: { Def () () } : Sig NL Bindings @@ -155,10 +166,11 @@ Binding :: { (Maybe String, Equation () ()) } span <- mkSpan (getPos $1, getEnd $4) return (Just $ symString $1, Equation span () $2 $4) } - | '|' Pats '=' Expr - {% do - span <- mkSpan (getPos $1, getEnd $4) - return (Nothing, Equation span () $2 $4) } +-- this was probably a silly idea @buggymcbugfix + -- | '|' Pats '=' Expr + -- {% do + -- span <- mkSpan (getPos $1, getEnd $4) + -- return (Nothing, Equation span () $2 $4) } DataConstrs :: { [DataConstr] } : DataConstr DataConstrNext { $1 : $2 } @@ -215,9 +227,13 @@ PAtom :: { Pattern () } | '[' NAryConstr ']' {% (mkSpan (getPos $1, getPos $3)) >>= \sp -> return $ PBox sp () $2 } - | '(' PAtom ',' PAtom ')' + | '(' PMolecule ',' PMolecule ')' {% (mkSpan (getPos $1, getPos $5)) >>= \sp -> return $ PConstr sp () (mkId ",") [$2, $4] } +PMolecule :: { Pattern () } + : NAryConstr { $1 } + | PAtom { $1 } + NAryConstr :: { Pattern () } : CONSTR Pats {% let TokenConstr _ x = $1 in (mkSpan (getPos $1, getEnd $ last $2)) >>= @@ -228,7 +244,7 @@ ForallSig :: { [(Id, Kind)] } | VarSigs { $1 } Forall :: { (((Pos, Pos), [(Id, Kind)]), [Type]) } - : forall ForallSig '.' { (((getPos $1, getPos $3), $2), []) } + : forall ForallSig '.' { (((getPos $1, getPos $3), $2), []) } | forall ForallSig '.' '{' Constraints '}' '=>' { (((getPos $1, getPos $7), $2), $5) } Constraints :: { [Type] } @@ -244,12 +260,18 @@ TypeScheme :: { TypeScheme } {% (mkSpan (fst $ fst $1)) >>= \sp -> return $ Forall sp (snd $ fst $1) (snd $1) $2 } VarSigs :: { [(Id, Kind)] } - : VarSig ',' VarSigs { $1 : $3 } - | VarSig { [$1] } + : VarSig ',' VarSigs { $1 <> $3 } + | VarSig { $1 } -VarSig :: { (Id, Kind) } - : VAR ':' Kind { (mkId $ symString $1, $3) } +VarSig :: { [(Id, Kind)] } + : Vars1 ':' Kind { map (\id -> (mkId id, $3)) $1 } + | Vars1 { flip concatMap $1 (\id -> let k = mkId ("_k" <> id) + in [(mkId id, KVar k)]) } +-- A non-empty list of variables +Vars1 :: { [String] } + : VAR { [symString $1] } + | VAR Vars1 { symString $1 : $2 } Kind :: { Kind } : Kind '->' Kind { KFun $1 $3 } @@ -280,20 +302,20 @@ TyJuxt :: { Type } : TyJuxt '`' TyAtom '`' { TyApp $3 $1 } | TyJuxt TyAtom { TyApp $1 $2 } | TyAtom { $1 } - | TyAtom '+' TyAtom { TyInfix ("+") $1 $3 } - | TyAtom '-' TyAtom { TyInfix "-" $1 $3 } - | TyAtom '*' TyAtom { TyInfix ("*") $1 $3 } - | TyAtom '^' TyAtom { TyInfix ("^") $1 $3 } - | TyAtom "∧" TyAtom { TyInfix ("∧") $1 $3 } - | TyAtom "∨" TyAtom { TyInfix ("∨") $1 $3 } + | TyAtom '+' TyAtom { TyInfix TyOpPlus $1 $3 } + | TyAtom '-' TyAtom { TyInfix TyOpMinus $1 $3 } + | TyAtom '*' TyAtom { TyInfix TyOpTimes $1 $3 } + | TyAtom '^' TyAtom { TyInfix TyOpExpon $1 $3 } + | TyAtom "/\\" TyAtom { TyInfix TyOpMeet $1 $3 } + | TyAtom "\\/" TyAtom { TyInfix TyOpJoin $1 $3 } Constraint :: { Type } - : TyAtom '>' TyAtom { TyInfix (">") $1 $3 } - | TyAtom '<' TyAtom { TyInfix ("<") $1 $3 } - | TyAtom '>=' TyAtom { TyInfix (">=") $1 $3 } - | TyAtom '<=' TyAtom { TyInfix ("<=") $1 $3 } - | TyAtom '=' TyAtom { TyInfix ("=") $1 $3 } - | TyAtom '/=' TyAtom { TyInfix ("/=") $1 $3 } + : TyAtom '>' TyAtom { TyInfix TyOpGreater $1 $3 } + | TyAtom '<' TyAtom { TyInfix TyOpLesser $1 $3 } + | TyAtom '<=' TyAtom { TyInfix TyOpLesserEq $1 $3 } + | TyAtom '>=' TyAtom { TyInfix TyOpGreaterEq $1 $3 } + | TyAtom '==' TyAtom { TyInfix TyOpEq $1 $3 } + | TyAtom '/=' TyAtom { TyInfix TyOpNotEq $1 $3 } TyAtom :: { Type } : CONSTR { TyCon $ mkId $ constrString $1 } @@ -313,19 +335,21 @@ Coeffect :: { Coeffect } | CONSTR { case (constrString $1) of "Public" -> Level publicRepresentation "Private" -> Level privateRepresentation + "Unused" -> Level unusedRepresentation "Inf" -> infinity x -> error $ "Unknown coeffect constructor `" <> x <> "`" } | VAR { CVar (mkId $ symString $1) } - | Coeffect ".." Coeffect { CInterval $1 $3 } + | Coeffect '..' Coeffect { CInterval $1 $3 } | Coeffect '+' Coeffect { CPlus $1 $3 } | Coeffect '*' Coeffect { CTimes $1 $3 } | Coeffect '-' Coeffect { CMinus $1 $3 } | Coeffect '^' Coeffect { CExpon $1 $3 } - | Coeffect "∧" Coeffect { CMeet $1 $3 } - | Coeffect "∨" Coeffect { CJoin $1 $3 } + | Coeffect "/\\" Coeffect { CMeet $1 $3 } + | Coeffect "\\/" Coeffect { CJoin $1 $3 } | '(' Coeffect ')' { $2 } | '{' Set '}' { CSet $2 } | Coeffect ':' Type { normalise (CSig $1 $3) } + | '(' Coeffect ',' Coeffect ')' { CProduct $2 $4 } Set :: { [(String, Type)] } : VAR ':' Type ',' Set { (symString $1, $3) : $5 } @@ -384,6 +408,10 @@ LetBind :: { (Pos, Pattern (), Maybe Type, Expr () ()) } { (getStart $1, $1, Just $3, $5) } | PAtom '=' Expr { (getStart $1, $1, Nothing, $3) } + | NAryConstr ':' Type '=' Expr + { (getStart $1, $1, Just $3, $5) } + | NAryConstr '=' Expr + { (getStart $1, $1, Nothing, $3) } MultiLet :: { Expr () () } MultiLet @@ -421,12 +449,16 @@ Case :: { (Pattern (), Expr () ()) } | NAryConstr '->' Expr { ($1, $3) } Form :: { Expr () () } - : Form '+' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () "+" $1 $3 } - | Form '-' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () "-" $1 $3 } - | Form '*' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () "*" $1 $3 } - | Form '<' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () "<" $1 $3 } - | Form '>' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () ">" $1 $3 } - | Form OP Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () (symString $2) $1 $3 } + : Form '+' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpPlus $1 $3 } + | Form '-' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpMinus $1 $3 } + | Form '*' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpTimes $1 $3 } + | Form '<' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpLesser $1 $3 } + | Form '>' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpGreater $1 $3 } + | Form '<=' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpLesserEq $1 $3 } + | Form '>=' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpGreaterEq $1 $3 } + | Form '==' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpEq $1 $3 } + | Form '/=' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ Binop sp () OpNotEq $1 $3 } + | Form '∘' Form {% (mkSpan $ getPosToSpan $2) >>= \sp -> return $ App sp () (App sp () (Val sp () (Var () (mkId "compose"))) $1) $3 } | Juxt { $1 } Juxt :: { Expr () () } @@ -439,7 +471,7 @@ Atom :: { Expr () () } | INT {% let (TokenInt _ x) = $1 in (mkSpan $ getPosToSpan $1) >>= \sp -> return $ Val sp () $ NumInt x } - + -- | '<' Expr '>' {% (mkSpan (getPos $1, getPos $3)) >>= \sp -> return $ App sp () (Val sp () (Var () (mkId "pure"))) $2 } | FLOAT {% let (TokenFloat _ x) = $1 in (mkSpan $ getPosToSpan $1) >>= \sp -> return $ Val sp () $ NumFloat $ read x } @@ -472,7 +504,9 @@ mkSpan (start, end) = do parseError :: [Token] -> ReaderT String (Either String) a parseError [] = lift $ Left "Premature end of file" -parseError t = lift . Left $ show l <> ":" <> show c <> ": parse error" +parseError t = do + file <- ask + lift . Left $ file <> ":" <> show l <> ":" <> show c <> ": parse error" where (l, c) = getPos (head t) parseDefs :: FilePath -> String -> Either String (AST () ()) @@ -485,51 +519,36 @@ parseAndDoImportsAndFreshenDefs input = do parseDefsAndDoImports :: (?globals :: Globals) => String -> IO (AST () ()) parseDefsAndDoImports input = do - defs <- either die return $ parseDefs (sourceFilePath ?globals) input - importedDefs <- forM imports $ \path -> do - src <- readFile path - let ?globals = ?globals { sourceFilePath = path } - parseDefsAndDoImports src - let allDefs = merge $ defs : importedDefs - checkNameClashes allDefs - checkMatchingNumberOfArgs allDefs - return allDefs - + AST dds defs imports <- either error return $ parseDefs sourceFilePath input + doImportsRecursively imports (AST dds defs mempty) where - merge :: [AST () ()] -> AST () () - merge xs = - let conc [] dds defs = AST dds defs - conc ((AST dds defs):xs) ddsAcc defsAcc = conc xs (dds <> ddsAcc) (defs <> defsAcc) - in conc xs [] [] - - imports = map ((includePath ?globals ) . (<> ".gr") . replace '.' '/') - . mapMaybe (stripPrefix "import ") . lines $ input - - replace from to = map (\c -> if c == from then to else c) - - checkMatchingNumberOfArgs ds@(AST dataDecls defs) = - mapM checkMatchingNumberOfArgs' defs - - checkMatchingNumberOfArgs' (Def _ name eqs _) = - if length eqs >= 1 - then if (and $ map (\x -> x == head lengths) lengths) - then return () - else - die $ "Syntax error: Number of arguments differs in the equattypeConstructorns of " - <> sourceName name - else return () - where - lengths = map (\(Equation _ _ pats _) -> length pats) eqs - - - checkNameClashes ds@(AST dataDecls defs) = - if null clashes - then return () - else die $ "Error: Name clash: " <> intercalate ", " (map sourceName clashes) - where - clashes = names \\ nub names - names = (`map` dataDecls) (\(DataDecl _ name _ _ _) -> name) - <> (`map` defs) (\(Def _ name _ _) -> name) + -- Get all (transitive) dependencies. TODO: blows up when the file imports itself + doImportsRecursively :: Set Import -> AST () () -> IO (AST () ()) + doImportsRecursively todo ast@(AST dds defs done) = do + case toList (todo \\ done) of + [] -> return ast + (i:todo) -> + let path = includePath i in + let ?globals = ?globals { globalsSourceFilePath = Just path } in do + src <- readFile path + let AST dds' defs' imports' = either error id (parseDefs path src) + doImportsRecursively + (fromList todo <> imports') + (AST (dds' <> dds) (defs' <> defs) (insert i done)) + + -- the following check doesn't seem to be needed because this comes up during type checking @buggymcbugfix + -- checkMatchingNumberOfArgs ds@(AST dataDecls defs) = + -- mapM checkMatchingNumberOfArgs' defs + + -- checkMatchingNumberOfArgs' (Def _ name eqs _) = + -- when (length eqs >= 1 && any (/= head lengths) lengths) + -- ( error $ "Syntax error: Number of arguments differs in the equations of `" + -- <> sourceName name <> "`" + -- ) + -- where + -- lengths = map (\(Equation _ _ pats _) -> length pats) eqs + + lastSpan [] = fst $ nullSpanLocs lastSpan xs = getEnd . snd . last $ xs diff --git a/frontend/src/Language/Granule/Syntax/Pattern.hs b/frontend/src/Language/Granule/Syntax/Pattern.hs index ab4d74964..9932d7961 100644 --- a/frontend/src/Language/Granule/Syntax/Pattern.hs +++ b/frontend/src/Language/Granule/Syntax/Pattern.hs @@ -110,9 +110,9 @@ ppair s annotation left right = -- PVar ((0,0),(0,0)) (Id "x" "x_0") -- | Freshening for patterns -instance Monad m => Freshenable m (Pattern a) where +instance Freshenable m (Pattern a) where - freshen :: Pattern a -> Freshener m (Pattern a) + freshen :: Monad m => Pattern a -> Freshener m (Pattern a) freshen (PVar s a var) = do var' <- freshIdentifierBase Value var return $ PVar s a var' diff --git a/frontend/src/Language/Granule/Syntax/Preprocessor/Ascii.hs b/frontend/src/Language/Granule/Syntax/Preprocessor/Ascii.hs index 2668fbe95..ebfef663d 100644 --- a/frontend/src/Language/Granule/Syntax/Preprocessor/Ascii.hs +++ b/frontend/src/Language/Granule/Syntax/Preprocessor/Ascii.hs @@ -1,22 +1,48 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.Granule.Syntax.Preprocessor.Ascii (unAscii) where +module Language.Granule.Syntax.Preprocessor.Ascii + ( asciiToUnicode + , unicodeToAscii + , asciiUnicodeTableMarkdown + ) where +import Control.Arrow (first, second) +import Data.String (fromString) import Text.Replace (Replace(..), replaceWithList) -unAscii :: String -> String -unAscii = replaceWithList - [ "forall" ~> "∀" - , "Inf" ~> "∞" - , "->" ~> "→" - , "=>" ~> "⇒" - , "<-" ~> "←" - , "/\\" ~> "∧" - , "\\/" ~> "∨" - , "<=" ~> "≤" - , ">=" ~> "≥" - , "==" ~> "≡" - , "\\" ~> "λ" +asciiToUnicode :: String -> String +asciiToUnicode = replaceWithList $ map (uncurry Replace . first fromString) asciiUnicodeTable + +unicodeToAscii :: String -> String +unicodeToAscii = replaceWithList $ map (uncurry (flip Replace) . second fromString) asciiUnicodeTable + +-- NOTE: Update the documentation with 'asciiUnicodeTableMarkdown' if you touch this. +asciiUnicodeTable :: [(String,String)] +asciiUnicodeTable = + [ ("forall" , "∀") + , ("Inf" , "∞") + , ("->" , "→") + , ("=>" , "⇒") + , ("<-" , "←") + , ("/\\" , "∧") + , ("\\/" , "∨") + , ("<=" , "≤") + , (">=" , "≥") + , ("==" , "≡") + , ("\\" , "λ") ] + +asciiUnicodeTableMarkdown :: String +asciiUnicodeTableMarkdown + = unlines + $ [ ("| ASCII | Unicode |") + , ("|:---:|:---:|") + ] + <> map mkRow asciiUnicodeTable where - (~>) = Replace + mkRow (x,y) = mconcat ["| `", x, "` | `", y, "` |"] + -- escapeBackslash = \case + -- [] -> [] + -- '\\' : cs -> '\\' : '\\' : escapeBackslash cs + -- c : cs -> c : escapeBackslash cs + diff --git a/frontend/src/Language/Granule/Syntax/Preprocessor/Latex.hs b/frontend/src/Language/Granule/Syntax/Preprocessor/Latex.hs index 513e00b94..bcbf35a62 100644 --- a/frontend/src/Language/Granule/Syntax/Preprocessor/Latex.hs +++ b/frontend/src/Language/Granule/Syntax/Preprocessor/Latex.hs @@ -3,7 +3,7 @@ module Language.Granule.Syntax.Preprocessor.Latex , unLatex ) where - + import Data.Char (isSpace) import Control.Arrow ((>>>)) @@ -11,28 +11,29 @@ data DocType = Latex | GranuleBlock --- | Extract \begin{granule} code blocks \end{granule} from tex files on a --- line-by-line basis. Maps other lines to the empty string, such that line --- numbers are preserved. -unLatex :: String -> String -unLatex = processGranuleLatex id (const "") +-- | Extract @\begin{env}@ code blocks @\end{env}@ from tex files on a +-- line-by-line basis, where @env@ is the name of the relevant environment. Maps +-- other lines to the empty string, such that line numbers are preserved. +unLatex :: String -> (String -> String) +unLatex env = processGranuleLatex (const "") env id --- | Transform the input by the given processing functions for Granule and --- Latex (currently operating on a line-by-line basis) +-- | Transform the input by the given processing functions for Granule and Latex +-- (currently operating on a line-by-line basis) processGranuleLatex - :: (String -> String) -- the processing function to apply to each line of granule code - -> (String -> String) -- the processing function to apply to each line of latex + :: (String -> String) -- ^ the processing function to apply to each line of latex + -> String -- ^ the name of the environment to check + -> (String -> String) -- ^ the processing function to apply to each line of granule code -> (String -> String) -processGranuleLatex fGr fTex = lines >>> (`zip` [1..]) >>> go Latex >>> unlines +processGranuleLatex fTex env fGr = lines >>> (`zip` [1..]) >>> go Latex >>> unlines where go :: DocType -> [(String, Int)] -> [String] go Latex ((line, lineNumber) : ls) - | strip line == "\\begin{granule}" = fTex line : go GranuleBlock ls - | strip line == "\\end{granule}" = error $ "Unmatched `\\end{granule}` on line " <> show lineNumber + | strip line == "\\begin{" <> env <> "}" = fTex line : go GranuleBlock ls + | strip line == "\\end{" <> env <> "}" = error $ "Unmatched `\\end{" <> env <> "}` on line " <> show lineNumber | otherwise = fTex line : go Latex ls go GranuleBlock ((line, lineNumber) : ls) - | strip line == "\\end{granule}" = fTex line : go Latex ls - | strip line == "\\begin{granule}" = error $ "Unmatched `\\begin{granule}` on line " <> show lineNumber + | strip line == "\\end{" <> env <> "}" = fTex line : go Latex ls + | strip line == "\\begin{" <> env <> "}" = error $ "Unmatched `\\begin{" <> env <> "}` on line " <> show lineNumber | otherwise = fGr line : go GranuleBlock ls go _ [] = [] diff --git a/frontend/src/Language/Granule/Syntax/Preprocessor/Markdown.hs b/frontend/src/Language/Granule/Syntax/Preprocessor/Markdown.hs index eac7f4a02..b0c177c2a 100644 --- a/frontend/src/Language/Granule/Syntax/Preprocessor/Markdown.hs +++ b/frontend/src/Language/Granule/Syntax/Preprocessor/Markdown.hs @@ -12,56 +12,57 @@ data DocType | GranuleBlockTwiddle | GranuleBlockTick --- | Extract fenced code blocks labeled "granule" from markdown files on a +-- | Extract fenced code blocks from markdown files on a -- line-by-line basis. Maps other lines to the empty string, such that line -- numbers are preserved. -unMarkdown :: String -> String -unMarkdown = processGranuleMarkdown id (const "") +unMarkdown :: String -> (String -> String) +unMarkdown env = processGranuleMarkdown (const "") env id -- | Transform the input by the given processing functions for Granule and -- Markdown (currently operating on a line-by-line basis) processGranuleMarkdown - :: (String -> String) -- the processing function to apply to each line of granule code - -> (String -> String) -- the processing function to apply to each line of markdown + :: (String -> String) -- the processing function to apply to each line of markdown + -> String -- the name of the code env, e.g. "granule" + -> (String -> String) -- the processing function to apply to each line of granule code -> (String -> String) -processGranuleMarkdown fGr fMd = lines >>> (`zip` [1..]) >>> go Markdown >>> unlines +processGranuleMarkdown fMd env fGr = lines >>> (`zip` [1..]) >>> go Markdown >>> unlines where go :: DocType -> [(String, Int)] -> [String] go Markdown ((line, lineNumber) : ls) - | strip line == "~~~granule" || strip line == "~~~ granule" + | strip line == "~~~" <> env <> "" || strip line == "~~~ " <> env <> "" = fMd line : go GranuleBlockTwiddle ls - | strip line == "```granule" || strip line == "``` granule" + | strip line == "```" <> env <> "" || strip line == "``` " <> env <> "" = fMd line : go GranuleBlockTick ls | otherwise = fMd line : go Markdown ls go GranuleBlockTwiddle ((line, lineNumber) : ls) | strip line == "~~~" = fMd line : go Markdown ls - | strip line == "~~~granule" - || strip line == "~~~ granule" - || strip line == "```granule" - || strip line == "``` granule" + | strip line == "~~~" <> env <> "" + || strip line == "~~~ " <> env <> "" + || strip line == "```" <> env <> "" + || strip line == "``` " <> env <> "" = error $ "Unexpected `" <> line <> "` on line " <> show lineNumber - <> " while inside a granule code block (~~~)" + <> " while inside a " <> env <> " code block (~~~)" | otherwise = fGr line : go GranuleBlockTwiddle ls go GranuleBlockTick ((line, lineNumber) : ls) | strip line == "```" = fMd line : go Markdown ls - | strip line == "~~~granule" - || strip line == "~~~ granule" - || strip line == "```granule" - || strip line == "``` granule" + | strip line == "~~~" <> env <> "" + || strip line == "~~~ " <> env <> "" + || strip line == "```" <> env <> "" + || strip line == "``` " <> env <> "" = error $ "Unexpected `" <> line <> "` on line " <> show lineNumber - <> " while inside a granule code block (```)" + <> " while inside a " <> env <> " code block (```)" | otherwise = fGr line : go GranuleBlockTick ls go _ [] = [] diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs index 9081f96e7..5c61c4b50 100644 --- a/frontend/src/Language/Granule/Syntax/Pretty.hs +++ b/frontend/src/Language/Granule/Syntax/Pretty.hs @@ -2,15 +2,16 @@ -- It is not especially pretty. -- Useful in debugging and error messages -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} module Language.Granule.Syntax.Pretty where +import Data.Foldable (toList) import Data.List import Language.Granule.Syntax.Expr import Language.Granule.Syntax.Type @@ -22,7 +23,7 @@ import Language.Granule.Utils prettyDebug :: (?globals :: Globals) => Pretty t => t -> String prettyDebug x = - let ?globals = ?globals { debugging = True } + let ?globals = ?globals { globalsDebugging = Just True } in prettyL 0 x pretty :: (?globals :: Globals, Pretty t) => t -> String @@ -32,10 +33,16 @@ type Level = Int parens :: Level -> String -> String parens l x | l <= 0 = x -parens n x = - if head x == '(' && last x == ')' - then x - else "(" <> x <> ")" +parens n x = "(" <> x <> ")" + +-- infixr 6 <+> +-- (<+>) :: String -> String -> String +-- s1 <+> s2 = s1 <> " " <> s2 + +-- The code below seems to be wrong, consider `f ((g x) (h y))`, @buggymcbugfix + -- if head x == '(' && last x == ')' + -- then x + -- else "(" <> x <> ")" -- The pretty printer class class Pretty t where @@ -62,7 +69,7 @@ instance {-# OVERLAPPABLE #-} Pretty a => Pretty [a] where -- Core prettyL l printers instance {-# OVERLAPS #-} Pretty Effect where - prettyL l es = "[" <> intercalate "," es <> "]" + prettyL l es = "[" <> intercalate "," (nub es) <> "]" instance Pretty Coeffect where prettyL l (CNat n) = show n @@ -71,8 +78,11 @@ instance Pretty Coeffect where prettyL l (CZero k) | k == TyCon (mkId "Nat") || k == extendedNat = "0" prettyL l (COne k) = "1 : " <> prettyL l k prettyL l (CZero k) = "0 : " <> prettyL l k - prettyL l (Level 0) = "Public" - prettyL l (Level _) = "Private" + prettyL l (Level x) = if x == privateRepresentation + then "Private" + else if x == publicRepresentation + then "Public" + else "Unused" prettyL l (CExpon a b) = prettyL l a <> "^" <> prettyL l b prettyL l (CVar c) = prettyL l c prettyL l (CMeet c d) = @@ -108,13 +118,13 @@ instance Pretty Kind where prettyL l (KPromote t) = "↑" <> prettyL l t instance Pretty TypeScheme where - prettyL l (Forall _ [] [] t) = prettyL l t - prettyL l (Forall _ cvs cons t) = - "forall " <> intercalate ", " (map prettyKindSignatures cvs) - <> intercalate ", " (map (prettyL l) cons) - <> ". " <> prettyL l t + prettyL l (Forall _ vs cs t) = kVars vs <> constraints cs <> prettyL l t where - prettyKindSignatures (var, kind) = prettyL l var <> " : " <> prettyL l kind + kVars [] = "" + kVars vs = "\n forall {" <> intercalate ", " (map prettyKindSignatures vs) <> "}\n . " + prettyKindSignatures (var, kind) = prettyL l var <> " : " <> prettyL l kind + constraints [] = "" + constraints cs = "\n {" <> intercalate ", " (map (prettyL l) cs) <> "}\n => " instance Pretty Type where -- Atoms @@ -131,7 +141,7 @@ instance Pretty Type where prettyL l (Box c t) = parens l (prettyL (l+1) t <> " [" <> prettyL l c <> "]") - prettyL l (Diamond e t) | e == ["Com"] = + prettyL l (Diamond e t) | e == ["Session"] = parens l ("Session " <> prettyL (l+1) t) prettyL l (Diamond e t) = @@ -155,26 +165,47 @@ instance Pretty Type where parens l (prettyL l t1 <> " " <> prettyL (l+1) t2) prettyL l (TyInfix op t1 t2) = - parens l (prettyL (l+1) t1 <> " " <> op <> " " <> prettyL (l+1) t2) + parens l (prettyL (l+1) t1 <> " " <> prettyL l op <> " " <> prettyL (l+1) t2) + +instance Pretty TypeOperator where + prettyL _ = \case + TyOpLesser -> "<" + TyOpLesserEq -> "≤" + TyOpGreater -> ">" + TyOpGreaterEq -> "≥" + TyOpEq -> "≡" + TyOpNotEq -> "≠" + TyOpPlus -> "+" + TyOpTimes -> "*" + TyOpMinus -> "-" + TyOpExpon -> "^" + TyOpMeet -> "∧" + TyOpJoin -> "∨" + appChain :: Type -> Bool appChain (TyApp (TyApp t1 t2) _) = appChain (TyApp t1 t2) appChain (TyApp t1 t2) = True appChain _ = False -instance (Pretty (Value v a), Pretty v) => Pretty (AST v a) where - prettyL l (AST dataDecls defs) = pretty' dataDecls <> "\n\n" <> pretty' defs +instance Pretty v => Pretty (AST v a) where + prettyL l (AST dataDecls defs imprts) + = (unlines . map ("import " <>) . toList) imprts + <> "\n\n" <> pretty' dataDecls + <> "\n\n" <> pretty' defs where pretty' :: Pretty l => [l] -> String pretty' = intercalate "\n\n" . map pretty -instance (Pretty (Value v a), Pretty v) => Pretty (Def v a) where - prettyL l (Def _ v eqs t) = - prettyL l v <> " : " <> prettyL l t <> "\n" - <> intercalate "\n" (map prettyEq eqs) - where - prettyEq (Equation _ _ ps e) = - prettyL l v <> " " <> prettyL l ps <> "= " <> prettyL l e +instance Pretty v => Pretty (Def v a) where + prettyL l (Def _ v eqs (Forall _ [] [] t)) + = prettyL l v <> " : " <> prettyL l t <> "\n" <> intercalate "\n" (map (prettyEqn v) eqs) + prettyL l (Def _ v eqs tySch) + = prettyL l v <> "\n : " <> prettyL l tySch <> "\n" <> intercalate "\n" (map (prettyEqn v) eqs) + +prettyEqn :: (?globals :: Globals, Pretty v) => Id -> Equation v a -> String +prettyEqn v (Equation _ _ ps e) = + prettyL 0 v <> " " <> prettyL 0 ps <> "= " <> prettyL 0 e instance Pretty DataDecl where prettyL l (DataDecl _ tyCon tyVars kind dataConstrs) = @@ -195,7 +226,7 @@ instance Pretty (Pattern a) where prettyL l (PBox _ _ p) = "[" <> prettyL l p <> "]" prettyL l (PInt _ _ n) = show n prettyL l (PFloat _ _ n) = show n - prettyL l (PConstr _ _ name args) = intercalate " " (prettyL l name : map (prettyL l) args) + prettyL l (PConstr _ _ name args) = intercalate " " (prettyL l name : map (prettyL (l + 1)) args) instance {-# OVERLAPS #-} Pretty [Pattern a] where prettyL l [] = "" @@ -218,18 +249,12 @@ instance Pretty v => Pretty (Value v a) where prettyL l (Constr _ s vs) | internalName s == "," = "(" <> intercalate ", " (map (prettyL l) vs) <> ")" prettyL l (Constr _ n []) = prettyL 0 n - prettyL l (Constr _ n vs) = intercalate " " (prettyL l n : map (parensOn (not . valueAtom)) vs) - where - -- Syntactically atomic values - valueAtom (NumInt _) = True - valueAtom (NumFloat _) = True - valueAtom (Constr _ _ []) = True - valueAtom _ = False + prettyL l (Constr _ n vs) = parens l . intercalate " " $ prettyL 0 n : map (prettyL (l + 1)) vs prettyL l (Ext _ v) = prettyL l v instance Pretty Id where prettyL l - = if debugging ?globals + = if debugging then internalName else (stripMarker '`') . (stripMarker '.') . sourceName where @@ -246,7 +271,7 @@ instance Pretty (Value v a) => Pretty (Expr v a) where parens l $ prettyL (l+1) e1 <> " " <> prettyL l e2 prettyL l (Binop _ _ op e1 e2) = - parens l $ prettyL (l+1) e1 <> " " <> op <> " " <> prettyL (l+1) e2 + parens l $ prettyL (l+1) e1 <> " " <> prettyL l op <> " " <> prettyL (l+1) e2 prettyL l (LetDiamond _ _ v t e1 e2) = parens l $ "let " <> prettyL l v <> " :" <> prettyL l t <> " <- " @@ -257,15 +282,35 @@ instance Pretty (Value v a) => Pretty (Expr v a) where <> intercalate ";\n " (map (\(p, e') -> prettyL l p <> " -> " <> prettyL l e') ps) <> ")" + +instance Pretty Operator where + prettyL _ = \case + OpLesser -> "<" + OpLesserEq -> "≤" + OpGreater -> ">" + OpGreaterEq -> "≥" + OpEq -> "≡" + OpNotEq -> "≠" + OpPlus -> "+" + OpTimes -> "*" + OpMinus -> "-" + parensOn :: (?globals :: Globals) => Pretty a => (a -> Bool) -> a -> String parensOn p t = prettyL (if p t then 0 else 1) t -instance (Pretty a, Pretty b) => Pretty (Either a b) where - prettyL l (Left v) = prettyL l v - prettyL l (Right v) = prettyL l v +ticks :: String -> String +ticks x = "`" <> x <> "`" instance Pretty Int where prettyL l = show instance Pretty Span where - prettyL _ (Span start end fileName) = "(" <> pretty start <> ":" <> pretty end <> ")" + prettyL _ + | testing = const "(location redacted)" + | otherwise = \case + Span (0,0) _ "" -> "(unknown location)" + Span (0,0) _ f -> f + Span pos _ f -> f <> ":" <> pretty pos + +instance Pretty Pos where + prettyL _ (l, c) = show l <> ":" <> show c diff --git a/frontend/src/Language/Granule/Syntax/Type.hs b/frontend/src/Language/Granule/Syntax/Type.hs index 76ef7f26b..4cd6f05ed 100644 --- a/frontend/src/Language/Granule/Syntax/Type.hs +++ b/frontend/src/Language/Granule/Syntax/Type.hs @@ -26,7 +26,21 @@ data TypeScheme = deriving (Eq, Show, Generic) -- Constructors and operators are just strings -type Operator = String +data TypeOperator + = TyOpLesser + | TyOpLesserEq + | TyOpGreater + | TyOpGreaterEq + | TyOpEq + | TyOpNotEq + | TyOpPlus + | TyOpTimes + | TyOpMinus + | TyOpExpon + | TyOpMeet + | TyOpJoin + deriving (Eq, Ord, Show) + {-| Types. Example: `List n Int` in Granule @@ -39,7 +53,7 @@ data Type = FunTy Type Type -- ^ Function type | TyVar Id -- ^ Type variable | TyApp Type Type -- ^ Type application | TyInt Int -- ^ Type-level Int - | TyInfix Operator Type Type -- ^ Infix type operator + | TyInfix TypeOperator Type Type -- ^ Infix type operator deriving (Eq, Ord, Show) -- | Kinds @@ -51,8 +65,27 @@ data Kind = KType | KPromote Type -- Promoted types deriving (Show, Ord, Eq) +promoteTypeToKind :: Type -> Kind +promoteTypeToKind (TyVar v) = KVar v +promoteTypeToKind t = KPromote t + +demoteKindToType :: Kind -> Maybe Type +demoteKindToType (KPromote t) = Just t +demoteKindToType (KVar v) = Just (TyVar v) +demoteKindToType _ = Nothing + +instance Term Kind where + freeVars (KPromote t) = freeVars t + freeVars (KVar x) = [x] + freeVars _ = [] + +kConstr :: Id -> Kind kConstr = KPromote . TyCon +kNat, protocol :: Kind +kNat = kConstr $ mkId "Nat" +protocol = kConstr $ mkId "Protocol" + instance Monad m => Freshenable m Kind where freshen KType = return KType freshen KCoeffect = return KCoeffect @@ -105,13 +138,18 @@ coeffectIsAtom (Level _) = True coeffectIsAtom (CSet _) = True coeffectIsAtom _ = False - publicRepresentation, privateRepresentation :: Integer privateRepresentation = 1 -publicRepresentation = 0 +publicRepresentation = 2 + +unusedRepresentation :: Integer +unusedRepresentation = 0 +nat, extendedNat :: Type nat = TyCon $ mkId "Nat" extendedNat = TyApp (TyCon $ mkId "Ext") (TyCon $ mkId "Nat") + +infinity :: Coeffect infinity = CInfinity (Just extendedNat) isInterval :: Type -> Maybe Type @@ -123,8 +161,6 @@ isProduct (TyApp (TyApp (TyCon c) t) t') | internalName c == "×" = Just (t, t') isProduct _ = Nothing - - -- | Represents effect grades -- TODO: Make richer type Effect = [String] @@ -186,7 +222,7 @@ mTyApp :: Monad m => Type -> Type -> m Type mTyApp x y = return (TyApp x y) mTyInt :: Monad m => Int -> m Type mTyInt = return . TyInt -mTyInfix :: Monad m => Operator -> Type -> Type -> m Type +mTyInfix :: Monad m => TypeOperator -> Type -> Type -> m Type mTyInfix op x y = return (TyInfix op x y) -- Monadic algebra for types @@ -198,7 +234,7 @@ data TypeFold m a = TypeFold , tfTyVar :: Id -> m a , tfTyApp :: a -> a -> m a , tfTyInt :: Int -> m a - , tfTyInfix :: Operator -> a -> a -> m a } + , tfTyInfix :: TypeOperator -> a -> a -> m a } -- Base monadic algebra baseTypeFold :: Monad m => TypeFold m Type @@ -243,16 +279,16 @@ freeAtomsVars t = [] -- Types and coeffects are terms instance Term Type where - freeVars = runIdentity . typeFoldM TypeFold - { tfFunTy = \x y -> return $ x <> y - , tfTyCon = \_ -> return [] -- or: const (return []) - , tfBox = \c t -> return $ freeVars c <> t - , tfDiamond = \_ x -> return x - , tfTyVar = \v -> return [v] -- or: return . return - , tfTyApp = \x y -> return $ x <> y - , tfTyInt = \_ -> return [] - , tfTyInfix = \_ y z -> return $ y <> z - } + freeVars = runIdentity . typeFoldM TypeFold + { tfFunTy = \x y -> return $ x <> y + , tfTyCon = \_ -> return [] -- or: const (return []) + , tfBox = \c t -> return $ freeVars c <> t + , tfDiamond = \_ x -> return x + , tfTyVar = \v -> return [v] -- or: return . return + , tfTyApp = \x y -> return $ x <> y + , tfTyInt = \_ -> return [] + , tfTyInfix = \_ y z -> return $ y <> z + } instance Term Coeffect where freeVars (CVar v) = [v] @@ -265,21 +301,23 @@ instance Term Coeffect where freeVars CNat{} = [] freeVars CFloat{} = [] freeVars CInfinity{} = [] - freeVars CZero{} = [] - freeVars COne{} = [] + freeVars (CZero t) = freeVars t + freeVars (COne t) = freeVars t freeVars Level{} = [] freeVars CSet{} = [] - freeVars (CSig c _) = freeVars c + freeVars (CSig c k) = freeVars c <> freeVars k freeVars (CInterval c1 c2) = freeVars c1 <> freeVars c2 freeVars (CProduct c1 c2) = freeVars c1 <> freeVars c2 ---------------------------------------------------------------------- -- Freshenable instances -instance Monad m => Freshenable m TypeScheme where - freshen :: TypeScheme -> Freshener m TypeScheme +instance Freshenable m TypeScheme where + freshen :: Monad m => TypeScheme -> Freshener m TypeScheme freshen (Forall s binds constraints ty) = do - binds' <- mapM (\(v, k) -> do { v' <- freshIdentifierBase Type v; return (v', k) }) binds + binds' <- mapM (\(v, k) -> do { v' <- freshIdentifierBase Type v; + k' <- freshen k; + return (v', k') }) binds constraints' <- mapM freshen constraints ty' <- freshen ty return $ Forall s binds' constraints' ty' @@ -348,11 +386,19 @@ instance Freshenable m Coeffect where return $ CSet cs' freshen (CSig c k) = do c' <- freshen c - return $ CSig c' k + k' <- freshen k + return $ CSig c' k' freshen c@CInfinity{} = return c freshen c@CFloat{} = return c - freshen c@CZero{} = return c - freshen c@COne{} = return c + + freshen (CZero t) = do + t' <- freshen t + return $ CZero t' + + freshen (COne t) = do + t' <- freshen t + return $ COne t' + freshen c@Level{} = return c freshen c@CNat{} = return c freshen (CInterval c1 c2) = CInterval <$> freshen c1 <*> freshen c2 @@ -400,6 +446,11 @@ normalise (CTimes n m) = where n' = normalise n m' = normalise m +-- Push signatures in +normalise (CSig (CPlus c1 c2) k) = CPlus (CSig (normalise c1) k) (CSig (normalise c2) k) +normalise (CSig (CTimes c1 c2) k) = CTimes (CSig (normalise c1) k) (CSig (normalise c2) k) +normalise (CSig (CMeet c1 c2) k) = CMeet (CSig (normalise c1) k) (CSig (normalise c2) k) +normalise (CSig (CJoin c1 c2) k) = CJoin (CSig (normalise c1) k) (CSig (normalise c2) k) normalise (CSig (CNat 0) k) = CZero k normalise (CSig (CZero _) k) = CZero k normalise (CSig (CNat 1) k) = COne k diff --git a/frontend/src/Language/Granule/Utils.hs b/frontend/src/Language/Granule/Utils.hs index 9546d2bb9..c6ca940cf 100644 --- a/frontend/src/Language/Granule/Utils.hs +++ b/frontend/src/Language/Granule/Utils.hs @@ -6,10 +6,14 @@ module Language.Granule.Utils where +import Control.Applicative ((<|>)) import Control.Exception (SomeException, catch, try) import Control.Monad (when, forM) -import Data.List ((\\), nub) -import Data.Semigroup ((<>)) +import Data.List ((\\), nub, sortBy) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (getTimeZone, utc, utcToLocalTime) import Debug.Trace (trace, traceM) @@ -19,100 +23,154 @@ import "Glob" System.FilePath.Glob (glob) import Language.Granule.Syntax.Span --- | A result data type to be used pretty much like `Maybe`, but with an explanation as to why --- no result was returned -data Result a = Some a | None [String] - -data Globals = - Globals - { debugging :: Bool - , timing :: Bool - , sourceFilePath :: String - , noColors :: Bool - , noEval :: Bool - , suppressInfos :: Bool - , suppressErrors :: Bool - , timestamp :: Bool - , solverTimeoutMillis :: Integer - , includePath :: FilePath - } deriving Show - -defaultGlobals :: Globals -defaultGlobals = - Globals - { debugging = False - , timing = False - , sourceFilePath = "" - , noColors = False - , noEval = False - , suppressInfos = False - , suppressErrors = False - , timestamp = False - , solverTimeoutMillis = 5000 - , includePath = "StdLib" +-- | Flags that change Granule's behaviour +data Globals = Globals + { globalsDebugging :: Maybe Bool + , globalsNoColors :: Maybe Bool + , globalsAlternativeColors :: Maybe Bool + , globalsNoEval :: Maybe Bool + , globalsSuppressInfos :: Maybe Bool + , globalsSuppressErrors :: Maybe Bool + , globalsTimestamp :: Maybe Bool + , globalsTesting :: Maybe Bool -- ^ whether we are currently running a test (e.g. for pretty printing) + , globalsSolverTimeoutMillis :: Maybe Integer + , globalsIncludePath :: Maybe FilePath + , globalsSourceFilePath :: Maybe FilePath + , globalsEntryPoint :: Maybe String + } deriving (Read, Show) + +-- | Accessors for global flags with default values +debugging, noColors, alternativeColors, noEval, suppressInfos, suppressErrors, + timestamp, testing :: (?globals :: Globals) => Bool +debugging = fromMaybe False $ globalsDebugging ?globals +noColors = fromMaybe False $ globalsNoColors ?globals +alternativeColors = fromMaybe False $ globalsAlternativeColors ?globals +noEval = fromMaybe False $ globalsNoEval ?globals +suppressInfos = fromMaybe False $ globalsSuppressInfos ?globals +suppressErrors = fromMaybe False $ globalsSuppressErrors ?globals +timestamp = fromMaybe False $ globalsTimestamp ?globals +testing = fromMaybe False $ globalsTesting ?globals + +-- | Accessor for the solver timeout with a default value +solverTimeoutMillis :: (?globals :: Globals) => Integer +solverTimeoutMillis = fromMaybe 5000 $ globalsSolverTimeoutMillis ?globals + +-- | Accessors for global file paths with default values +includePath, sourceFilePath :: (?globals :: Globals) => FilePath +includePath = fromMaybe "StdLib" $ globalsIncludePath ?globals +sourceFilePath = fromMaybe "" $ globalsSourceFilePath ?globals + +-- | Accessor for program entry point +entryPoint :: (?globals :: Globals) => String +entryPoint = fromMaybe "main" $ globalsEntryPoint ?globals + +-- | Merge two 'Globals', giving preference to the settings of the left one +instance Semigroup Globals where + g1 <> g2 = Globals + { globalsDebugging = globalsDebugging g1 <|> globalsDebugging g2 + , globalsNoColors = globalsNoColors g1 <|> globalsNoColors g2 + , globalsAlternativeColors = globalsAlternativeColors g1 <|> globalsAlternativeColors g2 + , globalsNoEval = globalsNoEval g1 <|> globalsNoEval g2 + , globalsSuppressInfos = globalsSuppressInfos g1 <|> globalsSuppressInfos g2 + , globalsSuppressErrors = globalsSuppressErrors g1 <|> globalsSuppressErrors g2 + , globalsTimestamp = globalsTimestamp g1 <|> globalsTimestamp g2 + , globalsSolverTimeoutMillis = globalsSolverTimeoutMillis g1 <|> globalsSolverTimeoutMillis g2 + , globalsIncludePath = globalsIncludePath g1 <|> globalsIncludePath g2 + , globalsSourceFilePath = globalsSourceFilePath g1 <|> globalsSourceFilePath g2 + , globalsTesting = globalsTesting g1 <|> globalsTesting g2 + , globalsEntryPoint = globalsEntryPoint g1 <|> globalsEntryPoint g2 + } + +instance Monoid Globals where + mempty = Globals + { globalsDebugging = Nothing + , globalsNoColors = Nothing + , globalsAlternativeColors = Nothing + , globalsNoEval = Nothing + , globalsSuppressInfos = Nothing + , globalsSuppressErrors = Nothing + , globalsTimestamp = Nothing + , globalsSolverTimeoutMillis = Nothing + , globalsIncludePath = Nothing + , globalsSourceFilePath = Nothing + , globalsTesting = Nothing + , globalsEntryPoint = Nothing } +-- | A class for messages that are shown to the user. TODO: make more general class UserMsg a where + -- | The title of the message title :: a -> String - location :: a -> Maybe Span - msg :: a -> String -- short for `message`, not `monosodium glutamate` - location _ = Nothing + -- | The location (defaults to 'nullSpan') + location :: (?globals :: Globals) => a -> Span + location _ = nullSpan + -- | The body of the message + msg :: (?globals :: Globals) => a -> String + + +-- | Make a span from a pair of positions mkSpan :: (?globals :: Globals) => (Pos, Pos) -> Span -mkSpan (start, end) = Span start end (sourceFilePath ?globals) +mkSpan (start, end) = Span start end sourceFilePath +-- | When a source location is not applicable nullSpan :: (?globals :: Globals) => Span -nullSpan = Span (0, 0) (0, 0) (sourceFilePath ?globals) +nullSpan = Span (0, 0) (0, 0) sourceFilePath + debugM :: (?globals :: Globals, Applicative f) => String -> String -> f () debugM explanation message = - when (debugging ?globals) $ traceM $ + when debugging $ traceM $ ((unsafePerformIO getTimeString) <> (bold $ cyan $ "Debug: ") <> explanation <> " \n") <> message <> "\n" -- | Print to terminal when debugging e.g.: -- foo x y = x + y `debug` "foo" $ "given " <> show x <> " and " <> show y debug :: (?globals :: Globals) => a -> String -> a -debug x message = - if debugging ?globals - then ((unsafePerformIO getTimeString) <> (bold $ magenta $ "Debug: ") <> message <> "\n") - `trace` x - else x - --- | Append a debug message to a string, which will only get printed when debugging -() :: (?globals :: Globals) => String -> String -> String -infixr 6 -str msg = - if debugging ?globals - then str <> (bold $ magenta $ " Debug { ") <> msg <> (bold $ magenta $ " }") - else str - -printErr :: (?globals :: Globals, UserMsg msg) => msg -> IO () -printErr err = when (not $ suppressErrors ?globals) $ do - time <- getTimeString - hPutStrLn stderr $ - time - <> (bold $ red $ title err <> ": ") - <> sourceFile <> lineCol <> "\n" - <> indent (msg err) - <> "\n" - where - sourceFile = - case location err of -- sourceFilePath ?globals - Nothing -> "" - Just (filename -> "") -> "" - Just (filename -> p) -> p <> ":" - lineCol = - case location err of - Nothing -> "" - Just (Span (0,0) (0,0) _) -> "" - Just (Span (line,col) _ fileName) -> show line <> ":" <> show col <> ":" +debug x message + | debugging = ((unsafePerformIO getTimeString) <> (bold $ magenta $ "Debug: ") <> message <> "\n") `trace` x + | otherwise = x + +printError :: (?globals :: Globals, UserMsg msg) => msg -> IO () +printError message = when (not suppressErrors) $ + hPutStrLn stderr $ formatError message + +printSuccess :: (?globals :: Globals) => String -> IO () +printSuccess message = when (not suppressInfos) + (putStrLn . (if alternativeColors then blue else green) $ message) printInfo :: (?globals :: Globals) => String -> IO () -printInfo message = - when (not $ suppressInfos ?globals) $ do - time <- getTimeString - putStrLn $ time <> message +printInfo message = when (not suppressInfos) (putStrLn message) + +-- printInfo :: (?globals :: Globals) => String -> IO () +-- printInfo message = +-- when (not $ suppressInfos ?globals) $ do +-- time <- getTimeString +-- putStr $ time <> message + +formatError :: (?globals :: Globals, UserMsg msg) => msg -> String +formatError = formatMessage (bold . red) +-- | Given a function to format the title of a message, format the message +-- and its body. e.g. @formatMessage (bold . red)@ for errors. +formatMessage :: (?globals :: Globals, UserMsg msg) + => (String -> String) -> msg -> String +formatMessage titleStyle message + = (titleStyle $ title message <> ": ") + <> sourceFile <> lineCol <> "\n" + <> msg message + where + sourceFile = case filename $ location message of -- sourceFilePath ?globals + "" -> "" + p -> p <> ":" + lineCol = case location message of + (Span (0,0) (0,0) _) -> "" + (Span (line,col) _ _) -> show line <> ":" <> show col <> ":" + +formatMessageTime :: (?globals :: Globals, UserMsg msg) + => (String -> String) -> msg -> IO String +formatMessageTime titleStyle message = do + time <- getTimeString + pure $ time <> formatMessage titleStyle message -- backgColor colorCode = txtColor (colorCode + 10) bold :: (?globals :: Globals) => String -> String @@ -130,18 +188,15 @@ white = txtColor "37" txtColor :: (?globals :: Globals) => String -> String -> String txtColor colorCode message = - if noColors ?globals + if noColors then message else "\ESC[" <> colorCode <> ";1m" <> message <> reset where reset = "\ESC[0m" -indent :: String -> String -indent message = " " <> message - getTimeString :: (?globals :: Globals) => IO String getTimeString = - if timestamp ?globals == False then return "" + if not timestamp then return "" else do time <- try getCurrentTime case time of @@ -177,3 +232,19 @@ lookupMany a' (_:xs) = lookupMany a' xs -- [2,3] duplicates :: Eq a => [a] -> [a] duplicates xs = nub (xs \\ nub xs) + +-- | Using a projection function to get a partial order on elements, return the +-- groups of duplicates according to the projection. Useful for instance for +-- finding duplicate definitions by projecting on their source names. +-- +-- >>> duplicatesBy fst [("alice",1), ("bob",2), ("alice",3), ("alice", 4)] +-- [(("alice",3),("alice",1) :| [("alice",4)])] +-- +-- Observe that the second occurrence is the 'fst' element, since we can say +-- that this is the first offending case. The types ensure that we actually +-- have at least 2 instances of the thing we want to duplicate check. +duplicatesBy :: Ord b => (a -> b) -> [a] -> [(a,NonEmpty a)] +duplicatesBy proj + = mapMaybe (\case x1 :| x2 : xs -> Just (x2, x1 :| xs); _ -> Nothing) + . NonEmpty.groupBy (\x1 x2 -> proj x1 == proj x2) + . sortBy (comparing proj) diff --git a/frontend/tests/cases/errors/README b/frontend/tests/cases/errors/README deleted file mode 100644 index 1ecf3b94b..000000000 --- a/frontend/tests/cases/errors/README +++ /dev/null @@ -1 +0,0 @@ -Other types of error, such as parse errors and runtime errors diff --git a/frontend/tests/cases/errors/function-without-signature.gr b/frontend/tests/cases/errors/function-without-signature.gr deleted file mode 100644 index d04781e55..000000000 --- a/frontend/tests/cases/errors/function-without-signature.gr +++ /dev/null @@ -1,2 +0,0 @@ -bar : Int -foo = 0 diff --git a/frontend/tests/cases/errors/missingQuants.gr b/frontend/tests/cases/errors/missingQuants.gr deleted file mode 100644 index 79501df9b..000000000 --- a/frontend/tests/cases/errors/missingQuants.gr +++ /dev/null @@ -1,2 +0,0 @@ -SourceId : a → a -SourceId x = x \ No newline at end of file diff --git a/frontend/tests/cases/negative/CrossDefPolymorphism.gr b/frontend/tests/cases/negative/CrossDefPolymorphism.gr new file mode 100644 index 000000000..7b955af26 --- /dev/null +++ b/frontend/tests/cases/negative/CrossDefPolymorphism.gr @@ -0,0 +1,9 @@ +data State s a = State (s → a × s) + +get + : ∀ {s : Type} + . State (s [2]) s +get = State oopsie + +oopsie : forall {s : Type} . s [2] -> (s, s) +oopsie = \[s] -> (s, s) diff --git a/frontend/tests/cases/negative/CrossDefPolymorphism.gr.output b/frontend/tests/cases/negative/CrossDefPolymorphism.gr.output new file mode 100644 index 000000000..182736dce --- /dev/null +++ b/frontend/tests/cases/negative/CrossDefPolymorphism.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unification failed: 6:7: +Type variable `a0.0` cannot be unified with type `a0.0 [2]` (occurs check failure; implies infinite type). \ No newline at end of file diff --git a/frontend/tests/cases/negative/adt.gr.output b/frontend/tests/cases/negative/adt.gr.output new file mode 100644 index 000000000..c21145b65 --- /dev/null +++ b/frontend/tests/cases/negative/adt.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Kind mismatch: 6:3: +Expected kind `Type` but got `Type -> Type` \ No newline at end of file diff --git a/frontend/tests/cases/negative/approximation.gr.output b/frontend/tests/cases/negative/approximation.gr.output new file mode 100644 index 000000000..a4b6d9d22 --- /dev/null +++ b/frontend/tests/cases/negative/approximation.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 2:1: +4 is not approximatable by 2 for type Nat because Nat denotes precise usage. \ No newline at end of file diff --git a/frontend/tests/cases/negative/approximation2.gr.output b/frontend/tests/cases/negative/approximation2.gr.output new file mode 100644 index 000000000..9ec0895fb --- /dev/null +++ b/frontend/tests/cases/negative/approximation2.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Falsifiable theorem: 5:1: +The following theorem associated with `borg` is falsifiable: + (prom_[5:18]0 + prom_[5:22]0 ≤ 5..6) ∧ (3..4 ≤ prom_[5:22]0) ∧ (0..1 ≤ prom_[5:18]0) \ No newline at end of file diff --git a/frontend/tests/cases/negative/badExistential.gr.output b/frontend/tests/cases/negative/badExistential.gr.output new file mode 100644 index 000000000..24176ac95 --- /dev/null +++ b/frontend/tests/cases/negative/badExistential.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Type error: 4:23: +Expected `f t -> a` but got `f0.0 a0.0 -> a` \ No newline at end of file diff --git a/frontend/tests/cases/negative/badExistential2.gr.output b/frontend/tests/cases/negative/badExistential2.gr.output new file mode 100644 index 000000000..b8769791a --- /dev/null +++ b/frontend/tests/cases/negative/badExistential2.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Operator resolution failed: 6:14: +Could not resolve operator `+` at type `a0.0 -> Int -> ..` \ No newline at end of file diff --git a/frontend/tests/cases/negative/badKind.gr.output b/frontend/tests/cases/negative/badKind.gr.output new file mode 100644 index 000000000..faa820268 --- /dev/null +++ b/frontend/tests/cases/negative/badKind.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Kind mismatch: 1:1: +Expected kind `Type` but got `↑Nat` \ No newline at end of file diff --git a/frontend/tests/cases/negative/badLinearityNestedCase.gr.output b/frontend/tests/cases/negative/badLinearityNestedCase.gr.output new file mode 100644 index 000000000..60f30fc4a --- /dev/null +++ b/frontend/tests/cases/negative/badLinearityNestedCase.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 8:21: +Linear variable `x` is used more than once. \ No newline at end of file diff --git a/frontend/tests/cases/negative/badPoly.gr.output b/frontend/tests/cases/negative/badPoly.gr.output new file mode 100644 index 000000000..7e98c1917 --- /dev/null +++ b/frontend/tests/cases/negative/badPoly.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Type error: 2:14: +Expected `a -> a -> (a, b)` but got `a0 -> b0 -> (a0, b0)` \ No newline at end of file diff --git a/frontend/tests/cases/negative/badPoly2.gr.output b/frontend/tests/cases/negative/badPoly2.gr.output new file mode 100644 index 000000000..82781e7f7 --- /dev/null +++ b/frontend/tests/cases/negative/badPoly2.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Operator resolution failed: 2:10: +Could not resolve operator `+` at type `a -> Int -> ..` \ No newline at end of file diff --git a/frontend/tests/cases/negative/badPoly3.gr.output b/frontend/tests/cases/negative/badPoly3.gr.output new file mode 100644 index 000000000..2450a60f6 --- /dev/null +++ b/frontend/tests/cases/negative/badPoly3.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound data constructor: 8:14: +`SourceId` \ No newline at end of file diff --git a/frontend/tests/cases/negative/badRecursiveArgument.gr b/frontend/tests/cases/negative/badRecursiveArgument.gr new file mode 100644 index 000000000..9c3b211cf --- /dev/null +++ b/frontend/tests/cases/negative/badRecursiveArgument.gr @@ -0,0 +1,7 @@ +data N (n : Nat) where + Z : N 0; + S : N n -> N (n+1) + +fibble : forall {n : Nat} . N n -> N n +fibble Z = Z; +fibble (S n) = (fibble n) diff --git a/frontend/tests/cases/negative/badRecursiveArgument.gr.output b/frontend/tests/cases/negative/badRecursiveArgument.gr.output new file mode 100644 index 000000000..90718f22b --- /dev/null +++ b/frontend/tests/cases/negative/badRecursiveArgument.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 7:1: +The following theorem associated with `fibble` is falsifiable: + (n0.0 + 1 + 1 = n0.0 + 1 + 1 + 1) ∧ (n0.0 + 1 = n0.0 + 1 + 1) \ No newline at end of file diff --git a/frontend/tests/cases/errors/bogus-import.gr b/frontend/tests/cases/negative/bogus-import.gr similarity index 100% rename from frontend/tests/cases/errors/bogus-import.gr rename to frontend/tests/cases/negative/bogus-import.gr diff --git a/frontend/tests/cases/negative/bogus-import.gr.output b/frontend/tests/cases/negative/bogus-import.gr.output new file mode 100644 index 000000000..8d0514f92 --- /dev/null +++ b/frontend/tests/cases/negative/bogus-import.gr.output @@ -0,0 +1,2 @@ +Parse error: +StdLib/bogus.gr: openFile: does not exist (No such file or directory) \ No newline at end of file diff --git a/frontend/tests/cases/negative/bogusMap.gr.output b/frontend/tests/cases/negative/bogusMap.gr.output new file mode 100644 index 000000000..16710e6d5 --- /dev/null +++ b/frontend/tests/cases/negative/bogusMap.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound type constructor: 1:1: +`Vec` \ No newline at end of file diff --git a/frontend/tests/cases/negative/bool.gr.output b/frontend/tests/cases/negative/bool.gr.output new file mode 100644 index 000000000..f32e24233 --- /dev/null +++ b/frontend/tests/cases/negative/bool.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Wrong return type in value constructor: 2:3: +Expected type constructor `Bool`, but got `Int` \ No newline at end of file diff --git a/frontend/tests/cases/negative/cartesianCase.gr.output b/frontend/tests/cases/negative/cartesianCase.gr.output new file mode 100644 index 000000000..1f204f250 --- /dev/null +++ b/frontend/tests/cases/negative/cartesianCase.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Impossible pattern match: 8:6: +Pattern match in an equation of `case` is impossible as it implies the unsatisfiable condition (1 ≤ ∞) \ No newline at end of file diff --git a/frontend/tests/cases/negative/case.gr b/frontend/tests/cases/negative/case.gr index f6bfc8de4..4debb07f0 100644 --- a/frontend/tests/cases/negative/case.gr +++ b/frontend/tests/cases/negative/case.gr @@ -1,12 +1,4 @@ -import Vec - -foo : ∀ {a : Type, n : Nat} - . Vec n (a [0]) → Int [n] → Int [n] → Int -foo xs [x] [y] = - case xs of - Nil → 0; - Cons [_] ys → foo ys [x] [2] + x - --- The above should not type check due to `y` not being used in the --- branches, but it does not show up in the "output" context because --- it is being removed by specialisation, which is wrong. +Type checking failed: + Counter example: 5:1: + The following theorem associated with `foo` is falsifiable: + (0 ≤ n) ∧ ∀ n.91,t.58 . ((0 ≤ 0) ∧ (n = n91 + 1) ∧ ∃ t57 : Type . ¬((n = 0)) -> (0 ≤ n) ∧ (n92 + 1 ≤ n) ∧ (0 ≤ 0) ∧ (n91 = n92)) ∧ ∀ t.57 . ((n = 0) -> (0 ≤ n)) \ No newline at end of file diff --git a/frontend/tests/cases/negative/case.gr.output b/frontend/tests/cases/negative/case.gr.output new file mode 100644 index 000000000..e5f2478f0 --- /dev/null +++ b/frontend/tests/cases/negative/case.gr.output @@ -0,0 +1,2 @@ +Parse error: +lexical error at line 4, column 61 diff --git a/frontend/tests/cases/negative/caseDischargeStyle.gr.output b/frontend/tests/cases/negative/caseDischargeStyle.gr.output new file mode 100644 index 000000000..adf130c61 --- /dev/null +++ b/frontend/tests/cases/negative/caseDischargeStyle.gr.output @@ -0,0 +1,9 @@ +Type checking failed: +Linearity error: 7:3: +Variable `y` is promoted but its binding is linear; its binding should be under a box. + +Linearity error: 7:3: +Linear variable `b` is never used. + +Grading error: 14:3: +0 is not approximatable by 1 for type Nat because Nat denotes precise usage. \ No newline at end of file diff --git a/frontend/tests/cases/negative/comments.gr.output b/frontend/tests/cases/negative/comments.gr.output new file mode 100644 index 000000000..40ba88f15 --- /dev/null +++ b/frontend/tests/cases/negative/comments.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Type error: 4:7: +Expected `Int` but got `String` \ No newline at end of file diff --git a/frontend/tests/cases/negative/different-number-of-args-in-equations.gr b/frontend/tests/cases/negative/different-number-of-args-in-equations.gr new file mode 100644 index 000000000..87ae00481 --- /dev/null +++ b/frontend/tests/cases/negative/different-number-of-args-in-equations.gr @@ -0,0 +1,7 @@ +foo : Int -> Int +foo 1 = 2; +foo 1 2 = 3 + +bar : Int -> Int -> Int +bar 0 = \x -> x; +bar x y = x + y \ No newline at end of file diff --git a/frontend/tests/cases/negative/different-number-of-args-in-equations.gr.output b/frontend/tests/cases/negative/different-number-of-args-in-equations.gr.output new file mode 100644 index 000000000..1ad18ca15 --- /dev/null +++ b/frontend/tests/cases/negative/different-number-of-args-in-equations.gr.output @@ -0,0 +1,8 @@ +Type checking failed: +Too many patterns: 3:1: +Couldn't match expected type `Int` against a type of the form `?` implied by the remaining pattern(s) + `2` + +Too many patterns: 7:1: +Couldn't match expected type `Int -> Int` against a type of the form `?` implied by the remaining pattern(s) + `y` \ No newline at end of file diff --git a/frontend/tests/cases/negative/disallowZeroBoundFromUnifyingPatterns.gr.output b/frontend/tests/cases/negative/disallowZeroBoundFromUnifyingPatterns.gr.output new file mode 100644 index 000000000..8171558ac --- /dev/null +++ b/frontend/tests/cases/negative/disallowZeroBoundFromUnifyingPatterns.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Impossible pattern match: 9:5: +Pattern match in an equation of `case` is impossible as it implies the unsatisfiable condition (1 = 0) diff --git a/frontend/tests/cases/negative/duplicates/forall.gr b/frontend/tests/cases/negative/duplicates/forall.gr new file mode 100644 index 000000000..c24a06eb7 --- /dev/null +++ b/frontend/tests/cases/negative/duplicates/forall.gr @@ -0,0 +1,2 @@ +id : forall a a : Type . a -> a +id x = x diff --git a/frontend/tests/cases/negative/duplicates/forall.gr.output b/frontend/tests/cases/negative/duplicates/forall.gr.output new file mode 100644 index 000000000..f0cef9b7f --- /dev/null +++ b/frontend/tests/cases/negative/duplicates/forall.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Duplicate binding: 1:6: +Variable `a` bound more than once. \ No newline at end of file diff --git a/frontend/tests/cases/negative/duplicate-patterns.gr b/frontend/tests/cases/negative/duplicates/pattern.gr similarity index 100% rename from frontend/tests/cases/negative/duplicate-patterns.gr rename to frontend/tests/cases/negative/duplicates/pattern.gr diff --git a/frontend/tests/cases/negative/duplicates/pattern.gr.output b/frontend/tests/cases/negative/duplicates/pattern.gr.output new file mode 100644 index 000000000..c554645bc --- /dev/null +++ b/frontend/tests/cases/negative/duplicates/pattern.gr.output @@ -0,0 +1,6 @@ +Type checking failed: +Duplicate binding: 3:1: +Variable `x` bound more than once. + +Duplicate binding: 3:1: +Variable `y` bound more than once. \ No newline at end of file diff --git a/frontend/tests/cases/negative/errorExample.gr.output b/frontend/tests/cases/negative/errorExample.gr.output new file mode 100644 index 000000000..007569562 --- /dev/null +++ b/frontend/tests/cases/negative/errorExample.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 4:1: +2 is not approximatable by 1 for type Nat because Nat denotes precise usage. \ No newline at end of file diff --git a/frontend/tests/cases/negative/everyOtherBroken.gr.output b/frontend/tests/cases/negative/everyOtherBroken.gr.output new file mode 100644 index 000000000..d62e03e7f --- /dev/null +++ b/frontend/tests/cases/negative/everyOtherBroken.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 8:1: +The following theorem associated with `everyOther` is falsifiable: + ∀ n0.0 : ↑Nat,a1.0 : Type,t2.0 : Type,t3.0 : ↑Nat,n0.1 : ↑Nat,a1.1 : Type,t2.1 : Type,t3.1 : ↑Nat . ((0..0 ≤ 0..1) ∧ (n0.1 + 1 + 1 = n0.0 + 1) -> (1..1 ≤ 0..1) ∧ (1 + n0.2 = n0.0 + 1) ∧ (n0.2 + 1 = n0.1 + 1 + 1) ∧ (0..1 ≤ 0..1)) \ No newline at end of file diff --git a/frontend/tests/cases/negative/everyOtherBroken2.gr.output b/frontend/tests/cases/negative/everyOtherBroken2.gr.output new file mode 100644 index 000000000..4072b7ad0 --- /dev/null +++ b/frontend/tests/cases/negative/everyOtherBroken2.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 9:1: +The following theorem associated with `everyOther` is falsifiable: + ∀ a1.0 : Type,n0.0 : ↑Nat,t2.0 : Type,t3.0 : ↑Nat,a1.1 : Type,n0.1 : ↑Nat,t2.1 : Type,t3.1 : ↑Nat . ((0..0 ≤ 0..1) ∧ (n0.1 + 1 + 1 = n0.0 + 1) -> (1..1 ≤ 0..1) ∧ (1 + n0.2 = n0.0 + 1) ∧ (n0.2 + 1 = n0.1 + 1 + 1) ∧ (0..1 ≤ 0..1)) \ No newline at end of file diff --git a/frontend/tests/cases/negative/exactNat.gr.output b/frontend/tests/cases/negative/exactNat.gr.output new file mode 100644 index 000000000..456531328 --- /dev/null +++ b/frontend/tests/cases/negative/exactNat.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 2:1: +1..1 is not approximatable by 2..2 for type Interval Nat \ No newline at end of file diff --git a/frontend/tests/cases/negative/expr.gr.output b/frontend/tests/cases/negative/expr.gr.output new file mode 100644 index 000000000..8e0899095 --- /dev/null +++ b/frontend/tests/cases/negative/expr.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Type error: 6:8: +Expected `Expr Int -> Expr Int -> Expr Int` but got `Expr Float -> Expr Float -> Expr Float` \ No newline at end of file diff --git a/frontend/tests/cases/negative/fact-inf.gr.output b/frontend/tests/cases/negative/fact-inf.gr.output new file mode 100644 index 000000000..3dccde449 --- /dev/null +++ b/frontend/tests/cases/negative/fact-inf.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Impossible pattern match: 5:1: +Pattern match in an equation of `fact` is impossible as it implies the unsatisfiable condition (1..1 ≤ ∞..∞) \ No newline at end of file diff --git a/frontend/tests/cases/negative/flat.gr.output b/frontend/tests/cases/negative/flat.gr.output new file mode 100644 index 000000000..21cc6166d --- /dev/null +++ b/frontend/tests/cases/negative/flat.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 2:1: +The following theorem associated with `flatten` is falsifiable: + (1 = d + 1) ∧ ((c + 1) * (d + 1) = c + 1) \ No newline at end of file diff --git a/frontend/tests/cases/negative/flatten/flattenByLet.gr.output b/frontend/tests/cases/negative/flatten/flattenByLet.gr.output new file mode 100644 index 000000000..636af4c41 --- /dev/null +++ b/frontend/tests/cases/negative/flatten/flattenByLet.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 2:1: +The following theorem associated with `flatten` is falsifiable: + (1 = n) ∧ (m * n = m) \ No newline at end of file diff --git a/frontend/tests/cases/negative/flatten/flattenLevel.gr b/frontend/tests/cases/negative/flatten/flattenLevel.gr index 227b4301d..1941d2a72 100644 --- a/frontend/tests/cases/negative/flatten/flattenLevel.gr +++ b/frontend/tests/cases/negative/flatten/flattenLevel.gr @@ -1,2 +1,2 @@ -flattenLevel : ∀ k : Level, l : Level . (Int [k]) [l] → Int [k ∧ l] +flattenLevel : ∀ k : Level, l : Level . (Int [k]) [l] → Int [k ∨ l] flattenLevel [[x]] = [x] diff --git a/frontend/tests/cases/negative/flatten/flattenLevel.gr.output b/frontend/tests/cases/negative/flatten/flattenLevel.gr.output new file mode 100644 index 000000000..0f31ed7af --- /dev/null +++ b/frontend/tests/cases/negative/flatten/flattenLevel.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 2:1: +The following theorem associated with `flattenLevel` is falsifiable: + (k \/ l ≤ l /\ k) \ No newline at end of file diff --git a/frontend/tests/cases/negative/flatten/flattenNat.gr.output b/frontend/tests/cases/negative/flatten/flattenNat.gr.output new file mode 100644 index 000000000..98edb99de --- /dev/null +++ b/frontend/tests/cases/negative/flatten/flattenNat.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 2:1: +The following theorem associated with `flattenNat` is falsifiable: + (m + n = n * m) \ No newline at end of file diff --git a/frontend/tests/cases/negative/gex0.gr b/frontend/tests/cases/negative/gex0.gr index 615139e3a..2ef318fd9 100644 --- a/frontend/tests/cases/negative/gex0.gr +++ b/frontend/tests/cases/negative/gex0.gr @@ -1,4 +1,4 @@ -- Example expression main : Int -main = let [x] : (Int [1]) = [1] in x + x +main = let [x] : (Int [1]) = [1] in x + x \ No newline at end of file diff --git a/frontend/tests/cases/negative/gex0.gr.output b/frontend/tests/cases/negative/gex0.gr.output new file mode 100644 index 000000000..0af8231fc --- /dev/null +++ b/frontend/tests/cases/negative/gex0.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 4:39: +2 is not approximatable by 1 for type Nat because Nat denotes precise usage. \ No newline at end of file diff --git a/frontend/tests/cases/negative/headAlt.gr.output b/frontend/tests/cases/negative/headAlt.gr.output new file mode 100644 index 000000000..0c77dd2c6 --- /dev/null +++ b/frontend/tests/cases/negative/headAlt.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Impossible pattern match: 6:1: +Pattern match in an equation of `headAlt` is impossible as it implies the unsatisfiable condition (1..1 ≤ 0..1) ∧ (0 > 0) \ No newline at end of file diff --git a/frontend/tests/cases/negative/headAlt2.gr.output b/frontend/tests/cases/negative/headAlt2.gr.output new file mode 100644 index 000000000..c1552b5d1 --- /dev/null +++ b/frontend/tests/cases/negative/headAlt2.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Falsifiable theorem: 10:1: +The following theorem associated with `foo` is falsifiable: + (0..1 ≤ 0..1) ∧ (0 > 0) \ No newline at end of file diff --git a/frontend/tests/cases/negative/headAlt3.gr.output b/frontend/tests/cases/negative/headAlt3.gr.output new file mode 100644 index 000000000..0669f08cc --- /dev/null +++ b/frontend/tests/cases/negative/headAlt3.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 9:1: +The following theorem associated with `headAlt'` is falsifiable: + ((n > 0) -> (0..1 ≤ 0..1) ∧ (n1 > 1)) \ No newline at end of file diff --git a/frontend/tests/cases/negative/if0pair.gr.output b/frontend/tests/cases/negative/if0pair.gr.output new file mode 100644 index 000000000..56cd8addd --- /dev/null +++ b/frontend/tests/cases/negative/if0pair.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 3:9: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/negative/implicitKind.gr b/frontend/tests/cases/negative/implicitKind.gr new file mode 100644 index 000000000..4df6e596b --- /dev/null +++ b/frontend/tests/cases/negative/implicitKind.gr @@ -0,0 +1,12 @@ +data Vec (n : Nat) t where + Nil : Vec 0 t; + Cons : t -> Vec n t -> Vec (n+1) t + +data N (n : Nat) where + Z : N 0; + S : N n -> N (n+1) + +-- Implicit kinds inferred +leng : forall t n. Vec n (n [0]) -> N t +leng Nil = Z; +leng (Cons [_] xs) = S (leng xs) \ No newline at end of file diff --git a/frontend/tests/cases/negative/implicitKind.gr.output b/frontend/tests/cases/negative/implicitKind.gr.output new file mode 100644 index 000000000..acefe860f --- /dev/null +++ b/frontend/tests/cases/negative/implicitKind.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unification failed: 10:1: +Trying to unify `↑Nat` and `Type` \ No newline at end of file diff --git a/frontend/tests/cases/negative/impossible-pattern-match.gr b/frontend/tests/cases/negative/impossible-pattern-match.gr new file mode 100644 index 000000000..62532cd48 --- /dev/null +++ b/frontend/tests/cases/negative/impossible-pattern-match.gr @@ -0,0 +1,8 @@ +import Nat + +subBad + : forall {m n : Nat} + . {n ≥ m} => N n -> N m -> N (n - m) +subBad m Z = m; +subBad Z (S n') = subBad Z n'; -- impossible +subBad (S m') (S n') = subBad m' n' \ No newline at end of file diff --git a/frontend/tests/cases/negative/impossible-pattern-match.gr.output b/frontend/tests/cases/negative/impossible-pattern-match.gr.output new file mode 100644 index 000000000..b03076560 --- /dev/null +++ b/frontend/tests/cases/negative/impossible-pattern-match.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Impossible pattern match: 7:1: +Pattern match in an equation of `subBad` is impossible as it implies the unsatisfiable condition ∃ n0.13 : ↑Nat . (0 ≥ n0.13 + 1) \ No newline at end of file diff --git a/frontend/tests/cases/negative/impossiblePat.gr.output b/frontend/tests/cases/negative/impossiblePat.gr.output new file mode 100644 index 000000000..c44bdd35a --- /dev/null +++ b/frontend/tests/cases/negative/impossiblePat.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 8:1: +The following theorem associated with `last` is falsifiable: + ∀ n0.1 : ↑Nat,t3.1 : Type,t4.1 : Type,t5.1 : ↑Nat . ((0..0 ≤ 0..1) ∧ (n0.1 + 1 = n + 1) -> (0..1 ≤ 0..1)) \ No newline at end of file diff --git a/frontend/tests/cases/negative/intervalApprox.gr b/frontend/tests/cases/negative/intervalApprox.gr new file mode 100644 index 000000000..ca61e57aa --- /dev/null +++ b/frontend/tests/cases/negative/intervalApprox.gr @@ -0,0 +1,6 @@ +foo : forall {a : Type} . a [0..Inf] -> (a, a) +foo [a] = (a, a) + +-- Bad approx (wrong way) +intervalApprox : forall {a : Type} . a [1..2] -> (a, a) +intervalApprox = foo \ No newline at end of file diff --git a/frontend/tests/cases/negative/intervalApprox.gr.output b/frontend/tests/cases/negative/intervalApprox.gr.output new file mode 100644 index 000000000..e6048aa69 --- /dev/null +++ b/frontend/tests/cases/negative/intervalApprox.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Falsifiable theorem: 6:1: +The following theorem associated with `intervalApprox` is falsifiable: + (0..∞ ≤ 1..2) \ No newline at end of file diff --git a/frontend/tests/cases/negative/intervals.gr.output b/frontend/tests/cases/negative/intervals.gr.output new file mode 100644 index 000000000..ce017f35c --- /dev/null +++ b/frontend/tests/cases/negative/intervals.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 6:13: +1..1 is not approximatable by 2..2 for type Interval Nat \ No newline at end of file diff --git a/frontend/tests/cases/negative/isEmpty.gr.output b/frontend/tests/cases/negative/isEmpty.gr.output new file mode 100644 index 000000000..d5974173d --- /dev/null +++ b/frontend/tests/cases/negative/isEmpty.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound type constructor: 3:1: +`Vec` \ No newline at end of file diff --git a/frontend/tests/cases/negative/kind-mismatch.gr b/frontend/tests/cases/negative/kind-mismatch.gr new file mode 100644 index 000000000..eebfd6690 --- /dev/null +++ b/frontend/tests/cases/negative/kind-mismatch.gr @@ -0,0 +1,7 @@ +-- correct: +-- push : forall {a b : Type, k : Coeffect, c : k} + +-- bad: +push : forall {a b : Type, c : Coeffect} + . (a, b) [c] -> (a [c], b [c]) +push [(x, y)] = ([x], [y]) \ No newline at end of file diff --git a/frontend/tests/cases/negative/kind-mismatch.gr.output b/frontend/tests/cases/negative/kind-mismatch.gr.output new file mode 100644 index 000000000..7fcfdbcaf --- /dev/null +++ b/frontend/tests/cases/negative/kind-mismatch.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Kind mismatch: 5:1: +Expected kind `↑coeffectType` but got `Coeffect` \ No newline at end of file diff --git a/frontend/tests/cases/negative/lambdaApprox.gr b/frontend/tests/cases/negative/lambdaApprox.gr new file mode 100644 index 000000000..239bba442 --- /dev/null +++ b/frontend/tests/cases/negative/lambdaApprox.gr @@ -0,0 +1,2 @@ +lambdaApprox : Int [0..0] -> Int +lambdaApprox = \[x] -> x \ No newline at end of file diff --git a/frontend/tests/cases/negative/lambdaApprox.gr.output b/frontend/tests/cases/negative/lambdaApprox.gr.output new file mode 100644 index 000000000..f14ea553e --- /dev/null +++ b/frontend/tests/cases/negative/lambdaApprox.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 2:16: +1..1 is not approximatable by 0..0 for type Interval Nat \ No newline at end of file diff --git a/frontend/tests/cases/negative/leak.gr.output b/frontend/tests/cases/negative/leak.gr.output new file mode 100644 index 000000000..32a87344f --- /dev/null +++ b/frontend/tests/cases/negative/leak.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 4:1: +Private value cannot be moved to level Public \ No newline at end of file diff --git a/frontend/tests/cases/negative/letdiaLinearity.gr.output b/frontend/tests/cases/negative/letdiaLinearity.gr.output new file mode 100644 index 000000000..3512671fe --- /dev/null +++ b/frontend/tests/cases/negative/letdiaLinearity.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 2:7: +Linear variable `x` is never used. \ No newline at end of file diff --git a/frontend/tests/cases/negative/levelApprox.gr b/frontend/tests/cases/negative/levelApprox.gr new file mode 100644 index 000000000..f71e1ae68 --- /dev/null +++ b/frontend/tests/cases/negative/levelApprox.gr @@ -0,0 +1,3 @@ +-- Bad, declassification +castLevel : ∀ {a : Type} . a [Private] → a [Public] +castLevel [x] = [x] \ No newline at end of file diff --git a/frontend/tests/cases/negative/levelApprox.gr.output b/frontend/tests/cases/negative/levelApprox.gr.output new file mode 100644 index 000000000..25e5ceb17 --- /dev/null +++ b/frontend/tests/cases/negative/levelApprox.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 3:1: +Private value cannot be moved to level Public \ No newline at end of file diff --git a/frontend/tests/cases/negative/levelContractionWrongSpec.gr.output b/frontend/tests/cases/negative/levelContractionWrongSpec.gr.output new file mode 100644 index 000000000..32a87344f --- /dev/null +++ b/frontend/tests/cases/negative/levelContractionWrongSpec.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 4:1: +Private value cannot be moved to level Public \ No newline at end of file diff --git a/frontend/tests/cases/negative/localBinding.gr.output b/frontend/tests/cases/negative/localBinding.gr.output new file mode 100644 index 000000000..16570d9dd --- /dev/null +++ b/frontend/tests/cases/negative/localBinding.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 3:8: +1 is not approximatable by 3 for type Nat because Nat denotes precise usage. \ No newline at end of file diff --git a/frontend/tests/cases/negative/name-clash-data-constr.gr b/frontend/tests/cases/negative/name-clash-data-constr.gr new file mode 100644 index 000000000..8c7913e19 --- /dev/null +++ b/frontend/tests/cases/negative/name-clash-data-constr.gr @@ -0,0 +1,7 @@ +data Type1 = A | B | C + +data Type2 = A + +data Type3 where + A : Type3; + B : Type3 \ No newline at end of file diff --git a/frontend/tests/cases/negative/name-clash-data-constr.gr.output b/frontend/tests/cases/negative/name-clash-data-constr.gr.output new file mode 100644 index 000000000..256d52ffd --- /dev/null +++ b/frontend/tests/cases/negative/name-clash-data-constr.gr.output @@ -0,0 +1,9 @@ +Type checking failed: +Data constructor name clash: 3:14: +`A` already defined at + (location redacted) + (location redacted) + +Data constructor name clash: 7:3: +`B` already defined at + (location redacted) \ No newline at end of file diff --git a/frontend/tests/cases/negative/name-clash-type-def.gr b/frontend/tests/cases/negative/name-clash-type-def.gr new file mode 100644 index 000000000..3b13404f7 --- /dev/null +++ b/frontend/tests/cases/negative/name-clash-type-def.gr @@ -0,0 +1,9 @@ +data A where -- 1 + +data A where -- 2 <-- complain about this one, mentioning 1 and 4 + +data B where -- 3 + +data A where -- 4 + +data B where -- 5 <-- complain about this one, mentioning 3 \ No newline at end of file diff --git a/frontend/tests/cases/negative/name-clash-type-def.gr.output b/frontend/tests/cases/negative/name-clash-type-def.gr.output new file mode 100644 index 000000000..73c04015a --- /dev/null +++ b/frontend/tests/cases/negative/name-clash-type-def.gr.output @@ -0,0 +1,9 @@ +Type checking failed: +Type constructor name clash: 3:1: +`A` already defined at + (location redacted) + (location redacted) + +Type constructor name clash: 9:1: +`B` already defined at + (location redacted) \ No newline at end of file diff --git a/frontend/tests/cases/errors/name-clash.gr b/frontend/tests/cases/negative/name-clash.gr similarity index 100% rename from frontend/tests/cases/errors/name-clash.gr rename to frontend/tests/cases/negative/name-clash.gr diff --git a/frontend/tests/cases/negative/name-clash.gr.output b/frontend/tests/cases/negative/name-clash.gr.output new file mode 100644 index 000000000..60119e9ff --- /dev/null +++ b/frontend/tests/cases/negative/name-clash.gr.output @@ -0,0 +1,8 @@ +Type checking failed: +Definition name clash: 6:1: +`id` already defined at + (location redacted) + +Definition name clash: 12:1: +`onlyDefinedHere` already defined at + (location redacted) \ No newline at end of file diff --git a/frontend/tests/cases/negative/nestedWildLinearAbs.gr.output b/frontend/tests/cases/negative/nestedWildLinearAbs.gr.output new file mode 100644 index 000000000..999fab195 --- /dev/null +++ b/frontend/tests/cases/negative/nestedWildLinearAbs.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 2:6: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/negative/noConsumption.gr.output b/frontend/tests/cases/negative/noConsumption.gr.output new file mode 100644 index 000000000..61836f786 --- /dev/null +++ b/frontend/tests/cases/negative/noConsumption.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Impossible pattern match: 4:1: +Pattern match in an equation of `and` is impossible as it implies the unsatisfiable condition (0 = 1) +(0 = 1) diff --git a/frontend/tests/cases/negative/nonLinearCase.gr.output b/frontend/tests/cases/negative/nonLinearCase.gr.output new file mode 100644 index 000000000..f3699e1f5 --- /dev/null +++ b/frontend/tests/cases/negative/nonLinearCase.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 5:5: +Linear variable `x` is never used. \ No newline at end of file diff --git a/frontend/tests/cases/negative/occurs.gr b/frontend/tests/cases/negative/occurs.gr new file mode 100644 index 000000000..1cf3cbba6 --- /dev/null +++ b/frontend/tests/cases/negative/occurs.gr @@ -0,0 +1,16 @@ +-- gr --no-eval + +data Lam : Type → Type where + Lift : ∀ a : Type . a → Lam a; --- lifted value + Pair : ∀ a : Type, b : Type . a → b → Lam (a,b); --- product + Lam : ∀ a : Type, b : Type . (a → b) → Lam (a → b); --- lambda abstraction + App : ∀ a : Type, b : Type . Lam (a → b) → Lam a → Lam b; --- beta reduction + Fix : ∀ a : Type . (Lam (a → a)) [∞] → Lam a --- fixed point + +eval : ∀ a : Type . Lam a → a +eval e = case e of + (Lift v) → v; + (Pair l r) → (eval l, eval r); + (Lam f) → λx → eval (f (Lift x)); + (App f x) → (eval f) (eval x); + (Fix [f]) → (eval f) (eval (Fix [f])) diff --git a/frontend/tests/cases/negative/occurs.gr.output b/frontend/tests/cases/negative/occurs.gr.output new file mode 100644 index 000000000..b5d41ffb7 --- /dev/null +++ b/frontend/tests/cases/negative/occurs.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unification failed: 13:25: +Type variable `a6` cannot be unified with type `Lam a6` (occurs check failure; implies infinite type). \ No newline at end of file diff --git a/frontend/tests/cases/negative/patternCoeffect.gr.output b/frontend/tests/cases/negative/patternCoeffect.gr.output new file mode 100644 index 000000000..7a628191c --- /dev/null +++ b/frontend/tests/cases/negative/patternCoeffect.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 7:3: +3 is not approximatable by 2 for type Nat because Nat denotes precise usage. \ No newline at end of file diff --git a/frontend/tests/cases/negative/polarity.gr.output b/frontend/tests/cases/negative/polarity.gr.output new file mode 100644 index 000000000..be2e82003 --- /dev/null +++ b/frontend/tests/cases/negative/polarity.gr.output @@ -0,0 +1,7 @@ +Type checking failed: +Unification failed: 3:40: +Type variable `a` cannot be unified with type `a [0]` (occurs check failure; implies infinite type). + +Falsifiable theorem: 7:1: +The following theorem associated with `secondOrderAlt` is falsifiable: + (prom_[7:26]0 = 0) ∧ (1 = prom_[7:26]0) \ No newline at end of file diff --git a/frontend/tests/cases/negative/polarityHO.gr.output b/frontend/tests/cases/negative/polarityHO.gr.output new file mode 100644 index 000000000..f2341f4c3 --- /dev/null +++ b/frontend/tests/cases/negative/polarityHO.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Pattern typing error: 3:52: +Pattern match `[y]` does not have expected type `Int` \ No newline at end of file diff --git a/frontend/tests/cases/negative/poly.gr.output b/frontend/tests/cases/negative/poly.gr.output new file mode 100644 index 000000000..e760ab5db --- /dev/null +++ b/frontend/tests/cases/negative/poly.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unification failed: 2:9: +Cannot unify universally quantified type variable `a`` of kind `Type` with a concrete type `Int` \ No newline at end of file diff --git a/frontend/tests/cases/negative/polyGradeBad.gr b/frontend/tests/cases/negative/polyGradeBad.gr new file mode 100644 index 000000000..53dedd6cb --- /dev/null +++ b/frontend/tests/cases/negative/polyGradeBad.gr @@ -0,0 +1,3 @@ +-- Incorrect grade generic function +cp : forall {a : Type, c : Coeffect} . a [(1 + 1 + 1):c] -> (a × a) +cp [x] = (x, x) \ No newline at end of file diff --git a/frontend/tests/cases/negative/polyGradeBad.gr.output b/frontend/tests/cases/negative/polyGradeBad.gr.output new file mode 100644 index 000000000..b5fabfe4d --- /dev/null +++ b/frontend/tests/cases/negative/polyGradeBad.gr.output @@ -0,0 +1,4 @@ +Fatal error: +It is unknown whether (1 + 1) .< (1 + (1 + 1)) holds for all resource algebras. +CallStack (from HasCallStack): + error, called at src/Language/Granule/Checker/Constraints/SymbolicGrades.hs:272:3 in granule-frontend-0.7.3.0-JLcnPrGgMMqLIMTBGiwzbe:Language.Granule.Checker.Constraints.SymbolicGrades \ No newline at end of file diff --git a/frontend/tests/cases/negative/polyo.gr.output b/frontend/tests/cases/negative/polyo.gr.output new file mode 100644 index 000000000..c6a53afc5 --- /dev/null +++ b/frontend/tests/cases/negative/polyo.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound type constructor: 4:1: +`Bool` \ No newline at end of file diff --git a/frontend/tests/cases/negative/predicateFalseInDef.gr.output b/frontend/tests/cases/negative/predicateFalseInDef.gr.output new file mode 100644 index 000000000..0c77dd2c6 --- /dev/null +++ b/frontend/tests/cases/negative/predicateFalseInDef.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Impossible pattern match: 6:1: +Pattern match in an equation of `headAlt` is impossible as it implies the unsatisfiable condition (1..1 ≤ 0..1) ∧ (0 > 0) \ No newline at end of file diff --git a/frontend/tests/cases/negative/predicateFalseInUse.gr.output b/frontend/tests/cases/negative/predicateFalseInUse.gr.output new file mode 100644 index 000000000..b1823e0c0 --- /dev/null +++ b/frontend/tests/cases/negative/predicateFalseInUse.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Falsifiable theorem: 9:1: +The following theorem associated with `foo` is falsifiable: + (0..1 ≤ 0..1) ∧ (0 > 0) \ No newline at end of file diff --git a/frontend/tests/cases/negative/promotionConsumptionPat.gr.output b/frontend/tests/cases/negative/promotionConsumptionPat.gr.output new file mode 100644 index 000000000..bc2410516 --- /dev/null +++ b/frontend/tests/cases/negative/promotionConsumptionPat.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 3:5: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/negative/scale.gr.output b/frontend/tests/cases/negative/scale.gr.output new file mode 100644 index 000000000..501da753f --- /dev/null +++ b/frontend/tests/cases/negative/scale.gr.output @@ -0,0 +1,6 @@ +Type checking failed: +Unbound variable error: 2:10: +`scale` + +Unbound variable error: 5:20: +`scale` \ No newline at end of file diff --git a/frontend/tests/cases/negative/security.gr b/frontend/tests/cases/negative/security.gr new file mode 100644 index 000000000..f1e210f05 --- /dev/null +++ b/frontend/tests/cases/negative/security.gr @@ -0,0 +1,17 @@ +-- The following is not typeable: +-- leak : Int [Private] → Int [Public] +-- leak [x] = [x] + +notALeak : (Int [Private]) [0] → Int [Public] +notALeak [x] = [0] + +secret : Int [Private] +secret = [1234] + +hash : ∀ l : Level . Int [l] → Int [l] +hash [x] = [x + x] + +-- If `main` was of type `Int [Public]`, this wouldn't type check, i.e. the secret +-- can't be used in a Public security environment. +main : Int [Public] +main = hash secret \ No newline at end of file diff --git a/frontend/tests/cases/negative/security.gr.output b/frontend/tests/cases/negative/security.gr.output new file mode 100644 index 000000000..a2e7654ee --- /dev/null +++ b/frontend/tests/cases/negative/security.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Grading error: 17:8: +Private value cannot be moved to level Public \ No newline at end of file diff --git a/frontend/tests/cases/negative/signature-equation-name-mismatch.gr b/frontend/tests/cases/negative/signature-equation-name-mismatch.gr new file mode 100644 index 000000000..08d471f74 --- /dev/null +++ b/frontend/tests/cases/negative/signature-equation-name-mismatch.gr @@ -0,0 +1,2 @@ +foo : Int +f00 = 5 \ No newline at end of file diff --git a/frontend/tests/cases/negative/signature-equation-name-mismatch.gr.output b/frontend/tests/cases/negative/signature-equation-name-mismatch.gr.output new file mode 100644 index 000000000..67bf5d175 --- /dev/null +++ b/frontend/tests/cases/negative/signature-equation-name-mismatch.gr.output @@ -0,0 +1,2 @@ +Parse error: +Name for equation `f00` does not match the signature head `foo` diff --git a/frontend/tests/cases/negative/two-errors.gr b/frontend/tests/cases/negative/two-errors.gr new file mode 100644 index 000000000..4a10fec92 --- /dev/null +++ b/frontend/tests/cases/negative/two-errors.gr @@ -0,0 +1,7 @@ +-- ensure that we report both errors + +foo : Int +foo = () + +bar : () +bar = 1 \ No newline at end of file diff --git a/frontend/tests/cases/negative/two-errors.gr.output b/frontend/tests/cases/negative/two-errors.gr.output new file mode 100644 index 000000000..b6901019b --- /dev/null +++ b/frontend/tests/cases/negative/two-errors.gr.output @@ -0,0 +1,6 @@ +Type checking failed: +Type error: 4:7: +Expected `Int` but got `()` + +Type error: 7:7: +Expected `()` but got `Int` \ No newline at end of file diff --git a/frontend/tests/cases/negative/twoBox.gr.output b/frontend/tests/cases/negative/twoBox.gr.output new file mode 100644 index 000000000..77de01eef --- /dev/null +++ b/frontend/tests/cases/negative/twoBox.gr.output @@ -0,0 +1,6 @@ +Type checking failed: +Unbound type constructor: 4:1: +`Vec` + +Unbound type constructor: 7:1: +`Vec` \ No newline at end of file diff --git a/frontend/tests/cases/negative/ty-var-clashes.gr.output b/frontend/tests/cases/negative/ty-var-clashes.gr.output new file mode 100644 index 000000000..36ce19a7b --- /dev/null +++ b/frontend/tests/cases/negative/ty-var-clashes.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Kind mismatch: 2:3: +Expected kind `Type` but got `Type -> Type` \ No newline at end of file diff --git a/frontend/tests/cases/negative/tyConClash.gr.output b/frontend/tests/cases/negative/tyConClash.gr.output new file mode 100644 index 000000000..bbaa60464 --- /dev/null +++ b/frontend/tests/cases/negative/tyConClash.gr.output @@ -0,0 +1,9 @@ +Type checking failed: +Type constructor name clash: 1:1: +Type constructor `Int` already defined + +Type constructor name clash: 3:1: +Type constructor `Float` already defined + +Type constructor name clash: 5:1: +Type constructor `()` already defined \ No newline at end of file diff --git a/frontend/tests/cases/negative/unbound.gr b/frontend/tests/cases/negative/unbound.gr new file mode 100644 index 000000000..62fe749f5 --- /dev/null +++ b/frontend/tests/cases/negative/unbound.gr @@ -0,0 +1,2 @@ +foo : Int -> Int +foo 2 = 🍊 \ No newline at end of file diff --git a/frontend/tests/cases/negative/unbound.gr.output b/frontend/tests/cases/negative/unbound.gr.output new file mode 100644 index 000000000..b1f49f794 --- /dev/null +++ b/frontend/tests/cases/negative/unbound.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound variable error: 2:9: +`🍊` \ No newline at end of file diff --git a/frontend/tests/cases/negative/universal.gr.output b/frontend/tests/cases/negative/universal.gr.output new file mode 100644 index 000000000..b435c620f --- /dev/null +++ b/frontend/tests/cases/negative/universal.gr.output @@ -0,0 +1,4 @@ +Type checking failed: +Counter example: 2:1: +The following theorem associated with `foo` is falsifiable: + (2 = n) \ No newline at end of file diff --git a/frontend/tests/cases/negative/unknownTyCon.gr.output b/frontend/tests/cases/negative/unknownTyCon.gr.output new file mode 100644 index 000000000..7707c0d0a --- /dev/null +++ b/frontend/tests/cases/negative/unknownTyCon.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound type constructor: 2:1: +`One` \ No newline at end of file diff --git a/frontend/tests/cases/negative/unknownTyVar.gr.output b/frontend/tests/cases/negative/unknownTyVar.gr.output new file mode 100644 index 000000000..3230d76c1 --- /dev/null +++ b/frontend/tests/cases/negative/unknownTyVar.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Unbound type variable: 1:1: +`a` is not quantified \ No newline at end of file diff --git a/frontend/tests/cases/negative/wild.gr.output b/frontend/tests/cases/negative/wild.gr.output new file mode 100644 index 000000000..456b13281 --- /dev/null +++ b/frontend/tests/cases/negative/wild.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 8:13: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/negative/wild2.gr.output b/frontend/tests/cases/negative/wild2.gr.output new file mode 100644 index 000000000..a6176f766 --- /dev/null +++ b/frontend/tests/cases/negative/wild2.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 2:5: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/negative/wildOrderAbs.gr.output b/frontend/tests/cases/negative/wildOrderAbs.gr.output new file mode 100644 index 000000000..a6176f766 --- /dev/null +++ b/frontend/tests/cases/negative/wildOrderAbs.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 2:5: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/negative/wildcard.gr.output b/frontend/tests/cases/negative/wildcard.gr.output new file mode 100644 index 000000000..bc2410516 --- /dev/null +++ b/frontend/tests/cases/negative/wildcard.gr.output @@ -0,0 +1,3 @@ +Type checking failed: +Linearity error: 3:5: +Wildcard pattern `_` allowing a value to be discarded \ No newline at end of file diff --git a/frontend/tests/cases/positive/FilesBoxed2.gr b/frontend/tests/cases/positive/FilesBoxed2.gr new file mode 100644 index 000000000..4e80fc20e --- /dev/null +++ b/frontend/tests/cases/positive/FilesBoxed2.gr @@ -0,0 +1,12 @@ +import File + +main : String +main = + let [[mh]] = [[openHandle ReadMode "LICENSE"]] in + let h <- mh; + h' <- mh; + () <- closeHandle h'; + (h, c) <- readChar h; + (h, c') <- readChar h; + () <- closeHandle h + in pure ((showChar c) `stringAppend` (showChar c')) diff --git a/frontend/tests/cases/positive/FilesBoxed2.gr.output b/frontend/tests/cases/positive/FilesBoxed2.gr.output new file mode 100644 index 000000000..586bc9d14 --- /dev/null +++ b/frontend/tests/cases/positive/FilesBoxed2.gr.output @@ -0,0 +1 @@ +"Co" \ No newline at end of file diff --git a/frontend/tests/cases/positive/PromoteData.gr b/frontend/tests/cases/positive/PromoteData.gr new file mode 100644 index 000000000..be5428689 --- /dev/null +++ b/frontend/tests/cases/positive/PromoteData.gr @@ -0,0 +1,12 @@ +data Bool = True | False + +data InOrOut : Bool -> Type -> Type where + In : forall {a : Type} . a -> InOrOut True a; + Out : forall {a : Type} . InOrOut False a + +test : forall {b : Bool} . InOrOut b Int -> InOrOut b Int +test (In x) = In (x * 2); +test Out = Out + +lala : forall {b : Bool} . InOrOut True Int -> Int +lala (In x) = x diff --git a/frontend/tests/cases/positive/absorbLevels.gr b/frontend/tests/cases/positive/absorbLevels.gr new file mode 100644 index 000000000..8bdf9160a --- /dev/null +++ b/frontend/tests/cases/positive/absorbLevels.gr @@ -0,0 +1,6 @@ +der : forall {a : Type} + . a [Public] -> a +der [x] = x + +test : forall {a : Type} . a [0:Level] -> a [0:Level] +test [x] = [der [x]] \ No newline at end of file diff --git a/frontend/tests/cases/positive/balanced.gr b/frontend/tests/cases/positive/balanced.gr deleted file mode 100644 index f5ef5d601..000000000 --- a/frontend/tests/cases/positive/balanced.gr +++ /dev/null @@ -1,7 +0,0 @@ -data Balanced (diff : Nat) where - Init : Balanced 0; - Open : Balanced diff → Balanced (diff + 1); - Close : Balanced (diff + 1) → Balanced diff - -test : Balanced 0 -test = Close (Open Init) diff --git a/frontend/tests/cases/positive/big.gr b/frontend/tests/cases/positive/big.gr new file mode 100644 index 000000000..b4c84eadc --- /dev/null +++ b/frontend/tests/cases/positive/big.gr @@ -0,0 +1,82 @@ +-- stolen from Edwin Brady :) + +data Bool = False | True + +data Vec (n : Nat) t where + Nil : Vec 0 t; + Cons : t -> Vec n t -> Vec (n + 1) t + +stuff : Vec 390 Bool +stuff = Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + (Cons False (Cons True (Cons False (Cons True (Cons False (Cons True + Nil))))))))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) + )))))))))))))))))))))))))))))))))))))))))))))))) \ No newline at end of file diff --git a/frontend/tests/cases/positive/bool.gr.output b/frontend/tests/cases/positive/bool.gr.output new file mode 100644 index 000000000..2bf5f726f --- /dev/null +++ b/frontend/tests/cases/positive/bool.gr.output @@ -0,0 +1 @@ +(False, Success) \ No newline at end of file diff --git a/frontend/tests/cases/positive/box.gr b/frontend/tests/cases/positive/box.gr index 5444ee7ec..d7348ef6c 100644 --- a/frontend/tests/cases/positive/box.gr +++ b/frontend/tests/cases/positive/box.gr @@ -1,2 +1,4 @@ +-- gr --no-eval + const : ∀ {a : Type, b : Type} . a → b [] → a const x [y] = x diff --git a/frontend/tests/cases/positive/breadth-first.gr b/frontend/tests/cases/positive/breadth-first.gr index 0a14df8fa..16e54276c 100644 --- a/frontend/tests/cases/positive/breadth-first.gr +++ b/frontend/tests/cases/positive/breadth-first.gr @@ -1,14 +1,16 @@ +-- gr --no-eval + import Maybe data BFLevel (c : Nat) a where - N : a → (BFLevel c a) [0..c] → BFLevel c a; - R : a → BFLevel c a + Node : a → (BFLevel c a) [0..c] → BFLevel c a; + Root : a → BFLevel c a label : ∀ {a : Type} . BFLevel 1 a → a label x = case x of - (N l [_]) → l; - (R l) → l + (Node l [_]) → l; + (Root l) → l -- 1 -- / \ @@ -19,10 +21,10 @@ data BFTree a where Next : (BFLevel 1 a) [0..1] → BFTree a → BFTree a root : BFLevel 1 Int -root = R 1 +root = Root 1 ex0 : BFTree Int -ex0 = Next [N 2 [root]] (Next [N 3 [root]] Empty) +ex0 = Next [Node 2 [root]] (Next [Node 3 [root]] Empty) last : ∀ {a : Type} . BFTree a → Maybe a @@ -36,4 +38,4 @@ exLast : Int exLast = fromMaybe [42] (last ex0) main : () -main = write (showInt exLast) +main = toStdout (showInt exLast) diff --git a/frontend/tests/cases/positive/cap.gr b/frontend/tests/cases/positive/cap.gr index a15ed7851..23afbacb5 100644 --- a/frontend/tests/cases/positive/cap.gr +++ b/frontend/tests/cases/positive/cap.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + import Existential data Cap (a : Type) (p : Type) : Type where diff --git a/frontend/tests/cases/positive/case.gr.output b/frontend/tests/cases/positive/case.gr.output new file mode 100644 index 000000000..e440e5c84 --- /dev/null +++ b/frontend/tests/cases/positive/case.gr.output @@ -0,0 +1 @@ +3 \ No newline at end of file diff --git a/frontend/tests/cases/positive/char.gr.output b/frontend/tests/cases/positive/char.gr.output new file mode 100644 index 000000000..e99ac6610 --- /dev/null +++ b/frontend/tests/cases/positive/char.gr.output @@ -0,0 +1 @@ +Next 'h' (Next 'i' Empty) \ No newline at end of file diff --git a/frontend/tests/cases/positive/const.gr.output b/frontend/tests/cases/positive/const.gr.output new file mode 100644 index 000000000..7730ef7f3 --- /dev/null +++ b/frontend/tests/cases/positive/const.gr.output @@ -0,0 +1 @@ +89 \ No newline at end of file diff --git a/frontend/tests/cases/positive/cproduct.gr b/frontend/tests/cases/positive/cproduct.gr new file mode 100644 index 000000000..3861fbba6 --- /dev/null +++ b/frontend/tests/cases/positive/cproduct.gr @@ -0,0 +1,8 @@ +foo : Int [(2, 1..2)] -> Int +foo [x] = x + x + +test : Int [(4, 2..4)] -> Int +test [x] = foo [x] + foo [x] + +main : Int +main = test [42] \ No newline at end of file diff --git a/frontend/tests/cases/positive/cproduct.gr.output b/frontend/tests/cases/positive/cproduct.gr.output new file mode 100644 index 000000000..a3090d211 --- /dev/null +++ b/frontend/tests/cases/positive/cproduct.gr.output @@ -0,0 +1 @@ +168 \ No newline at end of file diff --git a/frontend/tests/cases/positive/either.gr b/frontend/tests/cases/positive/either.gr index 32b2ae422..366c2833a 100644 --- a/frontend/tests/cases/positive/either.gr +++ b/frontend/tests/cases/positive/either.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Maybe a where None : Maybe a; Some : a → Maybe a diff --git a/frontend/tests/cases/positive/empty-data-decl.gr b/frontend/tests/cases/positive/empty-data-decl.gr index 955c85758..808dfffe2 100644 --- a/frontend/tests/cases/positive/empty-data-decl.gr +++ b/frontend/tests/cases/positive/empty-data-decl.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Zero where data Succ a where diff --git a/frontend/tests/cases/positive/exact.gr.output b/frontend/tests/cases/positive/exact.gr.output new file mode 100644 index 000000000..3ca9062a1 --- /dev/null +++ b/frontend/tests/cases/positive/exact.gr.output @@ -0,0 +1 @@ +84 \ No newline at end of file diff --git a/frontend/tests/cases/positive/example.gr.output b/frontend/tests/cases/positive/example.gr.output new file mode 100644 index 000000000..da2d3988d --- /dev/null +++ b/frontend/tests/cases/positive/example.gr.output @@ -0,0 +1 @@ +14 \ No newline at end of file diff --git a/frontend/tests/cases/positive/expr.gr.output b/frontend/tests/cases/positive/expr.gr.output new file mode 100644 index 000000000..50a7fc029 --- /dev/null +++ b/frontend/tests/cases/positive/expr.gr.output @@ -0,0 +1 @@ +Div (Const 10.0) (Const 5.0) \ No newline at end of file diff --git a/frontend/tests/cases/positive/expr2.gr b/frontend/tests/cases/positive/expr2.gr index d15f947c1..b0d77caa8 100644 --- a/frontend/tests/cases/positive/expr2.gr +++ b/frontend/tests/cases/positive/expr2.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Expr a where Const : Int → Expr Int; Add : Expr a → Expr a → Expr a diff --git a/frontend/tests/cases/positive/extnat.gr b/frontend/tests/cases/positive/extnat.gr index e31de38c9..9d6e8e75d 100644 --- a/frontend/tests/cases/positive/extnat.gr +++ b/frontend/tests/cases/positive/extnat.gr @@ -1,2 +1,4 @@ +-- gr --no-eval + tst : Int [1 : Ext Nat] → Int tst [x] = x diff --git a/frontend/tests/cases/positive/fewerAnnotations.gr.output b/frontend/tests/cases/positive/fewerAnnotations.gr.output new file mode 100644 index 000000000..2af5ded1d --- /dev/null +++ b/frontend/tests/cases/positive/fewerAnnotations.gr.output @@ -0,0 +1 @@ +Cons 2 (Cons 3 (Cons 4 Nil)) \ No newline at end of file diff --git a/frontend/tests/cases/positive/float.gr.output b/frontend/tests/cases/positive/float.gr.output new file mode 100644 index 000000000..415b19fc3 --- /dev/null +++ b/frontend/tests/cases/positive/float.gr.output @@ -0,0 +1 @@ +2.0 \ No newline at end of file diff --git a/frontend/tests/cases/positive/gadt-balanced.gr b/frontend/tests/cases/positive/gadt-balanced.gr index f5ef5d601..8b200ba95 100644 --- a/frontend/tests/cases/positive/gadt-balanced.gr +++ b/frontend/tests/cases/positive/gadt-balanced.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Balanced (diff : Nat) where Init : Balanced 0; Open : Balanced diff → Balanced (diff + 1); diff --git a/frontend/tests/cases/positive/gadt.gr b/frontend/tests/cases/positive/gadt.gr index e73b2f64a..904748e82 100644 --- a/frontend/tests/cases/positive/gadt.gr +++ b/frontend/tests/cases/positive/gadt.gr @@ -1,14 +1,16 @@ -data A where - A : A -data B where - B : B +-- gr --no-eval + +data Bar where + Bar : Bar +data Boo where + Boo : Boo data Foo a where - MkA : A → Foo A; - MkB : B → Foo B + MkBar : Bar → Foo Bar; + MkBoo : Boo → Foo Boo unwrap : ∀ {a : Type} . Foo a → a unwrap x = case x of - (MkA x) → x; - (MkB x) → x + (MkBar x) → x; + (MkBoo x) → x diff --git a/frontend/tests/cases/positive/gex0.gr.output b/frontend/tests/cases/positive/gex0.gr.output new file mode 100644 index 000000000..d8263ee98 --- /dev/null +++ b/frontend/tests/cases/positive/gex0.gr.output @@ -0,0 +1 @@ +2 \ No newline at end of file diff --git a/frontend/tests/cases/positive/gex1.gr.output b/frontend/tests/cases/positive/gex1.gr.output new file mode 100644 index 000000000..62f945751 --- /dev/null +++ b/frontend/tests/cases/positive/gex1.gr.output @@ -0,0 +1 @@ +6 \ No newline at end of file diff --git a/frontend/tests/cases/positive/headAlt.gr b/frontend/tests/cases/positive/headAlt.gr index ee6f5b82d..dc9bce329 100644 --- a/frontend/tests/cases/positive/headAlt.gr +++ b/frontend/tests/cases/positive/headAlt.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Vec : Nat -> Type -> Type where Nil : forall {a : Type} . Vec 0 a; Cons : forall {a : Type, n : Nat} . a -> Vec n a -> Vec (n+1) a diff --git a/frontend/tests/cases/positive/headlist.gr b/frontend/tests/cases/positive/headlist.gr index 7720f70d1..2b38d79cb 100644 --- a/frontend/tests/cases/positive/headlist.gr +++ b/frontend/tests/cases/positive/headlist.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + import Result data List a where Empty; Next a (List a) diff --git a/frontend/tests/cases/positive/if0.gr b/frontend/tests/cases/positive/if0.gr index 1839f7238..198d02ba7 100644 --- a/frontend/tests/cases/positive/if0.gr +++ b/frontend/tests/cases/positive/if0.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + if0 : ∀ {a : Type} . Int [0..1] → a [0..1] → a [0..1] → a if0 [0] [x] [y] = x; if0 [_] [x] [y] = y diff --git a/frontend/tests/cases/positive/implicitKind2.gr b/frontend/tests/cases/positive/implicitKind2.gr new file mode 100644 index 000000000..f4730710a --- /dev/null +++ b/frontend/tests/cases/positive/implicitKind2.gr @@ -0,0 +1,4 @@ +data Fix (f : Type -> Type) = Fix (f (Fix f)) + +unfix : forall f . Fix f -> f (Fix f) +unfix (Fix x) = x diff --git a/frontend/tests/cases/positive/indexedMatch.gr b/frontend/tests/cases/positive/indexedMatch.gr new file mode 100644 index 000000000..63f404f4b --- /dev/null +++ b/frontend/tests/cases/positive/indexedMatch.gr @@ -0,0 +1,7 @@ +data Indexed a where + Inty : Int -> Indexed Int; + Chary : Char -> Indexed Char + +ofo : forall {a : Type} . Indexed a -> a +ofo (Inty i) = i; +ofo (Chary c) = c diff --git a/frontend/tests/cases/positive/infix.gr.output b/frontend/tests/cases/positive/infix.gr.output new file mode 100644 index 000000000..4791ed555 --- /dev/null +++ b/frontend/tests/cases/positive/infix.gr.output @@ -0,0 +1 @@ +True \ No newline at end of file diff --git a/frontend/tests/cases/positive/intervalApprox.gr b/frontend/tests/cases/positive/intervalApprox.gr new file mode 100644 index 000000000..14c9e250a --- /dev/null +++ b/frontend/tests/cases/positive/intervalApprox.gr @@ -0,0 +1,5 @@ +foo : forall {a : Type} . a [1..2] -> (a, a) +foo [a] = (a, a) + +intervalApprox : forall {a : Type} . a [0..Inf] -> (a, a) +intervalApprox = foo diff --git a/frontend/tests/cases/positive/intervals.gr b/frontend/tests/cases/positive/intervals.gr index 8a0c8e775..a4fb014e8 100644 --- a/frontend/tests/cases/positive/intervals.gr +++ b/frontend/tests/cases/positive/intervals.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + import Vec data Bool where True; False @@ -30,7 +32,7 @@ foo6 x [y] = if x > y then y else y -- bad! This should typecheck! foo7 : Int [1..∞] → Int -foo7 [n] = if n ≡ 0 then 1 else foo7 [n - 1] +foo7 [n] = if n == 0 then 1 else foo7 [n - 1] foo8 : Int → Int [2..3] → Int foo8 x [y] = if x > y then y else y + y diff --git a/frontend/tests/cases/positive/irrefutable.gr b/frontend/tests/cases/positive/irrefutable.gr index d02d2953e..ef2e6a995 100644 --- a/frontend/tests/cases/positive/irrefutable.gr +++ b/frontend/tests/cases/positive/irrefutable.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Bool where False : Bool; True : Bool data Pair a b where X : a → b → Pair a b diff --git a/frontend/tests/cases/positive/isSome.gr b/frontend/tests/cases/positive/isSome.gr index 4c145c045..1b57f9a44 100644 --- a/frontend/tests/cases/positive/isSome.gr +++ b/frontend/tests/cases/positive/isSome.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Maybe a where None : Maybe a; Some : a → Maybe a diff --git a/frontend/tests/cases/positive/kind-inference/fix.gr b/frontend/tests/cases/positive/kind-inference/fix.gr new file mode 100644 index 000000000..9d9a3f733 --- /dev/null +++ b/frontend/tests/cases/positive/kind-inference/fix.gr @@ -0,0 +1,4 @@ +data Fix (f : Type -> Type) = Fix (f (Fix f)) + +unfix : forall a : Type, f : Type -> Type . Fix f -> f (Fix f) +unfix (Fix x) = x \ No newline at end of file diff --git a/frontend/tests/cases/positive/kind-inference/type-nat.gr b/frontend/tests/cases/positive/kind-inference/type-nat.gr new file mode 100644 index 000000000..fa2333c21 --- /dev/null +++ b/frontend/tests/cases/positive/kind-inference/type-nat.gr @@ -0,0 +1,12 @@ +data Vec (n : Nat) t where + Nil : Vec 0 t; + Cons : t -> Vec n t -> Vec (n+1) t + +data N (n : Nat) where + Z : N 0; + S : N n -> N (n+1) + +-- Implicit kinds inferred +leng : forall t n. Vec n (t [0]) -> N n +leng Nil = Z; +leng (Cons [_] xs) = S (leng xs) diff --git a/frontend/tests/cases/positive/lambdaApprox.gr b/frontend/tests/cases/positive/lambdaApprox.gr new file mode 100644 index 000000000..53f3cab3d --- /dev/null +++ b/frontend/tests/cases/positive/lambdaApprox.gr @@ -0,0 +1,2 @@ +lambdaApprox : Int [0..4] -> Int +lambdaApprox = \[x] -> x \ No newline at end of file diff --git a/frontend/tests/cases/positive/lazy.gr b/frontend/tests/cases/positive/lazy.gr deleted file mode 100644 index 708983b59..000000000 --- a/frontend/tests/cases/positive/lazy.gr +++ /dev/null @@ -1,8 +0,0 @@ -bar : String -bar = read --- reads but doesn't do anything with that result - -foo : () → String -foo = λ() → read - -main : () -main = let userInp ← foo () in write userInp diff --git a/frontend/tests/cases/positive/levelAbsorb.gr b/frontend/tests/cases/positive/levelAbsorb.gr new file mode 100644 index 000000000..8bdf9160a --- /dev/null +++ b/frontend/tests/cases/positive/levelAbsorb.gr @@ -0,0 +1,6 @@ +der : forall {a : Type} + . a [Public] -> a +der [x] = x + +test : forall {a : Type} . a [0:Level] -> a [0:Level] +test [x] = [der [x]] \ No newline at end of file diff --git a/frontend/tests/cases/positive/levelApprox.gr b/frontend/tests/cases/positive/levelApprox.gr new file mode 100644 index 000000000..20d5a4a76 --- /dev/null +++ b/frontend/tests/cases/positive/levelApprox.gr @@ -0,0 +1,8 @@ +castLevel : ∀ {a : Type} . a [Public] → a [Private] +castLevel [x] = [x] + +ok : Int [Private] -> Int +ok [x] = x + +approxOk : Int [Public] -> Int +approxOk = ok \ No newline at end of file diff --git a/frontend/tests/cases/positive/list.gr.output b/frontend/tests/cases/positive/list.gr.output new file mode 100644 index 000000000..a29499a9d --- /dev/null +++ b/frontend/tests/cases/positive/list.gr.output @@ -0,0 +1 @@ +Cons 2 (Cons 4 (Cons 6 Nil)) \ No newline at end of file diff --git a/frontend/tests/cases/positive/maybe.gr.output b/frontend/tests/cases/positive/maybe.gr.output new file mode 100644 index 000000000..93f051ca6 --- /dev/null +++ b/frontend/tests/cases/positive/maybe.gr.output @@ -0,0 +1 @@ +(2, 3) \ No newline at end of file diff --git a/frontend/tests/cases/positive/maybePair.gr b/frontend/tests/cases/positive/maybePair.gr index fce43d02a..af051eec0 100644 --- a/frontend/tests/cases/positive/maybePair.gr +++ b/frontend/tests/cases/positive/maybePair.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + import Maybe maybePair : ∀ {a : Type, b : Type} . Maybe (a, b [0]) → a [0..1] → a diff --git a/frontend/tests/cases/positive/monoshaped.gr b/frontend/tests/cases/positive/monoshaped.gr index 746048388..90f10a882 100644 --- a/frontend/tests/cases/positive/monoshaped.gr +++ b/frontend/tests/cases/positive/monoshaped.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + -- Since unit type "monoshaped", i.e. has one constructor, then we allow -- pattern matching its constructor to have any coeffect, since the -- constructor itself contains no information diff --git a/frontend/tests/cases/positive/noninterf.gr b/frontend/tests/cases/positive/noninterf.gr new file mode 100644 index 000000000..9c338d6d4 --- /dev/null +++ b/frontend/tests/cases/positive/noninterf.gr @@ -0,0 +1,4 @@ +fooa : Int [Private] → Int [Public] +fooa [_] = [42] + -- x : Unused but Public * Unused = Unused and Unusused <= Private + -- i.e. cannot leak diff --git a/frontend/tests/cases/negative/levelPromotionWrongSpec.gr b/frontend/tests/cases/positive/noninterfAlt.gr similarity index 100% rename from frontend/tests/cases/negative/levelPromotionWrongSpec.gr rename to frontend/tests/cases/positive/noninterfAlt.gr diff --git a/frontend/tests/cases/positive/pair.gr.output b/frontend/tests/cases/positive/pair.gr.output new file mode 100644 index 000000000..0683cb25b --- /dev/null +++ b/frontend/tests/cases/positive/pair.gr.output @@ -0,0 +1 @@ +((1, 2), (3, (3, 3))) \ No newline at end of file diff --git a/frontend/tests/cases/positive/peano.gr b/frontend/tests/cases/positive/peano.gr index 572f88891..09a05c536 100644 --- a/frontend/tests/cases/positive/peano.gr +++ b/frontend/tests/cases/positive/peano.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Natural where Zero : Natural; Succ : Natural → Natural diff --git a/frontend/tests/cases/positive/poly.gr b/frontend/tests/cases/positive/polymorphism/poly.gr similarity index 100% rename from frontend/tests/cases/positive/poly.gr rename to frontend/tests/cases/positive/polymorphism/poly.gr diff --git a/frontend/tests/cases/positive/polymorphism/poly.gr.output b/frontend/tests/cases/positive/polymorphism/poly.gr.output new file mode 100644 index 000000000..56a6051ca --- /dev/null +++ b/frontend/tests/cases/positive/polymorphism/poly.gr.output @@ -0,0 +1 @@ +1 \ No newline at end of file diff --git a/frontend/tests/cases/positive/polymorphism/polyGradeGood.gr b/frontend/tests/cases/positive/polymorphism/polyGradeGood.gr new file mode 100644 index 000000000..48dbf0c75 --- /dev/null +++ b/frontend/tests/cases/positive/polymorphism/polyGradeGood.gr @@ -0,0 +1,3 @@ +-- Correct grade generic function +cp : forall {a : Type, c : Coeffect} . a [(1 + 1):c] -> (a × a) +cp [x] = (x, x) \ No newline at end of file diff --git a/frontend/tests/cases/positive/polymorphism/polyPoly.gr b/frontend/tests/cases/positive/polymorphism/polyPoly.gr new file mode 100644 index 000000000..c6f22692d --- /dev/null +++ b/frontend/tests/cases/positive/polymorphism/polyPoly.gr @@ -0,0 +1,9 @@ + +polyPoly : forall {a : Type, k : Coeffect, c : k} . a [(1+1)*c] -> (a, a) [c] +polyPoly [x] = [(x, x)] + +app : Int [4] -> (Int, Int) [2] +app [x] = polyPoly [x] + +go : (Int, Int) [2] +go = app [42] \ No newline at end of file diff --git a/frontend/tests/cases/positive/polymorphism/polymorph.gr b/frontend/tests/cases/positive/polymorphism/polymorph.gr new file mode 100644 index 000000000..ae7b659ee --- /dev/null +++ b/frontend/tests/cases/positive/polymorphism/polymorph.gr @@ -0,0 +1,9 @@ +foo : forall a b c. (a -> a) [] -> (b × c) -> (b × c) +foo [f] (x,y) = (f x, f y) + +id : forall a. a -> a +id x = x + +bar : forall d e. (d × e) -> (d × e) +bar = foo [id] + diff --git a/frontend/tests/cases/positive/postfix-joke.gr b/frontend/tests/cases/positive/postfix-joke.gr deleted file mode 100644 index 204d3cb30..000000000 --- a/frontend/tests/cases/positive/postfix-joke.gr +++ /dev/null @@ -1,7 +0,0 @@ -import Prelude - -thisSuitIsBlack : Bool -thisSuitIsBlack = False - -main : () -main = if thisSuitIsBlack `not` then "Great success!" `write` else "I am sad." `write` diff --git a/frontend/tests/cases/positive/postfix.gr b/frontend/tests/cases/positive/postfix.gr deleted file mode 100644 index ffdcf2520..000000000 --- a/frontend/tests/cases/positive/postfix.gr +++ /dev/null @@ -1,5 +0,0 @@ -succ : Int → Int -succ x = x + 1 - -main : () -main = (0 `succ` `succ`) `showInt` `write` diff --git a/frontend/tests/cases/positive/predicates.gr b/frontend/tests/cases/positive/predicates.gr index 89c5fcf0c..ebaf0501f 100644 --- a/frontend/tests/cases/positive/predicates.gr +++ b/frontend/tests/cases/positive/predicates.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Vec : Nat -> Type -> Type where Nil : forall {a : Type} . Vec 0 a; Cons : forall {a : Type, n : Nat} . a -> Vec n a -> Vec (n+1) a diff --git a/frontend/tests/cases/positive/privatise.gr b/frontend/tests/cases/positive/privatise.gr index 79ea94284..8fe48ba80 100644 --- a/frontend/tests/cases/positive/privatise.gr +++ b/frontend/tests/cases/positive/privatise.gr @@ -1,2 +1,4 @@ +-- gr --no-eval + privatise : Int [Public] → Int [Private] privatise [x] = [x] diff --git a/frontend/tests/cases/positive/product.gr b/frontend/tests/cases/positive/product.gr index e49790170..1492e7719 100644 --- a/frontend/tests/cases/positive/product.gr +++ b/frontend/tests/cases/positive/product.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + import Bool data X a b where diff --git a/frontend/tests/cases/positive/pushInstance.gr b/frontend/tests/cases/positive/pushInstance.gr new file mode 100644 index 000000000..101d43ce1 --- /dev/null +++ b/frontend/tests/cases/positive/pushInstance.gr @@ -0,0 +1,6 @@ +import Maybe +import Prelude + +-- Shows a use of push specialised to a concrete coeffect type +fromMaybeLeftPair' : forall a , b . (a, b) [0..1] -> Maybe a -> (a, b) +fromMaybeLeftPair' z m = let (x, [y]) = push z in (fromMaybe x m, y) \ No newline at end of file diff --git a/frontend/tests/cases/positive/range.gr.output b/frontend/tests/cases/positive/range.gr.output new file mode 100644 index 000000000..bfa6cc8fc --- /dev/null +++ b/frontend/tests/cases/positive/range.gr.output @@ -0,0 +1 @@ +Cons 0 (Cons 1 (Cons 2 (Cons 3 Nil))) \ No newline at end of file diff --git a/frontend/tests/cases/positive/replicate.gr.output b/frontend/tests/cases/positive/replicate.gr.output new file mode 100644 index 000000000..7e94ebcff --- /dev/null +++ b/frontend/tests/cases/positive/replicate.gr.output @@ -0,0 +1 @@ +Cons 5 (Cons 5 Nil) \ No newline at end of file diff --git a/frontend/tests/cases/positive/reuse-bounds.gr.output b/frontend/tests/cases/positive/reuse-bounds.gr.output new file mode 100644 index 000000000..bf0d87ab1 --- /dev/null +++ b/frontend/tests/cases/positive/reuse-bounds.gr.output @@ -0,0 +1 @@ +4 \ No newline at end of file diff --git a/frontend/tests/cases/positive/scopedVariables.gr b/frontend/tests/cases/positive/scopedVariables.gr index 24d907636..8160b35f6 100644 --- a/frontend/tests/cases/positive/scopedVariables.gr +++ b/frontend/tests/cases/positive/scopedVariables.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + id2 : ∀ {a : Type} . a → a id2 x = x diff --git a/frontend/tests/cases/positive/simple1.gr.output b/frontend/tests/cases/positive/simple1.gr.output new file mode 100644 index 000000000..3f10ffe7a --- /dev/null +++ b/frontend/tests/cases/positive/simple1.gr.output @@ -0,0 +1 @@ +15 \ No newline at end of file diff --git a/frontend/tests/cases/positive/simple2.gr.output b/frontend/tests/cases/positive/simple2.gr.output new file mode 100644 index 000000000..301160a93 --- /dev/null +++ b/frontend/tests/cases/positive/simple2.gr.output @@ -0,0 +1 @@ +8 \ No newline at end of file diff --git a/frontend/tests/cases/positive/simple3.gr.output b/frontend/tests/cases/positive/simple3.gr.output new file mode 100644 index 000000000..8e2afd342 --- /dev/null +++ b/frontend/tests/cases/positive/simple3.gr.output @@ -0,0 +1 @@ +17 \ No newline at end of file diff --git a/frontend/tests/cases/positive/simple4.gr.output b/frontend/tests/cases/positive/simple4.gr.output new file mode 100644 index 000000000..3e932fe8f --- /dev/null +++ b/frontend/tests/cases/positive/simple4.gr.output @@ -0,0 +1 @@ +34 \ No newline at end of file diff --git a/frontend/tests/cases/positive/simple5.gr.output b/frontend/tests/cases/positive/simple5.gr.output new file mode 100644 index 000000000..301160a93 --- /dev/null +++ b/frontend/tests/cases/positive/simple5.gr.output @@ -0,0 +1 @@ +8 \ No newline at end of file diff --git a/frontend/tests/cases/positive/simple6.gr.output b/frontend/tests/cases/positive/simple6.gr.output new file mode 100644 index 000000000..3f10ffe7a --- /dev/null +++ b/frontend/tests/cases/positive/simple6.gr.output @@ -0,0 +1 @@ +15 \ No newline at end of file diff --git a/frontend/tests/cases/positive/simple7.gr.output b/frontend/tests/cases/positive/simple7.gr.output new file mode 100644 index 000000000..6b3ed8d68 --- /dev/null +++ b/frontend/tests/cases/positive/simple7.gr.output @@ -0,0 +1 @@ +400 \ No newline at end of file diff --git a/frontend/tests/cases/positive/srepls.gr b/frontend/tests/cases/positive/srepls.gr index b2a345cc8..10306ffc3 100644 --- a/frontend/tests/cases/positive/srepls.gr +++ b/frontend/tests/cases/positive/srepls.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + dup : Int [2] → Int dup [n] = n + n diff --git a/frontend/tests/cases/positive/string.gr b/frontend/tests/cases/positive/string.gr index 154c7bf64..2187f0c54 100644 --- a/frontend/tests/cases/positive/string.gr +++ b/frontend/tests/cases/positive/string.gr @@ -1,4 +1,4 @@ -main : () -main = write "Hello world! +main : String +main = "Hello world! Yes, strings can be multiline. 🤔" diff --git a/frontend/tests/cases/positive/string.gr.output b/frontend/tests/cases/positive/string.gr.output new file mode 100644 index 000000000..328776913 --- /dev/null +++ b/frontend/tests/cases/positive/string.gr.output @@ -0,0 +1 @@ +"Hello world!\nYes, strings can be multiline.\n\129300" \ No newline at end of file diff --git a/frontend/tests/cases/positive/talk.gr b/frontend/tests/cases/positive/talk.gr index a9fee71ed..8ab4fa587 100644 --- a/frontend/tests/cases/positive/talk.gr +++ b/frontend/tests/cases/positive/talk.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + dub : Int [2] → Int dub [x] = x + x @@ -14,7 +16,7 @@ doTwice [f] [x] = in pure (a + b) echo : () -echo = let x ← read in write x +echo = let x ← fromStdin in toStdout x main : Int main = 42 diff --git a/frontend/tests/cases/positive/tasty.gr.output b/frontend/tests/cases/positive/tasty.gr.output new file mode 100644 index 000000000..da45eba2c --- /dev/null +++ b/frontend/tests/cases/positive/tasty.gr.output @@ -0,0 +1 @@ +(False, Wrap Slaw Chicken) \ No newline at end of file diff --git a/frontend/tests/cases/positive/tlla.gr b/frontend/tests/cases/positive/tlla.gr index 98ff45423..18dc59568 100644 --- a/frontend/tests/cases/positive/tlla.gr +++ b/frontend/tests/cases/positive/tlla.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + -- Hello TLLA dub : Int [2] → Int dub [x] = x + x @@ -18,8 +20,8 @@ hash : ∀ {l : Level} . Int [l] → Int [l] hash [x] = [x + x] hello : () -hello = let x ← read - in write x +hello = let x ← fromStdin + in toStdout x main : Int [Private] main = diff --git a/frontend/tests/cases/positive/vmap.gr b/frontend/tests/cases/positive/vmap.gr index 733ebe0b3..354f4e4d5 100644 --- a/frontend/tests/cases/positive/vmap.gr +++ b/frontend/tests/cases/positive/vmap.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Vec : Nat → Type → Type where Nil : ∀ {a : Type} . Vec 0 a; Cons : ∀ {a : Type, n : Nat} . a → Vec n a → Vec (n+1) a diff --git a/frontend/tests/cases/positive/ylppa.gr.output b/frontend/tests/cases/positive/ylppa.gr.output new file mode 100644 index 000000000..56a6051ca --- /dev/null +++ b/frontend/tests/cases/positive/ylppa.gr.output @@ -0,0 +1 @@ +1 \ No newline at end of file diff --git a/frontend/tests/cases/positive/zahl.gr b/frontend/tests/cases/positive/zahl.gr deleted file mode 100644 index 51321d50b..000000000 --- a/frontend/tests/cases/positive/zahl.gr +++ /dev/null @@ -1,14 +0,0 @@ -data Number where - Zahl : Int → Number - -n : Number -n = Zahl 42 - -check : Number → () -check n = - case n of - (Zahl 42) → write "0"; - (Zahl n) → write (showInt n) - -main : () -main = check n diff --git a/frontend/tests/hspec/Data/Bifunctor/FoldableSpec.hs b/frontend/tests/hspec/Data/Bifunctor/FoldableSpec.hs index e6abb7499..74c9cab49 100644 --- a/frontend/tests/hspec/Data/Bifunctor/FoldableSpec.hs +++ b/frontend/tests/hspec/Data/Bifunctor/FoldableSpec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} +{-# options_ghc -Wno-missing-pattern-synonym-signatures #-} + module Data.Bifunctor.FoldableSpec where import Test.Hspec hiding (Spec) diff --git a/frontend/tests/hspec/Language/Granule/Checker/CheckerSpec.hs b/frontend/tests/hspec/Language/Granule/Checker/CheckerSpec.hs index 19f9c0ea0..479830dc1 100644 --- a/frontend/tests/hspec/Language/Granule/Checker/CheckerSpec.hs +++ b/frontend/tests/hspec/Language/Granule/Checker/CheckerSpec.hs @@ -1,20 +1,13 @@ -{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImplicitParams #-} module Language.Granule.Checker.CheckerSpec where -import Control.Exception (SomeException, try) -import Control.Monad (forM_, liftM2) -import Data.Maybe (fromJust, isJust) - -import System.FilePath.Find import Test.Hspec import Language.Granule.Checker.Checker -import Language.Granule.Checker.Constraints import Language.Granule.Checker.Predicates import Language.Granule.Checker.Monad -import Control.Monad.Trans.Maybe import Language.Granule.Syntax.Parser import Language.Granule.Syntax.Expr import Language.Granule.Syntax.Def @@ -23,59 +16,10 @@ import Language.Granule.Syntax.Span import Language.Granule.Syntax.Identifiers import Language.Granule.Syntax.Annotated import Language.Granule.Utils -import Language.Granule.TestUtils -import System.Directory (setCurrentDirectory) - -pathToExamples :: FilePath -pathToExamples = "examples" - -pathToRegressionTests :: FilePath -pathToRegressionTests = "frontend/tests/cases/positive" -pathToIlltyped :: FilePath -pathToIlltyped = "frontend/tests/cases/negative" - - -- files in these directories don't get checked -exclude :: FilePath -exclude = "" - -fileExtensions :: [String] -fileExtensions = [".gr"] -- todo: .md spec :: Spec -spec = do - runIO $ setCurrentDirectory "../" - -- Working directory must be root of project for StdLib - -- imports to work - - -- Integration tests based on the fixtures - let ?globals = defaultGlobals { suppressInfos = True } - srcFiles <- runIO exampleFiles - forM_ srcFiles $ \file -> - describe file $ it "should typecheck" $ do - let ?globals = ?globals { sourceFilePath = file } - parsed <- try $ readFile file >>= parseAndDoImportsAndFreshenDefs :: IO (Either SomeException _) - case parsed of - Left ex -> expectationFailure (show ex) -- parse error - Right ast -> do - result <- try (check ast) :: IO (Either SomeException _) - case result of - Left ex -> expectationFailure (show ex) -- an exception was thrown - Right checked -> checked `shouldSatisfy` isJust - -- Negative tests: things which should fail to check - srcFiles <- runIO illTypedFiles - forM_ srcFiles $ \file -> - describe file $ it "should not typecheck" $ do - let ?globals = ?globals { sourceFilePath = file, suppressErrors = True } - parsed <- try $ readFile file >>= parseAndDoImportsAndFreshenDefs :: IO (Either SomeException _) - case parsed of - Left ex -> expectationFailure (show ex) -- parse error - Right ast -> do - result <- try (check ast) :: IO (Either SomeException _) - case result of - Left ex -> expectationFailure (show ex) -- an exception was thrown - Right checked -> checked `shouldBe` Nothing - +spec = let ?globals = mempty in do let tyVarK = TyVar $ mkId "k" let varA = mkId "a" @@ -85,19 +29,19 @@ spec = do (c, pred) <- runCtxts joinCtxts [(varA, Discharged tyVarK (CSig (CNat 5) natInterval))] [(varA, Discharged tyVarK (cNatOrdered 10))] - c `shouldBe` [(varA, Discharged tyVarK (CVar (mkId "a")))] + c `shouldBe` [(varA, Discharged tyVarK (CVar (mkId "a.0")))] pred `shouldBe` - [Conj [Con (ApproximatedBy nullSpan (cNatOrdered 10) (CVar (mkId "a")) natInterval) - , Con (ApproximatedBy nullSpan (cNatOrdered 5) (CVar (mkId "a")) natInterval)]] + [Conj [Con (ApproximatedBy nullSpan (cNatOrdered 10) (CVar (mkId "a.0")) natInterval) + , Con (ApproximatedBy nullSpan (cNatOrdered 5) (CVar (mkId "a.0")) natInterval)]] it "join ctxts with discharged assumption in one" $ do (c, pred) <- runCtxts joinCtxts [(varA, Discharged (tyVarK) (cNatOrdered 5))] [] - c `shouldBe` [(varA, Discharged (tyVarK) (CVar (mkId "a")))] + c `shouldBe` [(varA, Discharged (tyVarK) (CVar (mkId "a.0")))] pred `shouldBe` - [Conj [Con (ApproximatedBy nullSpan (CZero natInterval) (CVar (mkId "a")) natInterval) - ,Con (ApproximatedBy nullSpan (cNatOrdered 5) (CVar (mkId "a")) natInterval)]] + [Conj [Con (ApproximatedBy nullSpan (CZero natInterval) (CVar (mkId "a.0")) natInterval) + ,Con (ApproximatedBy nullSpan (cNatOrdered 5) (CVar (mkId "a.0")) natInterval)]] describe "intersectCtxtsWithWeaken" $ do @@ -135,27 +79,27 @@ spec = do it "simple elaborator tests" $ do -- Simple definitions -- \x -> x + 1 - (AST _ (def1:_)) <- parseAndDoImportsAndFreshenDefs "foo : Int -> Int\nfoo x = x + 1" - (Just defElab, _) <- runChecker initState (runMaybeT $ checkDef [] def1) + (AST _ (def1:_) _) <- parseAndDoImportsAndFreshenDefs "foo : Int -> Int\nfoo x = x + 1" + (Right defElab, _) <- runChecker initState (checkDef [] def1) annotation (extractMainExpr defElab) `shouldBe` (TyCon $ mkId "Int") - +extractMainExpr :: Def v a -> Expr v a extractMainExpr (Def _ _ [(Equation _ _ _ e)] _) = e - -runCtxts f a b = - runChecker initState (runMaybeT (f nullSpan a b)) - >>= (\(x, state) -> return (fromJust x, predicateStack state)) - -exampleFiles = foldr1 (liftM2 (<>)) $ do - fileExtension <- fileExtensions - id [ find (fileName /=? exclude) (extension ==? fileExtension) pathToExamples - , find always (extension ==? fileExtension) (includePath defaultGlobals) - , find always (extension ==? fileExtension) pathToRegressionTests - ] -- `id` in order to indent list, otherwise it doesn't parse in `do` notation - +extractMainExpr _ = undefined + +runCtxts + :: (?globals::Globals) + => (Span -> a -> a -> Checker a) + -> a + -> a + -> IO (a, [Pred]) +runCtxts f a b = do + (Right res, state) <- runChecker initState (f nullSpan a b) + pure (res, predicateStack state) + +cNatOrdered :: Int -> Coeffect cNatOrdered x = CSig (CNat x) natInterval + +natInterval :: Type natInterval = TyApp (TyCon $ mkId "Interval") (TyCon $ mkId "Nat") -illTypedFiles = foldr1 (liftM2 (<>)) $ do - fileExtension <- fileExtensions - [ find always (extension ==? fileExtension) pathToIlltyped ] diff --git a/frontend/tests/hspec/Language/Granule/Checker/MonadSpec.hs b/frontend/tests/hspec/Language/Granule/Checker/MonadSpec.hs index 406031a2e..9df420776 100644 --- a/frontend/tests/hspec/Language/Granule/Checker/MonadSpec.hs +++ b/frontend/tests/hspec/Language/Granule/Checker/MonadSpec.hs @@ -7,47 +7,45 @@ import Language.Granule.Syntax.Type import Language.Granule.Checker.Monad import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Reader.Class import Data.Maybe (fromJust) import qualified Data.Map as M -import Language.Granule.Checker.Constraints import Language.Granule.Checker.Predicates import Language.Granule.Checker.LaTeX spec :: Spec spec = do -- Unit tests - localCheckingSpec + peekCheckerSpec -- describe "" $ it "" $ True `shouldBe` True + -- peekChecker :: Checker a -> Checker (CheckerResult a, Checker ()) -localCheckingSpec :: Spec -localCheckingSpec = do +peekCheckerSpec :: Spec +peekCheckerSpec = do describe "Unit tests on localised checking function" $ do it "Updates do not leak" $ do - (Just (out, local), state) <- localising + (Right (Right out, local), state) <- localising -- State hasn't been changed by the local context state `shouldBe` endStateExpectation - out `shouldBe` (Just "x10") - (_, localState) <- runChecker endStateExpectation (runMaybeT local) + out `shouldBe` "x10" + (_, localState) <- runChecker endStateExpectation local localState `shouldBe` (transformState endStateExpectation) where endStateExpectation = initState { uniqueVarIdCounterMap = M.insert "x" 10 (M.empty) } - localising = runChecker initState $ runMaybeT $ do + localising :: IO (CheckerResult (CheckerResult String, Checker ()), CheckerState) + localising = runChecker initState $ do state <- get put (state { uniqueVarIdCounterMap = M.insert "x" 10 (M.empty) }) - localChecking $ do + peekChecker $ do state <- get put (transformState state) return $ "x" <> show (fromJust $ M.lookup "x" (uniqueVarIdCounterMap state)) transformState st = st { uniqueVarIdCounterMap = M.insertWith (+) "x" 1 (uniqueVarIdCounterMap st) , tyVarContext = [(mkId "inner", (KType, ForallQ))] - , kVarContext = [(mkId "innerk", KType)] , deriv = Just $ Leaf "testing" , derivStack = [Leaf "unit test"] } diff --git a/frontend/tests/hspec/Language/Granule/Checker/SubstitutionsSpec.hs b/frontend/tests/hspec/Language/Granule/Checker/SubstitutionsSpec.hs index a86f68007..ca2269225 100644 --- a/frontend/tests/hspec/Language/Granule/Checker/SubstitutionsSpec.hs +++ b/frontend/tests/hspec/Language/Granule/Checker/SubstitutionsSpec.hs @@ -4,21 +4,20 @@ module Language.Granule.Checker.SubstitutionsSpec where import Language.Granule.Syntax.Type import Language.Granule.Syntax.Identifiers -import Language.Granule.TestUtils import Test.Hspec -import Language.Granule.Checker.Substitutions +import Language.Granule.Checker.Substitution +import Language.Granule.Checker.SubstitutionContexts import Language.Granule.Checker.Monad -import Control.Monad.Trans.Maybe import Language.Granule.Utils spec :: Spec spec = do describe "unification" $ it "unif test" $ do - let ?globals = defaultGlobals - Just us <- evalChecker initState $ runMaybeT $ + let ?globals = mempty{ globalsTesting = Just True } + Right us <- evalChecker initState $ unify (Box (CVar $ mkId "x") (TyCon $ mkId "Bool")) (Box (COne (TyCon $ mkId "Nat")) (TyVar $ mkId "a")) - us `shouldBe` (Just [(mkId "x", SubstC $ COne (TyCon $ mkId "Nat")) - , (mkId "a", SubstT $ TyCon $ mkId "Bool")]) + us `shouldBe` (Just [(mkId "a", SubstT $ TyCon $ mkId "Bool") + , (mkId "x", SubstC $ COne (TyCon $ mkId "Nat"))]) diff --git a/frontend/tests/hspec/Language/Granule/ContextSpec.hs b/frontend/tests/hspec/Language/Granule/ContextSpec.hs deleted file mode 100644 index a88108a1f..000000000 --- a/frontend/tests/hspec/Language/Granule/ContextSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Language.Granule.ContextSpec where - -import Test.Hspec hiding (Spec) -import qualified Test.Hspec as Test -import Test.QuickCheck -import Language.Granule.Context - -spec :: Test.Spec -spec = do - describe "key intersection properties" - $ it "" $ True `shouldBe` True --- $ it "is not commutative" --- $ property (\e1 e2 -> intersectCtxts e1 e2 /= intersectCtxts e2 e1) diff --git a/frontend/tests/hspec/Language/Granule/TestUtils.hs b/frontend/tests/hspec/Language/Granule/TestUtils.hs deleted file mode 100644 index d9c90a070..000000000 --- a/frontend/tests/hspec/Language/Granule/TestUtils.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Language.Granule.TestUtils where - -import Language.Granule.Utils (Globals(..)) diff --git a/interpreter/app/Language/Granule/Interpreter/Preprocess.hs b/interpreter/app/Language/Granule/Interpreter/Preprocess.hs deleted file mode 100644 index c5e04bf79..000000000 --- a/interpreter/app/Language/Granule/Interpreter/Preprocess.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Granule.Interpreter.Preprocess where - -import Control.Exception (SomeException, throwIO, try) -import Control.Monad (when) -import Data.List (intercalate) -import System.Directory (removeFile, renameFile) -import System.FilePath (splitFileName) -import System.IO (hClose, hPutStr, openTempFile) - -import Language.Granule.Syntax.Preprocessor.Ascii -import Language.Granule.Syntax.Preprocessor.Latex -import Language.Granule.Syntax.Preprocessor.Markdown - - --- | Preprocess the source file based on the file extension. -preprocess :: Bool -> Bool -> FilePath -> IO String -preprocess performAsciiToUnicodeOnFile keepOldFile file - = case lookup extension preprocessors of - Just (stripNonGranule, asciiToUnicode) -> do - src <- asciiToUnicode <$> readFile file - when performAsciiToUnicodeOnFile $ do - (tempFile, tempHd) <- uncurry openTempFile (splitFileName file) - try (hPutStr tempHd src) >>= \case - Right () -> do - hClose tempHd - when keepOldFile (renameFile file (file <> ".bak")) - renameFile tempFile file - Left (e :: SomeException) -> do - hClose tempHd - removeFile tempFile - throwIO e - return $ stripNonGranule src - Nothing -> error - $ "Unrecognised file extension: " - <> extension - <> ". Expected one of " - <> intercalate ", " (map fst preprocessors) - <> "." - where - extension = reverse . takeWhile (/= '.') . reverse $ file - - preprocessors = - [ ("gr", (id, unAscii)) - , ("md", (unMarkdown, processGranuleMarkdown unAscii id)) - , ("tex", (unLatex, processGranuleLatex unAscii id)) - , ("latex", (unLatex, processGranuleLatex unAscii id)) - ] diff --git a/interpreter/package.yaml b/interpreter/package.yaml index 7f29f8843..3c2730602 100644 --- a/interpreter/package.yaml +++ b/interpreter/package.yaml @@ -1,16 +1,42 @@ name: granule-interpreter -version: '0.7.2.0' +version: '0.7.4.1' synopsis: The Granule interpreter author: Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Preston Keel -copyright: 2018 authors +copyright: 2019 authors license: BSD3 github: dorchard/granule dependencies: - base >=4.10 && <5 +- directory +- extra +- filepath +- gitrev +- Glob +- granule-frontend +- mtl >=2.2.1 +- optparse-applicative +- text +default-extensions: +- LambdaCase +- RecordWildCards +- ImplicitParams +- ScopedTypeVariables +- OverloadedStrings + +ghc-options: +- -O0 +- -Wall +- -Werror +- -Wcompat +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wredundant-constraints +- -Wno-unused-matches +- -Wno-name-shadowing +- -Wno-type-defaults library: source-dirs: src - ghc-options: -O0 -W -Werror -Wno-unused-matches -Wwarn=incomplete-patterns # when: # - condition: flag(dev) # then: @@ -18,22 +44,26 @@ library: # else: # ghc-options: -O3 -w exposed-modules: - - Language.Granule.Eval - - Language.Granule.Desugar - dependencies: - - granule-frontend - - mtl >=2.2.1 - - text + - Language.Granule.Interpreter + - Language.Granule.Interpreter.Eval + - Language.Granule.Interpreter.Desugar executables: gr: - main: Language/Granule/Interpreter/Main.hs - source-dirs: app - ghc-options: -O0 -W -Werror -Wno-unused-matches + main: Language/Granule/Interpreter.hs + source-dirs: src + ghc-options: -main-is Language.Granule.Interpreter dependencies: - - directory - - filepath - - Glob - - granule-frontend - granule-interpreter - - optparse-applicative + +tests: + gr-golden: + main: Golden.hs + source-dirs: tests + dependencies: + - Diff + - granule-interpreter + - strict + - tasty + - tasty-golden + diff --git a/interpreter/src/Language/Granule/Eval.hs b/interpreter/src/Language/Granule/Eval.hs deleted file mode 100755 index 7616753b5..000000000 --- a/interpreter/src/Language/Granule/Eval.hs +++ /dev/null @@ -1,386 +0,0 @@ --- Granule interpreter -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -module Language.Granule.Eval where - -import Language.Granule.Desugar -import Language.Granule.Syntax.Def -import Language.Granule.Syntax.Expr -import Language.Granule.Syntax.Identifiers -import Language.Granule.Syntax.Pattern -import Language.Granule.Syntax.Pretty -import Language.Granule.Syntax.Span -import Language.Granule.Context -import Language.Granule.Utils - -import Data.Text (pack, unpack, append) -import qualified Data.Text.IO as Text -import Control.Monad (zipWithM) - -import qualified Control.Concurrent as C (forkIO) -import qualified Control.Concurrent.Chan as CC (newChan, writeChan, readChan, Chan) - -import System.IO (hFlush, stdout) -import qualified System.IO as SIO (Handle, hGetChar, hPutChar, hClose, openFile, IOMode, isEOF) - -type RValue = Value (Runtime ()) () -type RExpr = Expr (Runtime ()) () - --- | Runtime values only used in the interpreter -data Runtime a = - -- | Primitive functions (builtins) - Primitive ((Value (Runtime a) a) -> IO (Value (Runtime a) a)) - - -- | Primitive operations that also close over the context - | PrimitiveClosure (Ctxt (Value (Runtime a) a) -> (Value (Runtime a) a) -> IO (Value (Runtime a) a)) - - -- | File handler - | Handle SIO.Handle - - -- | Channels - | Chan (CC.Chan (Value (Runtime a) a)) - -instance Show (Runtime a) where - show (Chan _) = "Some channel" - show (Primitive _) = "Some primitive" - show (PrimitiveClosure _) = "Some primitive closure" - show (Handle _) = "Some handle" - -instance Show (Runtime a) => Pretty (Runtime a) where - prettyL _ = show - -evalBinOp :: String -> RValue -> RValue -> RValue -evalBinOp "+" (NumInt n1) (NumInt n2) = NumInt (n1 + n2) -evalBinOp "*" (NumInt n1) (NumInt n2) = NumInt (n1 * n2) -evalBinOp "-" (NumInt n1) (NumInt n2) = NumInt (n1 - n2) -evalBinOp "+" (NumFloat n1) (NumFloat n2) = NumFloat (n1 + n2) -evalBinOp "*" (NumFloat n1) (NumFloat n2) = NumFloat (n1 * n2) -evalBinOp "-" (NumFloat n1) (NumFloat n2) = NumFloat (n1 - n2) -evalBinOp "≡" (NumInt n) (NumInt m) = Constr () (mkId . show $ (n == m)) [] -evalBinOp "≤" (NumInt n) (NumInt m) = Constr () (mkId . show $ (n <= m)) [] -evalBinOp "<" (NumInt n) (NumInt m) = Constr () (mkId . show $ (n < m)) [] -evalBinOp "≥" (NumInt n) (NumInt m) = Constr () (mkId . show $ (n >= m)) [] -evalBinOp ">" (NumInt n) (NumInt m) = Constr () (mkId . show $ (n > m)) [] -evalBinOp "≡" (NumFloat n) (NumFloat m) = Constr () (mkId . show $ (n == m)) [] -evalBinOp "≤" (NumFloat n) (NumFloat m) = Constr () (mkId . show $ (n <= m)) [] -evalBinOp "<" (NumFloat n) (NumFloat m) = Constr () (mkId . show $ (n < m)) [] -evalBinOp ">" (NumFloat n) (NumFloat m) = Constr () (mkId . show $ (n > m)) [] -evalBinOp "≥" (NumFloat n) (NumFloat m) = Constr () (mkId . show $ (n >= m)) [] -evalBinOp op v1 v2 = error $ "Unknown operator " <> op - <> " on " <> show v1 <> " and " <> show v2 - --- Call-by-value big step semantics -evalIn :: (?globals :: Globals) => Ctxt RValue -> RExpr -> IO RValue - -evalIn _ (Val s _ (Var _ v)) | internalName v == "read" = do - putStr "> " - hFlush stdout - val <- Text.getLine - return $ Pure () (Val s () (StringLiteral val)) - -evalIn _ (Val s _ (Var _ v)) | internalName v == "readInt" = do - putStr "> " - hFlush stdout - val <- readLn - return $ Pure () (Val s () (NumInt val)) - -evalIn _ (Val _ _ (Abs _ p t e)) = return $ Abs () p t e - -evalIn ctxt (App s _ e1 e2) = do - v1 <- evalIn ctxt e1 - case v1 of - (Ext _ (Primitive k)) -> do - v2 <- evalIn ctxt e2 - k v2 - - Abs _ p _ e3 -> do - p <- pmatchTop ctxt [(p, e3)] e2 - case p of - Just (e3, bindings) -> evalIn ctxt (applyBindings bindings e3) - _ -> error $ "Runtime exception: Failed pattern match " <> pretty p <> " in application at " <> pretty s - - Constr _ c vs -> do - v2 <- evalIn ctxt e2 - return $ Constr () c (vs <> [v2]) - - _ -> error $ show v1 - -- _ -> error "Cannot apply value" - -evalIn ctxt (Binop _ _ op e1 e2) = do - v1 <- evalIn ctxt e1 - v2 <- evalIn ctxt e2 - return $ evalBinOp op v1 v2 - -evalIn ctxt (LetDiamond s _ p _ e1 e2) = do - v1 <- evalIn ctxt e1 - case v1 of - Pure _ e -> do - v1' <- evalIn ctxt e - p <- pmatch ctxt [(p, e2)] v1' - case p of - Just (e2, bindings) -> evalIn ctxt (applyBindings bindings e2) - Nothing -> error $ "Runtime exception: Failed pattern match " <> pretty p <> " in let at " <> pretty s - other -> fail $ "Runtime exception: Expecting a diamonad value bug got: " - <> prettyDebug other - -{- --- Hard-coded 'scale', removed for now - - -evalIn _ (Val _ (Var v)) | internalName v == "scale" = return - (Abs (PVar nullSpan $ mkId " x") Nothing (Val nullSpan - (Abs (PVar nullSpan $ mkId " y") Nothing ( - letBox nullSpan (PVar nullSpan $ mkId " ye") - (Val nullSpan (Var (mkId " y"))) - (Binop nullSpan - "*" (Val nullSpan (Var (mkId " x"))) (Val nullSpan (Var (mkId " ye")))))))) --} - -evalIn ctxt (Val _ _ (Var _ x)) = - case lookup x ctxt of - Just val@(Ext _ (PrimitiveClosure f)) -> return $ Ext () $ Primitive (f ctxt) - Just val -> return val - Nothing -> fail $ "Variable '" <> sourceName x <> "' is undefined in context." - -evalIn ctxt (Val s _ (Pure _ e)) = do - v <- evalIn ctxt e - return $ Pure () (Val s () v) - -evalIn _ (Val _ _ v) = return v - -evalIn ctxt (Case _ _ guardExpr cases) = do - p <- pmatchTop ctxt cases guardExpr - case p of - Just (ei, bindings) -> evalIn ctxt (applyBindings bindings ei) - Nothing -> - error $ "Incomplete pattern match:\n cases: " - <> pretty cases <> "\n expr: " <> pretty guardExpr - -applyBindings :: Ctxt RExpr -> RExpr -> RExpr -applyBindings [] e = e -applyBindings ((var, e'):bs) e = applyBindings bs (subst e' var e) - -{-| Start pattern matching here passing in a context of values - a list of cases (pattern-expression pairs) and the guard expression. - If there is a matching pattern p_i then return Just of the branch - expression e_i and a list of bindings in scope -} -pmatchTop :: - (?globals :: Globals) - => Ctxt RValue - -> [(Pattern (), RExpr)] - -> RExpr - -> IO (Maybe (RExpr, Ctxt RExpr)) - -pmatchTop ctxt ((PBox _ _ (PVar _ _ var), branchExpr):_) guardExpr = do - Promote _ e <- evalIn ctxt guardExpr - return (Just (subst e var branchExpr, [])) - -pmatchTop ctxt ((PBox _ _ (PWild _ _), branchExpr):_) guardExpr = do - Promote _ _ <- evalIn ctxt guardExpr - return (Just (branchExpr, [])) - -pmatchTop ctxt ps guardExpr = do - val <- evalIn ctxt guardExpr - pmatch ctxt ps val - -pmatch :: - (?globals :: Globals) - => Ctxt RValue - -> [(Pattern (), RExpr)] - -> RValue - -> IO (Maybe (RExpr, Ctxt RExpr)) -pmatch _ [] _ = - return Nothing - -pmatch _ ((PWild _ _, e):_) _ = - return $ Just (e, []) - -pmatch ctxt ((PConstr _ _ s innerPs, e):ps) (Constr _ s' vs) | s == s' = do - matches <- zipWithM (\p v -> pmatch ctxt [(p, e)] v) innerPs vs - case sequence matches of - Just ebindings -> return $ Just (e, concat $ map snd ebindings) - Nothing -> pmatch ctxt ps (Constr () s' vs) - -pmatch _ ((PVar _ _ var, e):_) val = - return $ Just (e, [(var, Val nullSpan () val)]) - -pmatch ctxt ((PBox _ _ p, e):ps) (Promote _ e') = do - v <- evalIn ctxt e' - match <- pmatch ctxt [(p, e)] v - case match of - Just (_, bindings) -> return $ Just (e, bindings) - Nothing -> pmatch ctxt ps (Promote () e') - -pmatch _ ((PInt _ _ n, e):_) (NumInt m) | n == m = - return $ Just (e, []) - -pmatch _ ((PFloat _ _ n, e):_) (NumFloat m) | n == m = - return $ Just (e, []) - -pmatch ctxt (_:ps) val = pmatch ctxt ps val - -valExpr = Val nullSpanNoFile () - -builtIns :: (?globals :: Globals) => Ctxt RValue -builtIns = - [ - (mkId "div", Ext () $ Primitive $ \(NumInt n1) - -> return $ Ext () $ Primitive $ \(NumInt n2) -> - return $ NumInt (n1 `div` n2)) - , (mkId "pure", Ext () $ Primitive $ \v -> return $ Pure () (Val nullSpan () v)) - , (mkId "intToFloat", Ext () $ Primitive $ \(NumInt n) -> return $ NumFloat (cast n)) - , (mkId "showInt", Ext () $ Primitive $ \n -> case n of - NumInt n -> return . StringLiteral . pack . show $ n - n -> error $ show n) - , (mkId "write", Ext () $ Primitive $ \(StringLiteral s) -> do - Text.putStrLn s - return $ Pure () (Val nullSpan () (Constr () (mkId "()") []))) - , (mkId "openFile", Ext () $ Primitive openFile) - , (mkId "hGetChar", Ext () $ Primitive hGetChar) - , (mkId "hPutChar", Ext () $ Primitive hPutChar) - , (mkId "hClose", Ext () $ Primitive hClose) - , (mkId "showChar", - Ext () $ Primitive $ \(CharLiteral c) -> return $ StringLiteral $ pack [c]) - , (mkId "stringAppend", - Ext () $ Primitive $ \(StringLiteral s) -> return $ - Ext () $ Primitive $ \(StringLiteral t) -> return $ StringLiteral $ s `append` t) - , (mkId "isEOF", Ext () $ Primitive $ \(Ext _ (Handle h)) -> do - b <- SIO.isEOF - let boolflag = - case b of - True -> Constr () (mkId "True") [] - False -> Constr () (mkId "False") [] - return . (Pure ()) . Val nullSpan () $ Constr () (mkId ",") [Ext () $ Handle h, boolflag]) - , (mkId "fork", Ext () $ PrimitiveClosure fork) - , (mkId "forkRep", Ext () $ PrimitiveClosure forkRep) - , (mkId "recv", Ext () $ Primitive recv) - , (mkId "send", Ext () $ Primitive send) - , (mkId "close", Ext () $ Primitive close) - ] - where - fork :: (?globals :: Globals) => Ctxt RValue -> RValue -> IO RValue - fork ctxt e@Abs{} = do - c <- CC.newChan - C.forkIO $ - evalIn ctxt (App nullSpan () (valExpr e) (valExpr $ Ext () $ Chan c)) >> return () - return $ Pure () $ valExpr $ Ext () $ Chan c - fork ctxt e = error $ "Bug in Granule. Trying to fork: " <> prettyDebug e - - forkRep :: (?globals :: Globals) => Ctxt RValue -> RValue -> IO RValue - forkRep ctxt e@Abs{} = do - c <- CC.newChan - C.forkIO $ - evalIn ctxt (App nullSpan () - (valExpr e) - (valExpr $ Promote () $ valExpr $ Ext () $ Chan c)) >> return () - return $ Pure () $ valExpr $ Promote () $ valExpr $ Ext () $ Chan c - forkRep ctxt e = error $ "Bug in Granule. Trying to fork: " <> prettyDebug e - - recv :: (?globals :: Globals) => RValue -> IO RValue - recv (Ext _ (Chan c)) = do - x <- CC.readChan c - return $ Pure () $ valExpr $ Constr () (mkId ",") [x, Ext () $ Chan c] - recv e = error $ "Bug in Granule. Trying to recevie from: " <> prettyDebug e - - send :: (?globals :: Globals) => RValue -> IO RValue - send (Ext _ (Chan c)) = return $ Ext () $ Primitive - (\v -> do - CC.writeChan c v - return $ Pure () $ valExpr $ Ext () $ Chan c) - send e = error $ "Bug in Granule. Trying to send from: " <> prettyDebug e - - close :: RValue -> IO RValue - close (Ext _ (Chan c)) = return $ Pure () $ valExpr $ Constr () (mkId "()") [] - close rval = error $ "Runtime exception: trying to close a value which is not a channel" - - cast :: Int -> Double - cast = fromInteger . toInteger - - openFile :: RValue -> IO RValue - openFile (StringLiteral s) = return $ - Ext () $ Primitive (\x -> - case x of - (Constr _ m []) -> do - let mode = (read (internalName m)) :: SIO.IOMode - h <- SIO.openFile (unpack s) mode - return $ Pure () $ valExpr $ Ext () $ Handle h - rval -> error $ "Runtime exception: trying to open with a non-mode value") - openFile _ = error $ "Runtime exception: trying to open from a non string filename" - - hPutChar :: RValue -> IO RValue - hPutChar (Ext _ (Handle h)) = return $ - Ext () $ Primitive (\c -> - case c of - (CharLiteral c) -> do - SIO.hPutChar h c - return $ Pure () $ valExpr $ Ext () $ Handle h - _ -> error $ "Runtime exception: trying to put a non character value") - hPutChar _ = error $ "Runtime exception: trying to put from a non handle value" - - hGetChar :: RValue -> IO RValue - hGetChar (Ext _ (Handle h)) = do - c <- SIO.hGetChar h - return $ Pure () $ valExpr (Constr () (mkId ",") [Ext () $ Handle h, CharLiteral c]) - hGetChar _ = error $ "Runtime exception: trying to get from a non handle value" - - hClose :: RValue -> IO RValue - hClose (Ext _ (Handle h)) = do - SIO.hClose h - return $ Pure () $ valExpr (Constr () (mkId "()") []) - hClose _ = error $ "Runtime exception: trying to close a non handle value" - -evalDefs :: (?globals :: Globals) => Ctxt RValue -> [Def (Runtime ()) ()] -> IO (Ctxt RValue) -evalDefs ctxt [] = return ctxt -evalDefs ctxt (Def _ var [Equation _ _ [] e] _ : defs) = do - val <- evalIn ctxt e - case extend ctxt var val of - Some ctxt -> evalDefs ctxt defs - None msgs -> error $ unlines msgs -evalDefs ctxt (d : defs) = do - let d' = desugar d - evalDefs ctxt (d' : defs) - --- Maps an AST from the parser into the interpreter version with runtime values -class RuntimeRep t where - toRuntimeRep :: t () () -> t (Runtime ()) () - -instance RuntimeRep Def where - toRuntimeRep (Def s i eqs tys) = Def s i (map toRuntimeRep eqs) tys - -instance RuntimeRep Equation where - toRuntimeRep (Equation s a ps e) = Equation s a ps (toRuntimeRep e) - -instance RuntimeRep Expr where - toRuntimeRep (Val s a v) = Val s a (toRuntimeRep v) - toRuntimeRep (App s a e1 e2) = App s a (toRuntimeRep e1) (toRuntimeRep e2) - toRuntimeRep (Binop s a o e1 e2) = Binop s a o (toRuntimeRep e1) (toRuntimeRep e2) - toRuntimeRep (LetDiamond s a p t e1 e2) = LetDiamond s a p t (toRuntimeRep e1) (toRuntimeRep e2) - toRuntimeRep (Case s a e ps) = Case s a (toRuntimeRep e) (map (\(p, e) -> (p, toRuntimeRep e)) ps) - -instance RuntimeRep Value where - toRuntimeRep (Ext a ()) = error "Bug: Parser generated an extended value case when it shouldn't have" - toRuntimeRep (Abs a p t e) = Abs a p t (toRuntimeRep e) - toRuntimeRep (Promote a e) = Promote a (toRuntimeRep e) - toRuntimeRep (Pure a e) = Pure a (toRuntimeRep e) - toRuntimeRep (Constr a i vs) = Constr a i (map toRuntimeRep vs) - -- identity cases - toRuntimeRep (CharLiteral c) = CharLiteral c - toRuntimeRep (StringLiteral c) = StringLiteral c - toRuntimeRep (Var a x) = Var a x - toRuntimeRep (NumInt x) = NumInt x - toRuntimeRep (NumFloat x) = NumFloat x - -eval :: (?globals :: Globals) => AST () () -> IO (Maybe RValue) -eval (AST dataDecls defs) = do - bindings <- evalDefs builtIns (map toRuntimeRep defs) - case lookup (mkId "main") bindings of - Nothing -> return Nothing - -- Evaluate inside a promotion of pure if its at the top-level - Just (Pure _ e) -> fmap Just (evalIn bindings e) - Just (Promote _ e) -> fmap Just (evalIn bindings e) - -- ... or a regular value came out of the interpreter - Just val -> return $ Just val diff --git a/interpreter/src/Language/Granule/Interpreter.hs b/interpreter/src/Language/Granule/Interpreter.hs new file mode 100755 index 000000000..cae0bd9fc --- /dev/null +++ b/interpreter/src/Language/Granule/Interpreter.hs @@ -0,0 +1,373 @@ +{- ___ + /\_ \ + __ _ _ __ ___ __ __\//\ \ __ + / _ \/\`'__\/ __ \ /' _ `\/\ \/\ \ \ \ \ /'__`\ + /\ \_\ \ \ \//\ \_\ \_/\ \/\ \ \ \_\ \ \_\ \_/\ __/ + \ \____ \ \_\\ \__/ \_\ \_\ \_\ \____/ /\____\ \____\ + \/___L\ \/_/ \/__/\/_/\/_/\/_/\/___/ \/____/\/____/ + /\____/ + \_/__/ +-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Granule.Interpreter where + +import Control.Exception (SomeException, displayException, try) +import Control.Monad ((<=<), forM) +import Development.GitRev +import Data.Char (isSpace) +import Data.Either (isRight) +import Data.List (intercalate, isPrefixOf, stripPrefix) +import Data.List.Extra (breakOn) +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (fromMaybe) +import Data.Semigroup ((<>)) +import Data.Version (showVersion) +import System.Exit + +import System.Directory (getAppUserDataDirectory, getCurrentDirectory) +import System.FilePath (takeFileName) +import "Glob" System.FilePath.Glob (glob) +import Options.Applicative +import Options.Applicative.Help.Pretty (string) + +import Language.Granule.Checker.Checker +import Language.Granule.Checker.Monad (CheckerError) +import Language.Granule.Interpreter.Eval +import Language.Granule.Interpreter.Preprocess +import Language.Granule.Syntax.Parser +import Language.Granule.Syntax.Preprocessor.Ascii +import Language.Granule.Syntax.Pretty +import Language.Granule.Utils +import Paths_granule_interpreter (version) + +main :: IO () +main = do + (globPatterns, config) <- getGrConfig + if null globPatterns + then runGrOnStdIn config + else runGrOnFiles globPatterns config + +-- | Run the checker and interpreter on a bunch of files +runGrOnFiles :: [FilePath] -> GrConfig -> IO () +runGrOnFiles globPatterns config = let ?globals = grGlobals config in do + pwd <- getCurrentDirectory + results <- forM globPatterns $ \pattern -> do + paths <- glob pattern + case paths of + [] -> do + let result = Left $ NoMatchingFiles pattern + printResult result + return [result] + _ -> forM paths $ \path -> do + let fileName = if pwd `isPrefixOf` path then takeFileName path else path + let ?globals = ?globals{ globalsSourceFilePath = Just fileName } in do + printInfo $ "Checking " <> fileName <> "..." + src <- preprocess + (rewriter config) + (keepBackup config) + path + (literateEnvName config) + result <- run src + printResult result + return result + if all isRight (concat results) then exitSuccess else exitFailure + +runGrOnStdIn :: GrConfig -> IO () +runGrOnStdIn GrConfig{..} + = let ?globals = grGlobals{ globalsSourceFilePath = Just "stdin" } in do + printInfo "Reading from stdin: confirm input with `enter+ctrl-d` or exit with `ctrl-c`" + debugM "Globals" (show ?globals) + result <- getContents >>= run + printResult result + if isRight result then exitSuccess else exitFailure + +-- print the result of running the checker and interpreter +printResult + :: (?globals :: Globals) + => Either InterpreterError InterpreterResult + -> IO () +printResult = \case + Left err -> printError err + Right (InterpreterResult val) -> putStrLn $ pretty val + Right NoEval -> pure () + +{-| Run the input through the type checker and evaluate. +-} +run + :: (?globals :: Globals) + => String + -> IO (Either InterpreterError InterpreterResult) +run input = let ?globals = fromMaybe mempty (grGlobals <$> getEmbeddedGrFlags input) <> ?globals in do + result <- try $ parseAndDoImportsAndFreshenDefs input + case result of + Left (e :: SomeException) -> return . Left . ParseError $ show e + Right ast -> do + -- Print to terminal when in debugging mode: + debugM "Pretty-printed AST:" $ pretty ast + debugM "Raw AST:" $ show ast + -- Check and evaluate + checked <- try $ check ast + case checked of + Left (e :: SomeException) -> return . Left . FatalError $ displayException e + Right (Left errs) -> return . Left $ CheckerError errs + Right (Right ast') -> do + if noEval then do + printSuccess "OK" + return $ Right NoEval + else do + printSuccess "OK, evaluating..." + result <- try $ eval ast + case result of + Left (e :: SomeException) -> + return . Left . EvalError $ displayException e + Right Nothing -> if testing + then return $ Right NoEval + else return $ Left NoEntryPoint + Right (Just result) -> do + return . Right $ InterpreterResult result + + +-- | Get the flags embedded in the first line of a file, e.g. +-- "-- gr --no-eval" +getEmbeddedGrFlags :: String -> Maybe GrConfig +getEmbeddedGrFlags + = foldr (<|>) Nothing + . map getEmbeddedGrFlagsLine + . take 3 -- only check for flags within the top 3 lines (so they are visible and at the top) + . lines + where + getEmbeddedGrFlagsLine + = parseGrFlags . dropWhile isSpace + <=< stripPrefix "gr" . dropWhile isSpace + <=< stripPrefix "--" . dropWhile isSpace + + +parseGrFlags :: String -> Maybe GrConfig +parseGrFlags + = pure . snd + <=< getParseResult . execParserPure (prefs disambiguate) parseGrConfig . words + + +data GrConfig = GrConfig + { grRewriter :: Maybe (String -> String) + , grKeepBackup :: Maybe Bool + , grLiterateEnvName :: Maybe String + , grGlobals :: Globals + } + +rewriter :: GrConfig -> Maybe (String -> String) +rewriter c = grRewriter c <|> Nothing + +keepBackup :: GrConfig -> Bool +keepBackup = fromMaybe False . grKeepBackup + +literateEnvName :: GrConfig -> String +literateEnvName = fromMaybe "granule" . grLiterateEnvName + +instance Semigroup GrConfig where + c1 <> c2 = GrConfig + { grRewriter = grRewriter c1 <|> grRewriter c2 + , grKeepBackup = grKeepBackup c1 <|> grKeepBackup c2 + , grLiterateEnvName = grLiterateEnvName c1 <|> grLiterateEnvName c2 + , grGlobals = grGlobals c1 <> grGlobals c2 + } + +instance Monoid GrConfig where + mempty = GrConfig + { grRewriter = Nothing + , grKeepBackup = Nothing + , grLiterateEnvName = Nothing + , grGlobals = mempty + } + +getGrConfig :: IO ([FilePath], GrConfig) +getGrConfig = do + (globPatterns, configCLI) <- getGrCommandLineArgs + configHome <- readUserConfig (grGlobals configCLI) + pure (globPatterns, configCLI <> configHome) + where + -- TODO: UNIX specific + readUserConfig :: Globals -> IO GrConfig + readUserConfig globals = do + let ?globals = globals + try (getAppUserDataDirectory "granule") >>= \case + Left (e :: SomeException) -> do + debugM "Read user config" $ show e + pure mempty + Right configFile -> + try (parseGrFlags <$> readFile configFile) >>= \case + Left (e :: SomeException) -> do + debugM "Read user config" $ show e + pure mempty + Right Nothing -> do + printInfo . red . unlines $ + [ "Couldn't parse granule configuration file at " <> configFile + , "Run `gr --help` to see a list of accepted flags." + ] + pure mempty + Right (Just config) -> pure config + + +getGrCommandLineArgs :: IO ([FilePath], GrConfig) +getGrCommandLineArgs = customExecParser (prefs disambiguate) parseGrConfig + +parseGrConfig :: ParserInfo ([FilePath], GrConfig) +parseGrConfig = info (go <**> helper) $ briefDesc + <> (headerDoc . Just . string . unlines) + [ "The Granule Interpreter" + , "version: " <> showVersion version + , "branch: " <> $(gitBranch) + , "commit hash: " <> $(gitHash) + , "commit date: " <> $(gitCommitDate) + , if $(gitDirty) then "(uncommitted files present)" else "" + ] + <> footer "This software is provided under a BSD3 license and comes with NO WARRANTY WHATSOEVER.\ + \ Consult the LICENSE for further information." + where + go = do + globPatterns <- + many $ argument str $ metavar "GLOB_PATTERNS" <> action "file" + <> (help . unwords) + [ "Glob pattern for Granule source files. If the file extension is `.md`/`.tex`, the markdown/TeX preprocessor will be used." + , "If none are given, input will be read from stdin." + ] + + globalsDebugging <- + flag Nothing (Just True) + $ long "debug" + <> help "Debug mode" + + globalsSuppressInfos <- + flag Nothing (Just True) + $ long "no-info" + <> help "Don't output info messages" + + globalsSuppressErrors <- + flag Nothing (Just True) + $ long "no-error" + <> help "Don't output error messages" + + globalsNoColors <- + flag Nothing (Just True) + $ long "no-color" + <> long "no-colour" + <> help "Turn off colors in terminal output" + + globalsAlternativeColors <- + flag Nothing (Just True) + $ long "alternative-colors" + <> long "alternative-colours" + <> help "Print success messages in blue instead of green (may help with color blindness)" + + globalsNoEval <- + flag Nothing (Just True) + $ long "no-eval" + <> help "Don't evaluate, only type-check" + + globalsTimestamp <- + flag Nothing (Just True) + $ long "timestamp" + <> help "Print timestamp in info and error messages" + + globalsSolverTimeoutMillis <- + (optional . option (auto @Integer)) + $ long "solver-timeout" + <> (help . unwords) + [ "SMT solver timeout in milliseconds (negative for unlimited)" + , "Defaults to" + , show solverTimeoutMillis <> "ms." + ] + + globalsIncludePath <- + optional $ strOption + $ long "include-path" + <> help ("Path to the standard library. Defaults to " + <> show includePath) + <> metavar "PATH" + + globalsEntryPoint <- + optional $ strOption + $ long "entry-point" + <> help ("Program entry point. Defaults to " <> show entryPoint) + <> metavar "ID" + + grRewriter + <- flag' + (Just asciiToUnicode) + (long "ascii-to-unicode" <> help "WARNING: Destructively overwrite ascii characters to multi-byte unicode.") + <|> flag Nothing + (Just unicodeToAscii) + (long "unicode-to-ascii" <> help "WARNING: Destructively overwrite multi-byte unicode to ascii.") + + grKeepBackup <- + flag Nothing (Just True) + $ long "keep-backup" + <> help "Keep a backup copy of the input file (only has an effect when destructively preprocessing.)" + + grLiterateEnvName <- + optional $ strOption + $ long "literate-env-name" + <> help ("Name of the code environment to check in literate files. Defaults to " + <> show (literateEnvName mempty)) + + pure + ( globPatterns + , GrConfig + { grRewriter + , grKeepBackup + , grLiterateEnvName + , grGlobals = Globals + { globalsDebugging + , globalsNoColors + , globalsAlternativeColors + , globalsNoEval + , globalsSuppressInfos + , globalsSuppressErrors + , globalsTimestamp + , globalsTesting = Nothing + , globalsSolverTimeoutMillis + , globalsIncludePath + , globalsSourceFilePath = Nothing + , globalsEntryPoint + } + } + ) + where + ?globals = mempty @Globals + +data InterpreterError + = ParseError String + | CheckerError (NonEmpty CheckerError) + | EvalError String + | FatalError String + | NoEntryPoint + | NoMatchingFiles String + deriving Show + +data InterpreterResult + = NoEval + | InterpreterResult RValue + deriving Show + +instance UserMsg InterpreterError where + title ParseError {} = "Parse error" + title CheckerError {} = "Type checking failed" + title EvalError {} = "Error during evaluation" + title FatalError{} = "Fatal error" + title NoEntryPoint{} = "No program entry point" + title NoMatchingFiles{} = "User error" + + msg (ParseError m) = fst . breakOn "CallStack (from HasCallStack):" $ m -- TODO + msg (CheckerError ms) = intercalate "\n\n" . map formatError . toList $ ms + msg (EvalError m) = m + msg (FatalError m) = m + msg NoEntryPoint = "Program entry point `" <> entryPoint <> "` not found. A different one can be specified with `--entry-point`." + msg (NoMatchingFiles p) = "The glob pattern `" <> p <> "` did not match any files." \ No newline at end of file diff --git a/interpreter/src/Language/Granule/Desugar.hs b/interpreter/src/Language/Granule/Interpreter/Desugar.hs similarity index 96% rename from interpreter/src/Language/Granule/Desugar.hs rename to interpreter/src/Language/Granule/Interpreter/Desugar.hs index 3d325b65a..378397b86 100644 --- a/interpreter/src/Language/Granule/Desugar.hs +++ b/interpreter/src/Language/Granule/Interpreter/Desugar.hs @@ -1,6 +1,6 @@ -- Provides the desugaring step of the language -module Language.Granule.Desugar where +module Language.Granule.Interpreter.Desugar where import Language.Granule.Syntax.Def import Language.Granule.Syntax.Expr @@ -25,7 +25,7 @@ import Control.Monad.State.Strict Note that the explicit typing from the type signature is pushed inside of the definition to give an explicit typing on the coeffect-let binding. -} -desugar :: Show v => Def v () -> Def v () +desugar :: Def v () -> Def v () -- desugar adt@ADT{} = adt desugar (Def s var eqs tys@(Forall _ _ _ ty)) = Def s var [typeDirectedDesugarEquation (mkSingleEquation eqs)] tys diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs new file mode 100755 index 000000000..1edb0f7ce --- /dev/null +++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs @@ -0,0 +1,460 @@ +-- Granule interpreter +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} + + +{-# options_ghc -Wno-incomplete-uni-patterns #-} + +module Language.Granule.Interpreter.Eval where + +import Language.Granule.Interpreter.Desugar +import Language.Granule.Syntax.Def +import Language.Granule.Syntax.Expr +import Language.Granule.Syntax.Identifiers +import Language.Granule.Syntax.Pattern +import Language.Granule.Syntax.Pretty +import Language.Granule.Syntax.Span +import Language.Granule.Context +import Language.Granule.Utils + +import Data.Text (cons, pack, uncons, unpack, snoc, unsnoc) +import qualified Data.Text.IO as Text +import Control.Monad (when, foldM) + +import qualified Control.Concurrent as C (forkIO) +import qualified Control.Concurrent.Chan as CC (newChan, writeChan, readChan, Chan) + +import System.IO (hFlush, stdout, stderr) +import qualified System.IO as SIO + +type RValue = Value (Runtime ()) () +type RExpr = Expr (Runtime ()) () + +-- | Runtime values only used in the interpreter +data Runtime a = + -- | Primitive functions (builtins) + Primitive ((Value (Runtime a) a) -> Value (Runtime a) a) + + -- | Primitive operations that also close over the context + | PrimitiveClosure (Ctxt (Value (Runtime a) a) -> (Value (Runtime a) a) -> (Value (Runtime a) a)) + + -- | File handler + | Handle SIO.Handle + + -- | Channels + | Chan (CC.Chan (Value (Runtime a) a)) + + -- | Delayed side effects wrapper + | PureWrapper (IO (Expr (Runtime a) ())) + +diamondConstr :: IO (Expr (Runtime ()) ()) -> RValue +diamondConstr = Ext () . PureWrapper + +isDiaConstr :: RValue -> Maybe (IO (Expr (Runtime ()) ())) +isDiaConstr (Pure _ e) = Just $ return e +isDiaConstr (Ext _ (PureWrapper e)) = Just e +isDiaConstr _ = Nothing + +instance Show (Runtime a) where + show (Chan _) = "Some channel" + show (Primitive _) = "Some primitive" + show (PrimitiveClosure _) = "Some primitive closure" + show (Handle _) = "Some handle" + show (PureWrapper _) = "" + +instance Pretty (Runtime a) where + prettyL _ = show + +evalBinOp :: Operator -> RValue -> RValue -> RValue +evalBinOp op v1 v2 = case op of + OpPlus -> case (v1, v2) of + (NumInt n1, NumInt n2) -> NumInt (n1 + n2) + (NumFloat n1, NumFloat n2) -> NumFloat (n1 + n2) + _ -> evalFail + OpTimes -> case (v1, v2) of + (NumInt n1, NumInt n2) -> NumInt (n1 * n2) + (NumFloat n1, NumFloat n2) -> NumFloat (n1 * n2) + _ -> evalFail + OpMinus -> case (v1, v2) of + (NumInt n1, NumInt n2) -> NumInt (n1 - n2) + (NumFloat n1, NumFloat n2) -> NumFloat (n1 - n2) + _ -> evalFail + OpEq -> case (v1, v2) of + (NumInt n1, NumInt n2) -> Constr () (mkId . show $ (n1 == n2)) [] + (NumFloat n1, NumFloat n2) -> Constr () (mkId . show $ (n1 == n2)) [] + _ -> evalFail + OpNotEq -> case (v1, v2) of + (NumInt n1, NumInt n2) -> Constr () (mkId . show $ (n1 /= n2)) [] + (NumFloat n1, NumFloat n2) -> Constr () (mkId . show $ (n1 /= n2)) [] + _ -> evalFail + OpLesserEq -> case (v1, v2) of + (NumInt n1, NumInt n2) -> Constr () (mkId . show $ (n1 <= n2)) [] + (NumFloat n1, NumFloat n2) -> Constr () (mkId . show $ (n1 <= n2)) [] + _ -> evalFail + OpLesser -> case (v1, v2) of + (NumInt n1, NumInt n2) -> Constr () (mkId . show $ (n1 < n2)) [] + (NumFloat n1, NumFloat n2) -> Constr () (mkId . show $ (n1 < n2)) [] + _ -> evalFail + OpGreaterEq -> case (v1, v2) of + (NumInt n1, NumInt n2) -> Constr () (mkId . show $ (n1 >= n2)) [] + (NumFloat n1, NumFloat n2) -> Constr () (mkId . show $ (n1 >= n2)) [] + _ -> evalFail + OpGreater -> case (v1, v2) of + (NumInt n1, NumInt n2) -> Constr () (mkId . show $ (n1 > n2)) [] + (NumFloat n1, NumFloat n2) -> Constr () (mkId . show $ (n1 > n2)) [] + _ -> evalFail + where + evalFail = error $ show [show op, show v1, show v2] + +-- Call-by-value big step semantics +evalIn :: (?globals :: Globals) => Ctxt RValue -> RExpr -> IO RValue +evalIn ctxt (App s _ e1 e2) = do + -- (cf. APP_L) + v1 <- evalIn ctxt e1 + case v1 of + (Ext _ (Primitive k)) -> do + -- (cf. APP_R) + v2 <- evalIn ctxt e2 + return $ k v2 + + Abs _ p _ e3 -> do + -- (cf. APP_R) + v2 <- evalIn ctxt e2 + -- (cf. P_BETA) + pResult <- pmatch ctxt [(p, e3)] v2 + case pResult of + Just e3' -> evalIn ctxt e3' + _ -> error $ "Runtime exception: Failed pattern match " <> pretty p <> " in application at " <> pretty s + + Constr _ c vs -> do + -- (cf. APP_R) + v2 <- evalIn ctxt e2 + return $ Constr () c (vs <> [v2]) + + _ -> error $ show v1 + -- _ -> error "Cannot apply value" + +evalIn ctxt (Binop _ _ op e1 e2) = do + v1 <- evalIn ctxt e1 + v2 <- evalIn ctxt e2 + return $ evalBinOp op v1 v2 + +evalIn ctxt (LetDiamond s _ p _ e1 e2) = do + -- (cf. LET_1) + v1 <- evalIn ctxt e1 + case v1 of + (isDiaConstr -> Just e) -> do + -- Do the delayed side effect + eInner <- e + -- (cf. LET_2) + v1' <- evalIn ctxt eInner + -- (cf. LET_BETA) + pResult <- pmatch ctxt [(p, e2)] v1' + case pResult of + Just e2' -> evalIn ctxt e2' + Nothing -> error $ "Runtime exception: Failed pattern match " <> pretty p <> " in let at " <> pretty s + + other -> fail $ "Runtime exception: Expecting a diamonad value but got: " + <> prettyDebug other + +{- +-- Hard-coded 'scale', removed for now +evalIn _ (Val _ (Var v)) | internalName v == "scale" = return + (Abs (PVar nullSpan $ mkId " x") Nothing (Val nullSpan + (Abs (PVar nullSpan $ mkId " y") Nothing ( + letBox nullSpan (PVar nullSpan $ mkId " ye") + (Val nullSpan (Var (mkId " y"))) + (Binop nullSpan + "*" (Val nullSpan (Var (mkId " x"))) (Val nullSpan (Var (mkId " ye")))))))) +-} + +evalIn ctxt (Val _ _ (Var _ x)) = + case lookup x ctxt of + Just val@(Ext _ (PrimitiveClosure f)) -> return $ Ext () $ Primitive (f ctxt) + Just val -> return val + Nothing -> fail $ "Variable '" <> sourceName x <> "' is undefined in context." + +evalIn ctxt (Val s _ (Promote _ e)) = do + -- (cf. Box) + v <- evalIn ctxt e + return $ Promote () (Val s () v) + +evalIn _ (Val _ _ v) = return v + +evalIn ctxt (Case _ _ guardExpr cases) = do + v <- evalIn ctxt guardExpr + p <- pmatch ctxt cases v + case p of + Just ei -> evalIn ctxt ei + Nothing -> + error $ "Incomplete pattern match:\n cases: " + <> pretty cases <> "\n expr: " <> pretty v + +applyBindings :: Ctxt RExpr -> RExpr -> RExpr +applyBindings [] e = e +applyBindings ((var, e'):bs) e = applyBindings bs (subst e' var e) + +{-| Start pattern matching here passing in a context of values + a list of cases (pattern-expression pairs) and the guard expression. + If there is a matching pattern p_i then return Just of the branch + expression e_i and a list of bindings in scope -} +pmatch :: + (?globals :: Globals) + => Ctxt RValue + -> [(Pattern (), RExpr)] + -> RValue + -> IO (Maybe RExpr) +pmatch _ [] _ = + return Nothing + +pmatch _ ((PWild _ _, e):_) _ = + return $ Just e + +pmatch ctxt ((PConstr _ _ id innerPs, t0):ps) v@(Constr _ id' vs) + | id == id' && length innerPs == length vs = do + + -- Fold over the inner patterns + tLastM <- foldM (\tiM (pi, vi) -> case tiM of + Nothing -> return Nothing + Just ti -> pmatch ctxt [(pi, ti)] vi) (Just t0) (zip innerPs vs) + + case tLastM of + Just tLast -> return $ Just tLast + -- There was a failure somewhere + Nothing -> pmatch ctxt ps v + +pmatch _ ((PVar _ _ var, e):_) v = + return $ Just $ subst (Val nullSpan () v) var e + +pmatch ctxt ((PBox _ _ p, e):ps) v@(Promote _ (Val _ _ v')) = do + match <- pmatch ctxt [(p, e)] v' + case match of + Just e -> return $ Just e + Nothing -> pmatch ctxt ps v + +pmatch ctxt ((PInt _ _ n, e):ps) (NumInt m) | n == m = return $ Just e + +pmatch ctxt ((PFloat _ _ n, e):ps) (NumFloat m )| n == m = return $ Just e + +pmatch ctxt (_:ps) v = pmatch ctxt ps v + +valExpr :: ExprFix2 g ExprF ev () -> ExprFix2 ExprF g ev () +valExpr = Val nullSpanNoFile () + +builtIns :: (?globals :: Globals) => Ctxt RValue +builtIns = + [ + (mkId "div", Ext () $ Primitive $ \(NumInt n1) + -> Ext () $ Primitive $ \(NumInt n2) -> NumInt (n1 `div` n2)) + , (mkId "pure", Ext () $ Primitive $ \v -> Pure () (Val nullSpan () v)) + , (mkId "intToFloat", Ext () $ Primitive $ \(NumInt n) -> NumFloat (cast n)) + , (mkId "showInt", Ext () $ Primitive $ \n -> case n of + NumInt n -> StringLiteral . pack . show $ n + n -> error $ show n) + , (mkId "fromStdin", diamondConstr $ do + when testing (error "trying to read stdin while testing") + putStr "> " + hFlush stdout + val <- Text.getLine + return $ Val nullSpan () (StringLiteral val)) + + , (mkId "readInt", diamondConstr $ do + when testing (error "trying to read stdin while testing") + putStr "> " + hFlush stdout + val <- Text.getLine + return $ Val nullSpan () (NumInt $ read $ unpack val)) + + , (mkId "toStdout", Ext () $ Primitive $ \(StringLiteral s) -> + diamondConstr (do + when testing (error "trying to write `toStdout` while testing") + Text.putStr s + return $ (Val nullSpan () (Constr () (mkId "()") [])))) + , (mkId "toStderr", Ext () $ Primitive $ \(StringLiteral s) -> + diamondConstr (do + when testing (error "trying to write `toStderr` while testing") + let red x = "\ESC[31;1m" <> x <> "\ESC[0m" + Text.hPutStr stderr $ red s + return $ Val nullSpan () (Constr () (mkId "()") []))) + , (mkId "openHandle", Ext () $ Primitive openHandle) + , (mkId "readChar", Ext () $ Primitive readChar) + , (mkId "writeChar", Ext () $ Primitive writeChar) + , (mkId "closeHandle", Ext () $ Primitive closeHandle) + , (mkId "showChar", + Ext () $ Primitive $ \(CharLiteral c) -> StringLiteral $ pack [c]) + , (mkId "charToInt", + Ext () $ Primitive $ \(CharLiteral c) -> NumInt $ fromEnum c) + , (mkId "charFromInt", + Ext () $ Primitive $ \(NumInt c) -> CharLiteral $ toEnum c) + , (mkId "stringAppend", + Ext () $ Primitive $ \(StringLiteral s) -> + Ext () $ Primitive $ \(StringLiteral t) -> StringLiteral $ s <> t) + , ( mkId "stringUncons" + , Ext () $ Primitive $ \(StringLiteral s) -> case uncons s of + Just (c, s) -> Constr () (mkId "Some") [Constr () (mkId ",") [CharLiteral c, StringLiteral s]] + Nothing -> Constr () (mkId "None") [] + ) + , ( mkId "stringCons" + , Ext () $ Primitive $ \(CharLiteral c) -> + Ext () $ Primitive $ \(StringLiteral s) -> StringLiteral (cons c s) + ) + , ( mkId "stringUnsnoc" + , Ext () $ Primitive $ \(StringLiteral s) -> case unsnoc s of + Just (s, c) -> Constr () (mkId "Some") [Constr () (mkId ",") [StringLiteral s, CharLiteral c]] + Nothing -> Constr () (mkId "None") [] + ) + , ( mkId "stringSnoc" + , Ext () $ Primitive $ \(StringLiteral s) -> + Ext () $ Primitive $ \(CharLiteral c) -> StringLiteral (snoc s c) + ) + , (mkId "isEOF", Ext () $ Primitive $ \(Ext _ (Handle h)) -> Ext () $ PureWrapper $ do + b <- SIO.isEOF + let boolflag = + case b of + True -> Constr () (mkId "True") [] + False -> Constr () (mkId "False") [] + return . Val nullSpan () $ Constr () (mkId ",") [Ext () $ Handle h, boolflag]) + , (mkId "forkLinear", Ext () $ PrimitiveClosure fork) + , (mkId "forkRep", Ext () $ PrimitiveClosure forkRep) + , (mkId "fork", Ext () $ PrimitiveClosure forkRep) + , (mkId "recv", Ext () $ Primitive recv) + , (mkId "send", Ext () $ Primitive send) + , (mkId "close", Ext () $ Primitive close) + ] + where + fork :: (?globals :: Globals) => Ctxt RValue -> RValue -> RValue + fork ctxt e@Abs{} = diamondConstr $ do + c <- CC.newChan + _ <- C.forkIO $ + evalIn ctxt (App nullSpan () (valExpr e) (valExpr $ Ext () $ Chan c)) >> return () + return $ valExpr $ Ext () $ Chan c + fork ctxt e = error $ "Bug in Granule. Trying to fork: " <> prettyDebug e + + forkRep :: (?globals :: Globals) => Ctxt RValue -> RValue -> RValue + forkRep ctxt e@Abs{} = diamondConstr $ do + c <- CC.newChan + _ <- C.forkIO $ + evalIn ctxt (App nullSpan () + (valExpr e) + (valExpr $ Promote () $ valExpr $ Ext () $ Chan c)) >> return () + return $ valExpr $ Promote () $ valExpr $ Ext () $ Chan c + forkRep ctxt e = error $ "Bug in Granule. Trying to fork: " <> prettyDebug e + + recv :: (?globals :: Globals) => RValue -> RValue + recv (Ext _ (Chan c)) = diamondConstr $ do + x <- CC.readChan c + return $ valExpr $ Constr () (mkId ",") [x, Ext () $ Chan c] + recv e = error $ "Bug in Granule. Trying to recevie from: " <> prettyDebug e + + send :: (?globals :: Globals) => RValue -> RValue + send (Ext _ (Chan c)) = Ext () $ Primitive + (\v -> diamondConstr $ do + CC.writeChan c v + return $ valExpr $ Ext () $ Chan c) + send e = error $ "Bug in Granule. Trying to send from: " <> prettyDebug e + + close :: RValue -> RValue + close (Ext _ (Chan c)) = diamondConstr $ return $ valExpr $ Constr () (mkId "()") [] + close rval = error $ "Runtime exception: trying to close a value which is not a channel" + + cast :: Int -> Double + cast = fromInteger . toInteger + + openHandle :: RValue -> RValue + openHandle (Constr _ m []) = + Ext () $ Primitive (\x -> diamondConstr ( + case x of + (StringLiteral s) -> do + h <- SIO.openFile (unpack s) mode + return $ valExpr $ Ext () $ Handle h + rval -> error $ "Runtime exception: trying to open from a non string filename" <> show rval)) + where + mode = case internalName m of + "ReadMode" -> SIO.ReadMode + "WriteMode" -> SIO.WriteMode + "AppendMode" -> SIO.AppendMode + "ReadWriteMode" -> SIO.ReadWriteMode + x -> error $ show x + + openHandle x = error $ "Runtime exception: trying to open with a non-mode value" <> show x + + writeChar :: RValue -> RValue + writeChar (Ext _ (Handle h)) = + Ext () $ Primitive (\c -> diamondConstr ( + case c of + (CharLiteral c) -> do + SIO.hPutChar h c + return $ valExpr $ Ext () $ Handle h + _ -> error $ "Runtime exception: trying to put a non character value")) + writeChar _ = error $ "Runtime exception: trying to put from a non handle value" + + readChar :: RValue -> RValue + readChar (Ext _ (Handle h)) = diamondConstr $ do + c <- SIO.hGetChar h + return $ valExpr (Constr () (mkId ",") [Ext () $ Handle h, CharLiteral c]) + readChar _ = error $ "Runtime exception: trying to get from a non handle value" + + closeHandle :: RValue -> RValue + closeHandle (Ext _ (Handle h)) = diamondConstr $ do + SIO.hClose h + return $ valExpr (Constr () (mkId "()") []) + closeHandle _ = error $ "Runtime exception: trying to close a non handle value" + +evalDefs :: (?globals :: Globals) => Ctxt RValue -> [Def (Runtime ()) ()] -> IO (Ctxt RValue) +evalDefs ctxt [] = return ctxt +evalDefs ctxt (Def _ var [Equation _ _ [] e] _ : defs) = do + val <- evalIn ctxt e + case extend ctxt var val of + Just ctxt -> evalDefs ctxt defs + Nothing -> error $ "Name clash: `" <> sourceName var <> "` was already in the context." +evalDefs ctxt (d : defs) = do + let d' = desugar d + evalDefs ctxt (d' : defs) + +-- Maps an AST from the parser into the interpreter version with runtime values +class RuntimeRep t where + toRuntimeRep :: t () () -> t (Runtime ()) () + +instance RuntimeRep Def where + toRuntimeRep (Def s i eqs tys) = Def s i (map toRuntimeRep eqs) tys + +instance RuntimeRep Equation where + toRuntimeRep (Equation s a ps e) = Equation s a ps (toRuntimeRep e) + +instance RuntimeRep Expr where + toRuntimeRep (Val s a v) = Val s a (toRuntimeRep v) + toRuntimeRep (App s a e1 e2) = App s a (toRuntimeRep e1) (toRuntimeRep e2) + toRuntimeRep (Binop s a o e1 e2) = Binop s a o (toRuntimeRep e1) (toRuntimeRep e2) + toRuntimeRep (LetDiamond s a p t e1 e2) = LetDiamond s a p t (toRuntimeRep e1) (toRuntimeRep e2) + toRuntimeRep (Case s a e ps) = Case s a (toRuntimeRep e) (map (\(p, e) -> (p, toRuntimeRep e)) ps) + +instance RuntimeRep Value where + toRuntimeRep (Ext a ()) = error "Bug: Parser generated an extended value case when it shouldn't have" + toRuntimeRep (Abs a p t e) = Abs a p t (toRuntimeRep e) + toRuntimeRep (Promote a e) = Promote a (toRuntimeRep e) + toRuntimeRep (Pure a e) = Pure a (toRuntimeRep e) + toRuntimeRep (Constr a i vs) = Constr a i (map toRuntimeRep vs) + -- identity cases + toRuntimeRep (CharLiteral c) = CharLiteral c + toRuntimeRep (StringLiteral c) = StringLiteral c + toRuntimeRep (Var a x) = Var a x + toRuntimeRep (NumInt x) = NumInt x + toRuntimeRep (NumFloat x) = NumFloat x + +eval :: (?globals :: Globals) => AST () () -> IO (Maybe RValue) +eval (AST dataDecls defs _) = do + bindings <- evalDefs builtIns (map toRuntimeRep defs) + case lookup (mkId entryPoint) bindings of + Nothing -> return Nothing + -- Evaluate inside a promotion of pure if its at the top-level + Just (Pure _ e) -> fmap Just (evalIn bindings e) + Just (Ext _ (PureWrapper e)) -> do + eExpr <- e + fmap Just (evalIn bindings eExpr) + Just (Promote _ e) -> fmap Just (evalIn bindings e) + -- ... or a regular value came out of the interpreter + Just val -> return $ Just val diff --git a/interpreter/src/Language/Granule/Interpreter/Preprocess.hs b/interpreter/src/Language/Granule/Interpreter/Preprocess.hs new file mode 100644 index 000000000..4c9ecadb6 --- /dev/null +++ b/interpreter/src/Language/Granule/Interpreter/Preprocess.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Granule.Interpreter.Preprocess where + +import Control.Exception (SomeException, throwIO, try) +import Control.Monad (when) +import Data.List (intercalate) +import System.Directory (removeFile, renameFile) +import System.FilePath (splitFileName) +import System.IO (hClose, hPutStr, openTempFile) + +import Language.Granule.Syntax.Preprocessor.Latex +import Language.Granule.Syntax.Preprocessor.Markdown + + +-- | Preprocess the source file based on the file extension. +preprocess :: Maybe (String -> String) -> Bool -> String -> FilePath -> IO String +preprocess mbRewriter keepOldFile file env + = case lookup extension acceptedFormats of + Just (stripNonGranule, preprocessOnlyGranule) -> do + src <- readFile file + case mbRewriter of + Just rewriter -> do + let processedSrc = preprocessOnlyGranule rewriter src + -- open a temporary file + (tempFile, tempHd) <- uncurry openTempFile (splitFileName file) + -- write the processed source to the temporary file + try (hPutStr tempHd processedSrc) >>= \case + Right () -> do + hClose tempHd + -- if we are keeping the original source file, then rename it + when keepOldFile (renameFile file (file <> ".bak")) + -- move the temp file to the original source file path + renameFile tempFile file + return $ stripNonGranule processedSrc + Left (e :: SomeException) -> do + hClose tempHd + removeFile tempFile + throwIO e + Nothing -> return $ stripNonGranule src + Nothing -> error + $ "Unrecognised file extension: " + <> extension + <> ". Expected one of " + <> intercalate ", " (map fst acceptedFormats) + <> "." + where + extension = reverse . takeWhile (/= '.') . reverse $ file + + -- (file extension, (stripNonGranule, destructive preprocessor)) + acceptedFormats = + [ ("gr", (id, id)) + , ("md", (unMarkdown env, processGranuleMarkdown id env)) + , ("tex", (unLatex env, processGranuleLatex id env)) + , ("latex", (unLatex env, processGranuleLatex id env)) + ] diff --git a/interpreter/tests/Golden.hs b/interpreter/tests/Golden.hs new file mode 100644 index 000000000..f2b7aeee1 --- /dev/null +++ b/interpreter/tests/Golden.hs @@ -0,0 +1,127 @@ +import Control.Monad (unless) +import Data.Algorithm.Diff (getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Test.Tasty (defaultMain, TestTree, testGroup) +import Test.Tasty.Golden (findByExtension) +import Test.Tasty.Golden.Advanced (goldenTest) +import System.Directory (setCurrentDirectory) +import System.FilePath (dropExtension) +import qualified System.IO.Strict as Strict (readFile) + +import Language.Granule.Interpreter (InterpreterResult(..), InterpreterError(..)) +import qualified Language.Granule.Interpreter as Interpreter +import Language.Granule.Syntax.Pretty (pretty) +import Language.Granule.Utils (Globals (..), formatError) + +main :: IO () +main = do + -- go into project root + setCurrentDirectory "../" + negative <- goldenTestsNegative + positive <- goldenTestsPositive + defaultMain $ testGroup "Golden tests" [negative, positive] + +goldenTestsNegative :: IO TestTree +goldenTestsNegative = do + -- get example files, but discard the excluded ones + files <- findByExtension granuleFileExtensions "frontend/tests/cases/negative" + + -- ensure we don't have spurious output files without associated tests + outfiles <- findByExtension [".output"] "frontend/tests/cases/negative" + failOnOrphanOutfiles files outfiles + + return $ testGroup + "Golden examples, StdLib and positive regressions" + (map (grGolden formatResult) files) + + where + formatResult :: Either InterpreterError InterpreterResult -> String + formatResult = let ?globals = goldenGlobals in \case + Left err -> formatError err + Right x -> error $ "Negative test passed!\n" <> show x + + +goldenTestsPositive :: IO TestTree +goldenTestsPositive = do + -- get example files, but discard the excluded ones + exampleFiles <- findByExtension granuleFileExtensions "examples" + stdLibFiles <- findByExtension granuleFileExtensions "StdLib" + positiveFiles <- findByExtension granuleFileExtensions "frontend/tests/cases/positive" + let files = exampleFiles <> stdLibFiles <> positiveFiles + + -- ensure we don't have spurious output files without associated tests + exampleOutfiles <- findByExtension [".output"] "examples" + positiveOutfiles <- findByExtension [".output"] "frontend/tests/cases/positive" + let outfiles = exampleOutfiles <> positiveOutfiles + failOnOrphanOutfiles files outfiles + + return $ testGroup + "Golden examples, StdLib and positive regressions" + (map (grGolden formatResult) files) + + where + formatResult :: Either InterpreterError InterpreterResult -> String + formatResult = let ?globals = goldenGlobals in \case + Right (InterpreterResult val) -> pretty val + Left err -> error $ formatError err + Right NoEval -> mempty + +grGolden + :: (Either InterpreterError InterpreterResult -> String) + -> FilePath + -> TestTree +grGolden formatResult file = goldenTest + file + (Strict.readFile outfile) + (formatResult <$> runGr file) + checkDifference + (\actual -> unless (null actual) (writeFile outfile actual)) + where + outfile = file <> ".output" + checkDifference :: String -> String -> IO (Maybe String) + checkDifference exp act = if exp == act + then return Nothing + else return . Just $ unlines + [ "Contents of " <> outfile <> " (<) and actual output (>) differ:" + , ppDiff $ getGroupedDiff (lines exp) (lines act) + ] + + runGr :: FilePath -> IO (Either InterpreterError InterpreterResult) + runGr fp = do + src <- readFile fp + let ?globals = goldenGlobals + Interpreter.run src + +failOnOrphanOutfiles :: [FilePath] -> [FilePath] -> IO () +failOnOrphanOutfiles files outfiles + = case filter (\outfile -> dropExtension outfile `notElem` files) outfiles of + [] -> return () + orphans -> error . red $ "Orphan output files:\n" <> unlines orphans + where + red x = "\ESC[31;1m" <> x <> "\ESC[0m" + +granuleFileExtensions :: [String] +granuleFileExtensions = [".gr", ".gr.md"] + +goldenGlobals :: Globals +goldenGlobals = mempty + { globalsNoColors = Just True + , globalsSuppressInfos = Just True + , globalsTesting = Just True + } + +{- +-- This was used to clean up after running tests, previously. Keeping it around +-- here in case we need something like this in future. @buggymcbugfix + +-- | Run tests and remove all empty outfiles +runTestsAndCleanUp :: TestTree -> IO () +runTestsAndCleanUp tests = do + defaultMain tests `catch` (\(e :: SomeException) -> do + outfiles <- findByExtension [".output"] "." + forM_ outfiles $ \outfile -> do + contents <- readFile outfile + when (null contents) (removeFile outfile) + throwIO e) + +-} \ No newline at end of file diff --git a/repl/app/Language/Granule/Main.hs b/repl/app/Language/Granule/Main.hs index 5ba86c936..f0655fa50 100644 --- a/repl/app/Language/Granule/Main.hs +++ b/repl/app/Language/Granule/Main.hs @@ -14,11 +14,11 @@ import System.FilePath import System.FilePath.Find import System.Directory import qualified Data.Map as M -import qualified Language.Granule.Checker.Monad as Mo +import qualified Language.Granule.Checker.Monad as Checker import qualified Data.ConfigFile as C +import Data.List.NonEmpty (NonEmpty) import Control.Exception (try) import Control.Monad.State -import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import System.Console.Haskeline import System.Console.Haskeline.MonadException() @@ -35,9 +35,9 @@ import Language.Granule.Syntax.Parser import Language.Granule.Syntax.Lexer import Language.Granule.Syntax.Span import Language.Granule.Checker.Checker -import Language.Granule.Checker.Substitutions +import Language.Granule.Checker.Substitution import qualified Language.Granule.Checker.Primitives as Primitives -import Language.Granule.Eval +import Language.Granule.Interpreter.Eval import Language.Granule.Context --import qualified Language.Granule.Checker.Primitives as Primitives import qualified Control.Monad.Except as Ex @@ -64,7 +64,7 @@ instance MonadException m => MonadException (Ex.ExceptT e m) where in fmap Ex.runExceptT $ f run' replEval :: (?globals :: Globals) => Int -> AST () () -> IO (Maybe RValue) -replEval val (AST dataDecls defs) = do +replEval val (AST dataDecls defs _) = do bindings <- evalDefs builtIns (map toRuntimeRep defs) case lookup (mkId (" repl"<>(show val))) bindings of Nothing -> return Nothing @@ -98,7 +98,7 @@ rFindMain :: [String] -> [FilePath] -> IO [[FilePath]] rFindMain fn rfp = forM fn $ (\x -> rFindHelper x rfp ) readToQueue :: (?globals::Globals) => FilePath -> REPLStateIO () -readToQueue pth = do +readToQueue pth = let ?globals = ?globals{ globalsSourceFilePath = Just pth } in do pf <- liftIO' $ try $ parseAndDoImportsAndFreshenDefs =<< readFile pth case pf of @@ -107,15 +107,15 @@ readToQueue pth = do debugM "Pretty-printed AST:" $ pretty ast checked <- liftIO' $ check ast case checked of - Just _ -> do - let (AST dd def) = ast + Right _ -> do + let (AST dd def _) = ast forM def $ \idef -> loadInQueue idef (fvg,rp,adt,f,m) <- get put (fvg,rp,(dd<>adt),f,m) liftIO $ printInfo $ green $ pth<>", interpreted" - Nothing -> do + Left errs -> do (_,_,_,f,_) <- get - Ex.throwError (TypeCheckError pth f) + Ex.throwError (TypeCheckerError errs) Left e -> do (_,_,_,f,_) <- get Ex.throwError (ParseError e f) @@ -200,34 +200,30 @@ buildForEval [] _ = [] buildForEval (x:xs) m = buildAST (sourceName x) m <> buildForEval xs m synType :: (?globals::Globals) - => Expr () () -> Ctxt TypeScheme -> Mo.CheckerState - -> IO (Maybe (Type, Ctxt Mo.Assumption, Expr () Type)) -synType exp [] cs = liftIO $ Mo.evalChecker cs $ runMaybeT $ do - (ty, ctxt, subst, elab) <- synthExpr empty empty Positive exp - ty <- substitute subst ty - return (ty, ctxt, elab) - -synType exp cts cs = liftIO $ Mo.evalChecker cs $ runMaybeT $ do + => Expr () () + -> Ctxt TypeScheme + -> Checker.CheckerState + -> IO (Either (NonEmpty Checker.CheckerError) (Type, Ctxt Checker.Assumption, Expr () Type)) +synType exp cts cs = liftIO $ Checker.evalChecker cs $ do (ty, ctxt, subst, elab) <- synthExpr cts empty Positive exp ty <- substitute subst ty return (ty, ctxt, elab) - synTypeBuilder :: (?globals::Globals) => Expr () () -> [Def () ()] -> [DataDecl] -> REPLStateIO Type synTypeBuilder exp ast adt = do let ddts = buildCtxtTSDD adt - (_,cs) <- liftIO $ Mo.runChecker Mo.initState $ buildCheckerState adt + (_,cs) <- liftIO $ Checker.runChecker Checker.initState $ buildCheckerState adt ty <- liftIO $ synType exp ((buildCtxtTS ast) <> ddts) cs --liftIO $ print $ show ty case ty of - Just (t,a,_) -> return t - Nothing -> Ex.throwError OtherError' + Right (t,a,_) -> return t + Left err -> Ex.throwError (TypeCheckerError err) -buildCheckerState :: (?globals::Globals) => [DataDecl] -> Mo.Checker () -buildCheckerState dd = do - let checkDataDecls = runMaybeT (mapM_ checkTyCon dd *> mapM_ checkDataCons dd) - somethine <- checkDataDecls +buildCheckerState :: (?globals::Globals) => [DataDecl] -> Checker.Checker () +buildCheckerState dataDecls = do + _ <- Checker.runAll checkTyCon dataDecls + _ <- Checker.runAll checkDataCons dataDecls return () buildCtxtTS :: (?globals::Globals) => [Def () ()] -> Ctxt TypeScheme @@ -326,11 +322,11 @@ handleCMD s = case lfp of [] -> do put (fvg,rp,[],ptr,M.empty) - ecs <- processFilesREPL ptr (let ?globals = ?globals {debugging = True } in readToQueue) + ecs <- processFilesREPL ptr (let ?globals = ?globals {globalsDebugging = Just True } in readToQueue) return () _ -> do put (fvg,rp,[],lfp,M.empty) - ecs <- processFilesREPL lfp (let ?globals = ?globals {debugging = True } in readToQueue) + ecs <- processFilesREPL lfp (let ?globals = ?globals {globalsDebugging = Just True } in readToQueue) return () @@ -369,10 +365,10 @@ handleCMD s = _ -> liftIO $ putStrLn xtx ast -> do -- TODO: use the type that comes out of the checker to return the type - checked <- liftIO' $ check (AST adt ast) + checked <- liftIO' $ check (AST adt ast mempty) case checked of - Just _ -> liftIO $ putStrLn (printType trm m) - Nothing -> Ex.throwError (TypeCheckError trm f) + Right _ -> liftIO $ putStrLn (printType trm m) + Left err -> Ex.throwError (TypeCheckerError err) handleLine (Eval ev) = do (fvg,rp,adt,fp,m) <- get @@ -382,10 +378,10 @@ handleCMD s = let fv = freeVars exp case fv of [] -> do -- simple expressions - typ <- liftIO $ synType exp [] Mo.initState + typ <- liftIO $ synType exp [] Checker.initState case typ of - Just (t,a, _) -> return () - Nothing -> Ex.throwError (TypeCheckError ev fp) + Right (t,a, _) -> return () + Left err -> Ex.throwError (TypeCheckerError err) result <- liftIO' $ try $ evalIn builtIns (toRuntimeRep exp) case result of Right r -> liftIO $ putStrLn (pretty r) @@ -395,15 +391,15 @@ handleCMD s = typer <- synTypeBuilder exp ast adt let ndef = buildDef fvg (buildTypeScheme typer) exp put ((fvg+1),rp,adt,fp,m) - checked <- liftIO' $ check (AST adt (ast<>(ndef:[]))) + checked <- liftIO' $ check (AST adt (ast<>(ndef:[])) mempty) case checked of - Just _ -> do - result <- liftIO' $ try $ replEval fvg (AST adt (ast<>(ndef:[]))) + Right _ -> do + result <- liftIO' $ try $ replEval fvg (AST adt (ast<>(ndef:[])) mempty) case result of Left e -> Ex.throwError (EvalError e) Right Nothing -> liftIO $ print "if here fix" Right (Just result) -> liftIO $ putStrLn (pretty result) - Nothing -> Ex.throwError (OtherError') + Left err -> Ex.throwError (TypeCheckerError err) Left e -> Ex.throwError (ParseError e fp) --error from parsing (pexp) helpMenu :: String @@ -465,7 +461,7 @@ main = do | input == ":h" || input == ":help" -> (liftIO $ putStrLn helpMenu) >> loop st | otherwise -> do - r <- liftIO $ Ex.runExceptT (runStateT (let ?globals = defaultGlobals in handleCMD input) st) + r <- liftIO $ Ex.runExceptT (runStateT (let ?globals = mempty in handleCMD input) st) case r of Right (_,st') -> loop st' Left err -> do diff --git a/repl/app/Language/Granule/ReplError.hs b/repl/app/Language/Granule/ReplError.hs index c400914e9..1facd1454 100644 --- a/repl/app/Language/Granule/ReplError.hs +++ b/repl/app/Language/Granule/ReplError.hs @@ -1,33 +1,37 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} + module Language.Granule.ReplError where import Control.Monad.Except() import Control.Exception (SomeException) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import Data.Foldable (toList) +import Language.Granule.Checker.Monad (CheckerError) +import Language.Granule.Utils (formatError) data ReplError = FilePathError String | TermInContext String | OtherError - | OtherError' + | TypeCheckerError (NonEmpty CheckerError) -- TypeCheckError and ParserError record the filepath queue -- so that reloading across files can be done even if we -- fail to load a file the first time - | TypeCheckError String [FilePath] -- FilePath queue | ParseError SomeException [FilePath] -- FilePath queue | TermNotInContext String | EvalError SomeException remembersFiles :: ReplError -> Maybe [FilePath] remembersFiles (ParseError _ f) = Just f -remembersFiles (TypeCheckError _ f) = Just f remembersFiles _ = Nothing instance Show ReplError where show (FilePathError pth) = "The file path "<>pth<>" does not exist." show (TermInContext trm) = "The term \""<>trm<>"\" is already in context" - show (TypeCheckError pth _) = "Error type checking "<>pth show (ParseError e _) = show e show (TermNotInContext trm) = "The term \""<>trm<>"\" is not in the context" show (EvalError e) = show e show OtherError = "Error" - show OtherError' = "" + show (TypeCheckerError err) = let ?globals = mempty in intercalate "\n\n" . map formatError . toList $ err diff --git a/stack.yaml b/stack.yaml index 9235186ce..b13b018c7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2019-01-30 +resolver: lts-13.21 packages: - compiler/ - frontend/ @@ -13,6 +13,7 @@ extra-deps: - llvm-hs-7.0.1 - llvm-hs-pure-7.0.0 - text-replace-0.0.0.4 +- sbv-8.2 # Override default flag values for local packages and extra-deps flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 000000000..efb48f1d8 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,40 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: ConfigFile-1.1.4@sha256:ca56261e1deae6ef958a337b03812987bfd94ab37b047e27f262bc3137813165,2056 + pantry-tree: + size: 1016 + sha256: 58c2dbae1878d8f5bcac2848712ccfe90391bb1e6b719f43d044ead6c496f748 + original: + hackage: ConfigFile-1.1.4 +- completed: + hackage: llvm-hs-pretty-0.6.1.0@sha256:54785b205bc9a267513b539eb8073f9f576e01da196720871bc894520e712e16,1670 + pantry-tree: + size: 4741 + sha256: 09128cc6ff572c3c544de01ee2b683cdc356d606a5829f1c60966593ff2f59db + original: + hackage: llvm-hs-pretty-0.6.1.0 +- completed: + hackage: text-replace-0.0.0.4@sha256:88800aba160dfb512cf43b24063170d34900e1646ad21f28715a22679f42ae15,1738 + pantry-tree: + size: 293 + sha256: a7d17c85a9637ef9cc6762ea4e9b932191ede485655b5d18d41292cc9475b105 + original: + hackage: text-replace-0.0.0.4 +- completed: + hackage: sbv-8.2@sha256:bb17f85a58fbf67cc3fd9e897f7c4a625be80da342f8903ef17e97de7c9ac2ae,18313 + pantry-tree: + size: 52972 + sha256: b5e2f174fa20c1ef8c14cfb4e72fd35c92c35f181d042aaacce1cdf526addabd + original: + hackage: sbv-8.2 +snapshots: +- completed: + size: 498180 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/21.yaml + sha256: eff2de19a6d4691ccbf6edc1fba858f1918683047dce0f09adede874bbd2a8f3 + original: lts-13.21 diff --git a/work-in-progress/Choice.gr b/work-in-progress/Choice.gr new file mode 100644 index 000000000..ab0a205a7 --- /dev/null +++ b/work-in-progress/Choice.gr @@ -0,0 +1,50 @@ +-- ------ +-- --- Module: Choice +-- --- Description: A datatype with two elements. The only way to consume it is by either +-- --- choosing the first or the second element. You must choose exactly one. +-- --- Note: still need to encapsulate the `OneOf` constructor—pattern matching on it is BAD! +-- --- Authors: Vilem-Benjamin Liepelt +-- --- License: BSD3 +-- --- Copyright: (c) Authors 2018 +-- --- Issue-tracking: https://github.com/dorchard/granule/issues +-- --- Repository: https://github.com/dorchard/granule +-- ------ + +-- data Choice a b = OneOf (a [0..1]) (b [0..1]) -- TODO: don't export + +-- choice : forall {a : Type, b : Type} . a [0..1] -> b [0..1] -> Choice a b +-- choice x y = OneOf x y + +-- -- To construct a `Choice a b`, we need an `a [0..1]` and a `b [0..1]` because +-- -- the consumer can pick either the `a` or the `b`, not both. (That is currently +-- -- a lie, we need to be able to make the Choice constructor abstract, i.e. not +-- -- export it, for this to hold.) +-- -- +-- -- NB: Polymorphism allows further nonlinearity to be encapsulated inside of the +-- -- `a` and `b`. In other words, `[0..1]` is just the minimum amount of linearity +-- -- required. Example: +-- -- +-- -- ```granule +-- -- choiceExample : forall a : Type, b : Type +-- -- . a [0..2] -> b [0..1] -> Choice (a [1..2]) b +-- -- choiceExample aBox bBox = choice (unflatten aBox) bBox +-- -- ``` + +-- choose1 : forall a : Type, b : Type . Choice a b -> a +-- choose1 (OneOf [x] [_]) = x + +-- choose2 : forall a : Type, b : Type . Choice a b -> b +-- choose2 (OneOf [_] [y]) = y + + +data Choice : Type -> Type -> Nat -> Type where + MkChoice : forall {a : Type, b : Type, m : Nat, n : Nat}. a [0..m] -> b [0..n] -> Choice a b (m + n) + +chooseA : forall {a : Type, b : Type, n : Nat}. Choice a b (n + 1) -> (a, Choice a b n) +chooseA (MkChoice [a] [b]) = (a, MkChoice [a] [b]) + +chooseLeft : forall {a : Type, b : Type, m : Nat, n : Nat}. Choice a b 1 -> a +chooseLeft (MkChoice [a] [_]) = a + +chooseRight : forall {a : Type, b : Type, m : Nat, n : Nat}. Choice a b 1 -> b +chooseRight (MkChoice [_] [b]) = b diff --git a/work-in-progress/Parse.gr b/work-in-progress/Parse.gr new file mode 100644 index 000000000..6842a5cd6 --- /dev/null +++ b/work-in-progress/Parse.gr @@ -0,0 +1,38 @@ +import Char +import Maybe + +-- takeWhile : (a -> (Bool, a)) -> VecX a -> (VecX a, VecX a) + +parseInt : String -> (Maybe Int, String) +parseInt str = case stringUnsnoc str of + None -> (None, ""); -- fail on empty string + Some (init,c) -> parseIntInner (stringSnoc init c) + +parseIntInner : String -> (Maybe Int, String) +parseIntInner str = case stringUnsnoc str of + None -> (0, ""); + Some (str,c) -> case digitToInt c of + Left c -> (None, stringSnoc str c); + Right n -> case parseIntInner str of + + + parseIntInner init c + + + case [digitToInt [c]] of + [None] -> None; + [Some n] -> case parseInt [init] of + None -> None; + Some m -> Some (n + (m * 10)) + +parseInt : String [0..1] -> Maybe Int +parseInt [str] = case [stringUnsnoc str] of + [None] -> Some 0; + [Some (init,c)] -> case [digitToInt [c]] of + [None] -> None; + [Some n] -> case parseInt [init] of + None -> None; + Some m -> Some (n + (m * 10)) + +-- main : Maybe Int +-- main = parseInt ["123456"] \ No newline at end of file diff --git a/work-in-progress/State.gr b/work-in-progress/State.gr new file mode 100644 index 000000000..4769a155a --- /dev/null +++ b/work-in-progress/State.gr @@ -0,0 +1,55 @@ +import Prelude + +data State sIn sOut a = State (sIn -> a × sOut) + +mapState + : forall {a : Type, b : Type, sIn : Type, sOut : Type} + . (a -> b) -> State sIn sOut a -> State s b +mapState f (State ka) = State (\s -> let (a, s) = ka s in (f a, s)) + +pureState + : forall {a : Type, s : Type} + . a -> State s a +pureState a = State (\s -> (a, s)) + +amapState + : forall {a : Type, b : Type, s : Type} + . State s (a -> b) -> State s a -> State s b +amapState (State kf) (State ka) = State + (\s -> + let (f, s) = kf s; + (a, s) = ka s + in (f a, s) + ) + +joinState + : forall {a : Type, s : Type} + . State s (State s a) -> State s a +joinState (State kka) = State (\s -> let ((State ka), s) = kka s in ka s) + +mmapState + : forall {a : Type, b : Type, s : Type} + . (a -> State s b) -> State s a -> State s b +mmapState k = joinState ∘ mapState k + + +-- here things get interesitng +-- `get` duplicates the state, so the usual implementation is not well typed +-- get +-- : forall {s : Type} +-- . State s s +-- get = State (\s -> (s, s)) + + +-- get +-- : forall {s : Type} +-- . State (s [2]) s +-- get = State (\[x] -> (x, x)) + +get + : forall {s : Type} + . State (s [2]) s +get = State foo + +foo : forall {s : Type} . s [2] -> (s, s) +foo = \[s] -> (s, s) \ No newline at end of file diff --git a/work-in-progress/Vec.gr b/work-in-progress/Vec.gr deleted file mode 100644 index 6aa6f894e..000000000 --- a/work-in-progress/Vec.gr +++ /dev/null @@ -1,20 +0,0 @@ --- last checked 2019-01-07 by @buggymcbugfix - -import Nat - --- this definition is fine, but gives the following error: --- --- Type error: work-in-progress/Vec.gr: :10:1: --- Definition 'map''is Falsifiable. Counter-example: --- n_2 = 1 :: Integer - -data Vec (n : Nat) t where - Nil : Vec 0 t; - Cons : t → Vec n t → Vec (n+1) t - -map : ∀ {a : Type, b : Type, n : Nat} - . (a → b) [n] → Vec n a → Vec n b -map [f] ys = - case ys of - Nil → Nil; - (Cons x xs) → Cons (f x) (map [f] xs) diff --git a/work-in-progress/approx.gr b/work-in-progress/approx.gr index f225bbd69..d9737ba91 100644 --- a/work-in-progress/approx.gr +++ b/work-in-progress/approx.gr @@ -1,6 +1,6 @@ --- last checked 2019-01-07 by @buggymcbugfix +-- last checked 2019-05-16 by @dorchard --- Pull coeffects of pair elements up to the pair -pull : ∀ {a : Type, b : Type, n : Nat, m : Nat} +pull : ∀ {a : Type, b : Type, k : Coeffect, n : k, m : k} . (a [n], b [m]) → (a, b) [n ∧ m] pull ([x], [y]) = [(x, y)] diff --git a/work-in-progress/approximations.gr b/work-in-progress/approximations.gr deleted file mode 100644 index 47eb4b5d3..000000000 --- a/work-in-progress/approximations.gr +++ /dev/null @@ -1,7 +0,0 @@ --- last checked 2019-01-07 by @buggymcbugfix - -castLevel : ∀ {a : Type} . a [Public] → a [Private] -castLevel [x] = [x] - -castNat : ∀ {a : Type} . a [5] → a [4] -castNat [x] = [x] diff --git a/work-in-progress/badIndexingMatch.gr b/work-in-progress/badIndexingMatch.gr new file mode 100644 index 000000000..f768a3467 --- /dev/null +++ b/work-in-progress/badIndexingMatch.gr @@ -0,0 +1,7 @@ +data Blah a where + Blah : a -> Blah a + +data Maybe a where Nothing ; Just a + +foo : forall {a : Type} . Blah a -> Blah Int +foo (Blah Nothing) = Blah 4 diff --git a/work-in-progress/badIndexingMatch.gr.output b/work-in-progress/badIndexingMatch.gr.output new file mode 100644 index 000000000..82e2a6ac9 --- /dev/null +++ b/work-in-progress/badIndexingMatch.gr.output @@ -0,0 +1,3 @@ +Type checking failed: + Unification failed: 7:11: + Cannot unify universally quantified type variable `a`` of kind `Type` with a concrete type `Maybe t1.0` \ No newline at end of file diff --git a/work-in-progress/call-by-value-analysis.gr b/work-in-progress/call-by-value-analysis.gr new file mode 100644 index 000000000..d9c7c6ffe --- /dev/null +++ b/work-in-progress/call-by-value-analysis.gr @@ -0,0 +1,12 @@ +-- Our analysis is call-by-name at the moment. + +foo : Int [4] -> Int +foo [x] = x * x * x * x + +bar : Int [2] -> Int +bar [x] = let [y] = [x * x] in y * y + +-- Type checking failed: work-in-progress/call-by-value-analysis.gr: +-- Falsifiable theorem: work-in-progress/call-by-value-analysis.gr:5:1: +-- The following theorem associated with `bar` is falsifiable: +-- (2 * 2 ≤ 2) \ No newline at end of file diff --git a/work-in-progress/case-shadowing.gr b/work-in-progress/case-shadowing.gr new file mode 100644 index 000000000..7bad96adf --- /dev/null +++ b/work-in-progress/case-shadowing.gr @@ -0,0 +1,28 @@ +-- last checked on 2019-02-27 by @buggymcbugfix +import Maybe + +readFile : String -> (Maybe String) +readFile filename = + let o <- openHandle filename ReadMode in + case o of + None -> pure None; + Some h -> + let (h, cs) <- readUntilEnd h; + _ <- closeHandle h + in pure (Some cs) + +readUntilEnd : Handle R -> (Handle R, String) +readUntilEnd h = + let (h, mc) <- readChar h in + case mc of + Some c -> + let (h, str) <- readUntilEnd h + in pure (h, stringCons c str); + None -> pure (h, "") + + +-- Type checking failed: work-in-progress/case-shadowing.gr: +-- Unbound variable error: work-in-progress/case-shadowing.gr:21:19: +-- `h` + +-- but when reordering the branches it's fine \ No newline at end of file diff --git a/frontend/tests/cases/positive/existential.gr b/work-in-progress/existential.gr similarity index 94% rename from frontend/tests/cases/positive/existential.gr rename to work-in-progress/existential.gr index bd2d58436..cc3ef5fed 100644 --- a/frontend/tests/cases/positive/existential.gr +++ b/work-in-progress/existential.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Dyn where Dyn : ∀ a : Type . a → Dyn diff --git a/work-in-progress/existentialNat.gr b/work-in-progress/existentialNat.gr new file mode 100644 index 000000000..1a6a6f73d --- /dev/null +++ b/work-in-progress/existentialNat.gr @@ -0,0 +1,11 @@ +import Nat + +-- Recent changes means this doesn't work + +--- Existential nat +data NX where + NX : ∀ {n : Nat} . N n → NX + +natToNX : Int → NX +natToNX 0 = NX Z; +natToNX n = let (NX m) = natToNX (n - 1) in NX (S m) diff --git a/work-in-progress/exists.gr b/work-in-progress/exists.gr new file mode 100644 index 000000000..47929a699 --- /dev/null +++ b/work-in-progress/exists.gr @@ -0,0 +1,31 @@ +data Void where + +data Ptr (id : Void) = MkPtr + +data Cap (id : Void) (a : Type) = MkCap + +data PtrCap a where + MkPtrCap : forall { id : Void } . (Ptr id) [] -> Cap id a -> PtrCap a + +new + : forall { a : Type } + . a -> PtrCap a +new = new + +swap + : forall { a b : Type, id : Void } + . b -> Ptr id -> Cap id a -> (a × Cap id b) +swap = swap + +free + : forall { a b : Type, id : Void } + . Ptr id -> Cap id a -> a +free = free + +main : Int +main = let + MkPtrCap [ptr1] cap1 = new 1; + MkPtrCap [ptr2] cap2 = new 2; + n = free ptr1 cap2; -- oops + m = free ptr2 cap1 -- 'nother oops + in n + m \ No newline at end of file diff --git a/work-in-progress/filter.gr b/work-in-progress/filter.gr index efe628b44..37303ef89 100644 --- a/work-in-progress/filter.gr +++ b/work-in-progress/filter.gr @@ -1,15 +1,16 @@ --- last checked 2019-02-14 by @dorchard - -import Vec import Bool --- (A very strange counter example, strangely high!) --- The associated theorem for `filter` is Falsifiable. Counter-example: --- k = 0 :: Integer --- m = 0 :: Integer --- n = 142 :: Integer +data Vec (n : Nat) t where + Nil : Vec 0 t; + Cons : t -> Vec n t -> Vec (n+1) t + +data SmallerVec (n : Nat) (a : Type) where + SV : forall {m : Nat} . {m <= n} => Vec m a -> SmallerVec n a -filter : ∀ {a : Type, n : Nat, m : Nat, k : Nat} . {m <= n} - => (a → Bool) [n] → Vec n (a [0..2]) → Vec m a -filter [_] Nil = Nil; -filter [p] (Cons [x] xs) = if p x then Cons x (filter [p] xs) else filter [p] xs +filter : ∀ {a : Type, n : Nat} . (a -> Bool) [n] -> Vec n (a [1..2]) -> SmallerVec n a +filter [f] Nil = SV Nil; +filter [f] (Cons [x] xs) = + let (SV ys) = filter [f] xs + in case (f x) of + True -> SV (Cons x ys); + False -> SV ys \ No newline at end of file diff --git a/work-in-progress/intervalApproxIssue.gr b/work-in-progress/intervalApproxIssue.gr new file mode 100644 index 000000000..cffcf8cc3 --- /dev/null +++ b/work-in-progress/intervalApproxIssue.gr @@ -0,0 +1,9 @@ +blah : Int [2..5] +blah = [42] + +-- Has some strange issue +foo : forall n m : Nat, a : Type . a [n..m] -> a [n..m] +foo [x] = [x] + +main : Int [0..10] +main = foo blah \ No newline at end of file diff --git a/work-in-progress/josef.gr b/work-in-progress/josef.gr new file mode 100644 index 000000000..566ef35c1 --- /dev/null +++ b/work-in-progress/josef.gr @@ -0,0 +1,19 @@ +data N (n : Nat) where + Z : N 0; + S : N n -> N (n+1) + +data Vec (n : Nat) t where + Nil : Vec 0 t; + Cons : t -> Vec n t -> Vec (n+1) t + +foldr + : forall {a b : Type, n : Nat} + . (a -> b -> b) [n] -> b -> Vec n a -> b +foldr [_] z Nil = z; +foldr [f] z (Cons x xs) = f x (foldr [f] z xs) + +foldr' : forall a b n. (a [] -> b [] -> b []) [n] -> b [] -> Vec n (a []) -> b [] +foldr' = foldr + +main : Int [] +main = foldr' [\[x] -> \[y] -> [x + x + y + y]] [0] (Cons [1] (Cons [2] Nil)) diff --git a/work-in-progress/lazy.gr b/work-in-progress/lazy.gr new file mode 100644 index 000000000..4a26d8c7a --- /dev/null +++ b/work-in-progress/lazy.gr @@ -0,0 +1,8 @@ +bar : String +bar = fromStdin --- reads but doesn't do anything with that result + +foo : () → String +foo = λ() → fromStdin + +main : () +main = let userInp ← foo () in toStdout userInp diff --git a/frontend/tests/cases/positive/order-of-equations.gr b/work-in-progress/order-of-equations.gr similarity index 96% rename from frontend/tests/cases/positive/order-of-equations.gr rename to work-in-progress/order-of-equations.gr index 4d117749e..dc0aa1a9c 100644 --- a/frontend/tests/cases/positive/order-of-equations.gr +++ b/work-in-progress/order-of-equations.gr @@ -1,3 +1,5 @@ +-- gr --no-eval + data Vec (n : Nat) t where Nil : Vec 0 t; Cons : t → Vec n t → Vec (n+1) t diff --git a/work-in-progress/partition.gr b/work-in-progress/partition.gr new file mode 100644 index 000000000..7cf77bcf9 --- /dev/null +++ b/work-in-progress/partition.gr @@ -0,0 +1,14 @@ +-- last checked 2019-04-07 by @buggymcbugfix + +partition + : ∀ {a : Type, n_F : Nat, n_T : Nat} + . (a -> Bool × a) [n_F + n_T] + -> Vec (n_F + n_T) a + -> Vec n_F a × Vec n_T a +partition [_] Nil = (Nil, Nil); +partition [p] (Cons x xs) = + let (xs_F, xs_T) = partition [p] xs in + let (b, x) = p x in + if b + then (xs_F, Cons x xs_T) + else (Cons x xs_F, xs_T) diff --git a/work-in-progress/pat.gr b/work-in-progress/pat.gr deleted file mode 100644 index 22ae472b6..000000000 --- a/work-in-progress/pat.gr +++ /dev/null @@ -1,9 +0,0 @@ --- last checked 2019-01-07 by @buggymcbugfix - --- TODO: fix this --- source/Language.Granule.Checker.Patterns.hs:100 - -data Foo where Bar Bar - -unfoo : Foo → () -unfoo Bar = () diff --git a/work-in-progress/popZeroes.gr b/work-in-progress/popZeroes.gr new file mode 100644 index 000000000..2750d9fb4 --- /dev/null +++ b/work-in-progress/popZeroes.gr @@ -0,0 +1,10 @@ +import Stack +import Bool + +popZeros : forall {n : Nat, m : Nat} . + {m <= (n+1)} => (Vec (n+1) (Int [1..Inf])) -> Vec m (Int [1..Inf]) +popZeros s = + case peek'' s of + (x, s) -> if x == 0 + then case pop s of ([_], s) -> popZeros s + else s \ No newline at end of file diff --git a/work-in-progress/promote-data-poly.gr b/work-in-progress/promote-data-poly.gr new file mode 100644 index 000000000..59dad3a39 --- /dev/null +++ b/work-in-progress/promote-data-poly.gr @@ -0,0 +1,20 @@ +data Maybe a = None | Some a + +data InOrOut : Bool -> Type -> Type where + In : forall {a : Type} . a -> InOrOut (Some ()) a; + Out : forall {a : Type} . InOrOut None a + +test : forall {m : Maybe Int} . InOrOut b Int -> InOrOut b Int +test (In x) = In (x * 2); +test Out = Out + +lala : forall {m : Maybe Int} . InOrOut (Some ()) Int -> Int +lala (In x) = x + +-- last checked by @buggymcbugfix on 2019-02-26 + +-- Checking frontend/tests/cases/positive/promote-data-poly.gr... +-- Fatal error: frontend/tests/cases/positive/promote-data-poly.gr: +-- frontend/tests/cases/positive/promote-data-poly.gr:4:3I'm afraid I can't yet promote the polymorphic data constructor:Some +-- CallStack (from HasCallStack): +-- error, called at src/Language/Granule/Checker/Kinds.hs:80:23 in granule-frontend-0.7.3.0-BwdxWJOLWzl5t6OilnbXBU:Language.Granule.Checker.Kinds \ No newline at end of file diff --git a/frontend/tests/cases/negative/refutable.gr b/work-in-progress/refutable.gr similarity index 100% rename from frontend/tests/cases/negative/refutable.gr rename to work-in-progress/refutable.gr diff --git a/work-in-progress/vecLookupSlow.gr b/work-in-progress/vecLookupSlow.gr new file mode 100644 index 000000000..5ff81dc71 --- /dev/null +++ b/work-in-progress/vecLookupSlow.gr @@ -0,0 +1,19 @@ +-- The following is fine but just takes an unreasonable amount of time to check +-- ~45s for DAO on 16/05/2019 + +data Maybe a = None | Some a +data Bool = True | False + +data Vec (n : Nat) t where + Nil : Vec 0 t; + Cons : t -> Vec n t -> Vec (n+1) t + +-- Lookup function +lookupBy : forall {a : Type, b : Type, n : Nat} + . (a -> a -> Bool) [0..n] -> a [0..n] -> (Vec n (a, b)) [0..1] -> Maybe b +lookupBy [p] [k] [Nil] = None; +lookupBy [p] [k] [Cons (k', v) xs] = + if p k k' then Some v else lookupBy [p] [k] [xs] + + -- Note if either of [0..n] is replaced with [0..Inf] then the solver time goes down + -- to a couple of seconds, strangely. \ No newline at end of file diff --git a/work-in-progress/vecx.gr b/work-in-progress/vecx.gr new file mode 100644 index 000000000..f0ac09c63 --- /dev/null +++ b/work-in-progress/vecx.gr @@ -0,0 +1,22 @@ +import Vec + +data Vecx a where + Vecx : ∀ {n : Nat} . Vec n a → Vecx a + +import List + +listToVecx : ∀ {a : Type} . List a → Vecx a +listToVecx Empty = Vecx Nil; +listToVecx (Next x xs) = let (Vecx xs) = listToVecx xs in Vecx (Cons x xs) + +vecxToList : ∀ {a : Type} . Vecx a → List a +vecxToList (Vecx Nil) = Empty; +vecxToList (Vecx (Cons x xs)) = Next x (vecxToList (Vecx xs)) + +-- last checked on 2019-02-22 by @buggymcbugfix + +-- Checking work-in-progress/vecx.gr... +-- Fatal error: work-in-progress/vecx.gr: +-- Looking up a variable '(Id "n.84" "n.84")' in [((Id "n.86" "n.86"),SNat :: SInteger),((Id "n.87" "n.87"),SNat :: SInteger),((Id "n.85" "n.85"),SNat :: SInteger)] +-- CallStack (from HasCallStack): +-- error, called at src/Language/Granule/Checker/Constraints.hs:412:10 in granule-frontend-0.7.3.0-GNqvizCPJs1ELcvko7Wqc5:Language.Granule.Checker.Constraints \ No newline at end of file