Showing preview only (436K chars total). Download the full file or copy to clipboard to get everything.
Repository: ranjitjhala/sprite-lang
Branch: master
Commit: 3da4a84a1dd6
Files: 179
Total size: 395.9 KB
Directory structure:
gitextract_nx1wz071/
├── .gitignore
├── ChangeLog.md
├── LICENSE
├── NOTES.md
├── README.md
├── Setup.hs
├── app/
│ └── Main.hs
├── cabal.project
├── package.yaml
├── sprite.cabal
├── sprite.cabal.orig
├── src/
│ └── Language/
│ └── Sprite/
│ ├── Common/
│ │ ├── Misc.hs
│ │ ├── Parse.hs
│ │ └── UX.hs
│ ├── Common.hs
│ ├── L1/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L1.hs
│ ├── L2/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L2.hs
│ ├── L3/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L3.hs
│ ├── L4/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L4.hs
│ ├── L5/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L5.hs
│ ├── L6/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L6.hs
│ ├── L8/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ ├── Reflect.hs
│ │ └── Types.hs
│ └── L8.hs
├── stack.yaml
├── stack.yaml.github
└── test/
├── L1/
│ ├── neg/
│ │ ├── inc00.re
│ │ ├── inc01.re
│ │ ├── inc02.re
│ │ └── int01.re
│ └── pos/
│ ├── inc00.re
│ ├── inc01.re
│ ├── inc02.re
│ ├── int00.re
│ └── int01.re
├── L2/
│ ├── neg/
│ │ ├── abs00.re
│ │ ├── abs01.re
│ │ ├── cmp00.re
│ │ ├── cmp01.re
│ │ └── sum00.re
│ └── pos/
│ ├── abs00.re
│ ├── abs01.re
│ ├── cmp00.re
│ ├── cmp01.re
│ └── sum00.re
├── L3/
│ ├── neg/
│ │ ├── abs01.re
│ │ ├── abs02-bad.re
│ │ ├── abs02.re
│ │ ├── assert00.re
│ │ ├── rebind.re
│ │ └── sum01.re
│ └── pos/
│ ├── abs01.re
│ ├── abs02-debug.re
│ ├── abs02.re
│ ├── assert00.re
│ └── sum01.re
├── L4/
│ ├── neg/
│ │ ├── choose00.re
│ │ ├── choose01.re
│ │ ├── foldn00.re
│ │ ├── foldn01.re
│ │ └── id00.re
│ └── pos/
│ ├── choose00.re
│ ├── choose01.re
│ ├── foldn00.re
│ ├── foldn01.re
│ └── id00.re
├── L5/
│ ├── neg/
│ │ ├── append00.re
│ │ ├── cons00.re
│ │ ├── head00.re
│ │ ├── head01.re
│ │ ├── isort00.re
│ │ ├── isort01.re
│ │ ├── listSet.re
│ │ ├── nil00.re
│ │ ├── olist00.re
│ │ ├── olist01.re
│ │ ├── olist02.re
│ │ ├── single00.re
│ │ ├── tail01.re
│ │ └── tuple00.re
│ └── pos/
│ ├── append00.re
│ ├── cons00.re
│ ├── fold_right00.re
│ ├── head00.re
│ ├── head01.re
│ ├── isort00.re
│ ├── isort01.re
│ ├── listSet.re
│ ├── nil00.re
│ ├── olist00.re
│ ├── olist01.re
│ ├── olist02.re
│ ├── single00.re
│ ├── tail01.re
│ └── tuple00.re
├── L6/
│ ├── neg/
│ │ ├── deptup00.re
│ │ ├── isort02.re
│ │ ├── maxint1.re
│ │ ├── maxint2.re
│ │ ├── maxlist.re
│ │ ├── maxlist00_1.re
│ │ ├── maxlist00_2.re
│ │ └── maxlist01.re
│ └── pos/
│ ├── apply00.re
│ ├── deptup00.re
│ ├── deptup000.re
│ ├── deptup001.re
│ ├── deptup002.re
│ ├── deptup002a.re
│ ├── deptup003.re
│ ├── deptup01.re
│ ├── isort02.re
│ ├── maxint.re
│ ├── maxlist00.re
│ ├── maxlist01.re
│ ├── maxpoly.re
│ └── plaintup00.re
├── L7/
│ ├── neg/
│ │ ├── ack.re
│ │ ├── list00.re
│ │ ├── listSet.re
│ │ ├── range.re
│ │ ├── sum.re
│ │ └── sumAcc.re
│ └── pos/
│ ├── ack.re
│ ├── append.re
│ ├── braid.re
│ ├── listSet.re
│ ├── range.re
│ ├── sum.re
│ ├── sumAcc.re
│ └── sumNat.re
├── L8/
│ ├── neg/
│ │ ├── append.re
│ │ ├── listSet.re
│ │ └── sum.re
│ └── pos/
│ ├── adttup00.re
│ ├── append.re
│ ├── listSet.re
│ ├── poly.re
│ └── sum.re
├── Spec.hs
└── logs/
└── cur/
└── summary.csv
================================================
FILE CONTENTS
================================================
================================================
FILE: .gitignore
================================================
dist
dist-*
cabal-dev
*.o
*.hi
*.hie
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
.liquid/
*.hp
*.eventlog
.stack-work/
cabal.project.local
cabal.project.local~
.HTF/
.ghc.environment.*
================================================
FILE: ChangeLog.md
================================================
# Changelog for liquid-tutorial
## Unreleased changes
================================================
FILE: LICENSE
================================================
Copyright Author name here (c) 2019
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Author name here nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
================================================
FILE: NOTES.md
================================================
# SPRITE
An tutorial-style implementation of liquid/refinement types for a subset of Ocaml/Reason.
## TODO: Paper
- [*] Lang1 : STLC + Annot (refinements 101)
- [*] Lang2 : "" + Branches (path-sensitivity)
- [*] Lang3 : "" + *-refinements (inference + qual-fixpoint)
- [*] Lang4 : "" + T-Poly (type-polymorphism)
- [*] Lang5 : "" + Data (datatypes & measures)
- [*] Lang6 : "" + R-Poly (refinement-polymorphism)
- [*] Lang7 : "" + Termination (metrics + invariants)
- [-] Lang8 : "" + Reflection (proofs)
- [ ] well-formedness
- [ ] L7 Invariant & Validity
- [ ] intro
- [ ] outro
## TODO: Code
- [*] Save Horn QUERY
- [ ] ANF
## L7 Invariant & Validity
```
I, G, f_k |- t
---------------------- [Inv-RAbs]
I, G |- rall r. t
I, G, a |- t
---------------------- [Inv-TAbs]
I, G |- all a. t
I, G, x:s |- x:s -> t
---------------------- [Inv-Fun]
I, G |- x:s -> t
G |- t <: I(t)
---------------------- [Inv-Base]
I, G |- t
```
## Dependencies
```txt
L1 --> L2 --> L3 --> L4 --> L6
`--> L5 --> L7 --> L8
```
## Horn Constraints
- Syntax
- Semantics
- Solution
- Houdini
- Fusion
- [McMillan, Bjorner, Rybalchenko]
### Types and Terms
```txt
p :== x -- PREDICATES
| c
| (op p1 ... pn) -- interpreted ops
| (f p1 ... pn) -- uninterpreted ops
| (bop p1 ... pn) -- boolean ops
c :== p -- FORMULAS
| c /\ c
| all x. (p => c)
r ::= [v|p] -- known refinements
t ::= Int[r] -- refined int
| x:t -> t -- dependent arrow
e ::= x -- variables [synth]
| c -- constants [synth]
| \x. e -- functions [check]
| e x -- anf-application [synth]
| let x = e in e -- let-binding [check]
| e : t -- annotation [check]
```
### Declarative Checking
Environments
```txt
G ::= 0 | G, x:t -- environment
```
Judgments
```txt
G |- e <== t -- checking judgment
G |- e ==> t -- synthesis judgment
```
Rules
- *Check-_* deals with `let`, `\x.e`
- *Synth-_* deals with `x`, `c`, `e x`, `e:t`
#### Subtyping Rules
```txt
Valid(G,p)
----------[Sub-Valid]
G |- p
G,v:int{p} |- q[w:=v]
-------------------------[Sub-Base]
G |- int{v:p} <: int{w:q}
G |- s2 <: s1 G,x2:s2 |- t1[x1:=x2] <: t2
------------------------------------------------[Sub-Fun]
G |- x1:s1 -> t1 <: x2:s2 -> t2
```
Alternate "Hybrid" Presentation
```txt
Valid(c)
--------
0 => c
G => (all x. (p => c))
----------------------
G, x:{p} => c
G => sub(s, t)
---------------
G |- s <: t
```
#### Checking Rules
```txt
G, x:t1 |- e <== t2
--------------------------[Chk-Lam]
G |- \x.e <== x:t1 -> t2
G |- e1 ==> t1 G, x:t1 |- e2 <== t2
--------------------------------------------[Chk-Let]
G |- let x = e1 in e2 <== t2
G |- e ==> s G |- s <: t
----------------------------------[Chk-Syn]
G |- e <== t
```
#### Synthesis Rules
```txt
----------------- [Syn-Var]
G |- x ==> G(x)
----------------- [Syn-Con]
G |- x ==> ty(c)
G |- e <== t
----------------- [Syn-Ann]
G |- e:t ==> t
G |- e ==> x:s -> t
G |- y <== s
-----------------------[Syn-App]
G |- e y ==> t[x := y]
G |- e ==> s -> t G |- (s -> t) * x ==> t
-------------------------------------------
G |- e x ==> t
G |- e ==> forall as. x1:s1 -> ... xn:sn -> t
G |- (forall as.S * y1 ... yn) <== T
G |- (e y1 ... yn) ==> t
```
### Algorithmic Constraints
```haskell
--------------------------------------------------------------------
sub :: (Type, Type) -> Cstr
--------------------------------------------------------------------
sub(B{v:p}, B{w:q}) = (v::p) => q[w:=v]
sub(x1:s1 -> t1, x2:s2 -> t2) = sub (s2, s1) /\ (x2 :: t2) => sub(t1[x1:=x2], t2)
--------------------------------------------------------------------
imp :: (Env, Cstr) -> Cstr
--------------------------------------------------------------------
imp (0, c) = c
imp (G;x:t, c) = imp(G, all x t c)
```
```haskell
-------------------------------------------------------
check :: (Env, Expr, Type) -> C
-------------------------------------------------------
check (g, \x.e, x:s -> t) = (x :: s) => c
where
c = check(g;x:s, e, t)
check (g, let x e e', t') = c /\ ((x::s) => c')
where
(c, s) = synth(g, e)
c' = check(g;x:s, e', t')
check (g, e, t) = sub(s, t)
where
(c, s) = synth(g, e)
-----------------------------------------------------
synth :: (Env, Expr) -> (C, Type)
-----------------------------------------------------
synth (g, x) = (TT, lookupEnv g x )
synth (g, c) = (TT, ty c )
synth (g, e y) = (ce /\ cy, t[x := y])
where
(ce, x:s->t) = synth (g, e)
cy = check (g, y)
synth (g, e:t) = (c, t )
where
c = check g e t
```
## Lang2
### Examples
Booleans
```reason
/*@ val cmp : (x:int, y:int) => bool{b| b <=> (x < y)} */
let cmp = (x, y) => {
if (x < y) {
true
} else {
false
}
}
```
Path Sensitivity
```reason
/*@ val abs : x:int => int[v| 0<=v && x <= v] */
let abs = (x) => {
if x >= 0 {
x
} else {
0 - x
};
};
/*@ val test : (a:int, b:int) => int[v|0<=v && a + b <= v] */
let test = (a, b) => {
let t1 = abs(a);
let t2 = abs(b);
t1 + t2
}
```
Recursion
```reason
/*@ val sum : n:int => int[v|0 <= v && n <= v] */
let rec sum = (n) => {
if (n <= 0) {
0
} else {
let n1 = n-1;
let t1 = sum(n1);
n + t1
}
}
```
### Types and Terms
```txt
t ::=
| Bool{r} -- refined bool
e ::= ...
| if v e1 e2 -- branches
| letrec f = (e:t) -- recursive binder with annot
```
### Declarative Checking
Environments
```
G ::= ... | G, _:t -- extend with "fresh"/"distinct" binder
```
Judgments, Rules (as before)
#### Subtyping
Subtyping (as before)
#### Checking
Rec binders must have type-sig
```
G |- v <== bool
G, _:int{v} |- e1 <== t
G, _:int{not v} |- e2 <== t
--------------------------------[Chk-If]
G |- if v e1 e2 <== t
G; f:t1 |- e1 <== t1 G; f:t1 |- e2 <== t2
------------------------------------------------[Chk-Rec]
G |- letrec f = (e1:t1) in e2 <== t2
```
#### Synthesis
**Note** Only when you add branches do you need
the singleton rule for variable lookup: without it
`abs00.re` doesn't check!
```
--------------------------- [Syn-Var]
G |- x ==> singleton(G, x)
```
where
```
singleton(G, x) = v:b{p /\ v = x} if G(x) = b[v|p]
G(x) otherwise
```
### Algorithmic Constraints
#### Check
```haskell
check g (EIf v e1 e2) t = ((x :: v) => c1) /\ ((x :: ~v) => c2)
where
c1 = check g e1 t
c2 = check g e2 t
x = fresh
check g (ERec f e1 t1 e2) t2 = c1 /\ c2
where
c1 = check g' e1 t1
c2 = check g' e2 t2
g' = g; f:t1
```
#### Synth
as before
## Lang 3
### Examples
```reason
/*@ val assert : bool[b|b] => int */
let assert = (b) => { 0 };
/*@ val abs : x:int => int[?] */
let abs = (x) => {
if x >= 0 {
x
} else {
0 - x
};
};
/*@ val main : int -> int */
let main = (y) => {
let ya = abs(y); // neg: omit 'abs'
let ok = 0 <= ya;
assert(ok) // never fails
}
```
```reason
/*@ val assert : bool[b|b] => int */
let assert = (b) => { 0 };
/*@ val abs : x:int => int[?] */
let abs = (x) => {
if x >= 0 {
x
} else {
0 - x
};
};
/*@ val incf: int => int */
let incf = (x:nat) : nat => {
/*@ val wrap : (int -> int[?]) -> int[?] */
let wrap = (f) => {
let r = f(x);
r + 1
};
let res = wrap(abs);
let ok = 0 < res;
assert (ok)
};
```
### Types and Terms
```txt
p ::= ...
| K(x1,...,xn) -- horn-variable
r ::= ...
| [?] -- unknown
```
### Declarative Checking
"fresh" each annotation
#### Subtyping
(as before)
#### Checking
```txt
t1 := fresh(s1)
G; f:t1 |- e1 <== t1
G; f:t1 |- e2 <== t2
------------------------------------- [Chk-Rec]
G |- letrec f = (e1:s1) in e2 <== t2
```
#### Synthesis
```
G |- e <== t t := fresh(s)
--------------------------- [Syn-Ann]
G |- e:s => t
```
### Algorithmic Constraints
"fresh" each annotation
```haskell
fresh :: Env -> Type -> Type
fresh g (B[r]) = B[freshR g B r]
where
r' = freshR g r
fresh g (x:s -> t) = x:s' -> t'
where
s' = fresh g s
t' = fresh (g; x:s') t
freshR :: Env -> Base -> Reft -> Reft
freshR _ _ [v|p] = [v|p]
freshR g B [?] = [v|k(v, x1...)]
where
v = freshV
k = freshK [B, s1...]
(x1:s1...) = g
```
Rest is swept under the horn solving rug?
#### Check
```haskell
check g (ERec f e1 s1 e2) t2 = c1 /\ c2
where
c1 = check g' e1 t1
c2 = check g' e2 t2
g' = g; f:t1
t1 = fresh s1
```
#### Synth
```haskell
synth (g, e:s) = (c, t)
where
c = check g e t
t = fresh s
```
## Lang 4
### Examples
see `tests/L4/{pos, neg}`
### Types and Terms
```txt
G ::= ...
| G, a -- ^ type variables
t :== ...
| a[r] -- ^ refined base type
| all a. t -- ^ forall types (quantifiers at the top)
e :== ...
| Λ a. e -- ^ type abstraction
| e [t] -- ^ type application
```
### Declarative Checking
The real hassle here is the *elaboration* step that adds the explicit
type abstraction and application.
#### Subtyping
```txt
G, v:int{p} |- q[w:=v]
-------------------------[Sub-Base]
G |- b[v|p] <: b[w|q]
G |- t1 <: t2 [a2 := a1]
------------------------------[Sub-All]
G |- all a1. t1 <: all a2. t2
```
#### Checking
```txt
G, a |- e <== s
------------------------ [Chk-TLam]
G |- Λ a. e <== all a. s
```
#### Synthesis
```txt
G |- e ==> all a. s
------------------------- [Syn-TApp]
G |- e[t] ==> s [ a := t]
```
### Algorithmic Constraints
#### Check
```haskell
check g (ETLam a e _) (TAll b t) | a == b = do
check g e t
```
#### Synth
```haskell
synth g (ETApp e t l) = do
(ce, te) <- synth g e
case te of
TAll a s -> do tt <- Misc.traceShow "REFRESH" <$> refresh l g t
return (ce, tsubst a tt s)
_ -> failWith "Type Application to non-forall" l
```
## Lang 5
### Examples
containers
- head00
data-refinement
- tuple00
- olist00
measures
- head01
- tail01
- append
### Types and Terms
```txt
d ::= [C1:t1,...] -- ^ data-definition
G ::= ...
| G, d -- ^ data-definitions
a := C(x1...) => e -- ^ switch-alternative
e :== ...
| C(x1...) -- ^ constructor
| switch(x){ a1...} -- ^ destructor
```
### Declarative Checking
#### Subtyping
```txt
G,v:int{p} |- q[w:=v] G |- si <: ti
-----------------------------------------[Sub-TCon]
G |- (C s1...)[v|p] <: (C t1...)[w|q]
```
#### Checking
Environment Extension
```txt
G(y) = s
-----------------------------[G-Scr]
G | y + 0 * t ~~> G, y:s/\t
G, z:s | y + zs * t[z/x] ~~> G'
---------------------------------[G-Ext]
G | y + z;zs * (x:s -> t) ~~> G'
```
```txt
G | y |- a_i <== t
----------------------------[Chk-Switch]
G |- switch y {a_1...} <== t
unfold(G, c, y) === s G | y + z... * s ~~> G' G' |- e <== t
----------------------------------------------------------------- [Chk-Alt]
G | y |- C z... -> e <== t
G(y) === tc[ts] G(c) === all as. t
------------------------------------- [Unfold]
unfold(g, c, y) === t [as := ts]
```
#### Synthesis
```
singleton(G, x) = v:b [p /\ v = x] if G(x) = b[v|p]
v:(c ts)[p /\ v = x] if G(x) = c ts
G(x) otherwise
```
### Algorithmic Constraints
#### Check
#### Synth
================================================
FILE: README.md
================================================
# SPRITE
A tutorial-style implementation of liquid/refinement types for a subset of Ocaml/Reason.
## Install
**1. Get Z3**
[Download from here](https://github.com/Z3Prover/z3/releases) and make sure `z3` is on your `$PATH`
**2. Clone the repository**
```
$ git clone git@github.com:ranjitjhala/sprite-lang.git
$ cd sprite-lang
```
**3. Build**
Using `stack`
```
$ stack build
```
or
```
$ cabal v2-build
```
## Run on a single file
```
$ stack exec -- sprite 8 test/L8/pos/listSet.re
```
The `8` indicates the *language-level* -- see below.
## Horn VC
When you run `sprite N path/to/file.re`
the generated Horn-VC is saved in `path/to/.liquid/file.re.smt2`.
So for example
```
$ stack exec -- sprite 8 test/L8/pos/listSet.re
```
will generate a VC in
```
test/L8/pos/.liquid/listSet.re.smt2
```
## Languages
- Lang1 : STLC + Annot (refinements 101)
- Lang2 : "" + Branches (path-sensitivity)
- Lang3 : "" + ?-refinements (inference + qual-fixpoint)
- Lang4 : "" + T-Poly (type-polymorphism)
- Lang5 : "" + Data (datatypes & measures)
- Lang6 : "" + R-Poly (refinement-polymorphism)
- Lang7 : "" + Termination (metrics + invariants)
- Lang8 : "" + Reflection (proofs)
================================================
FILE: Setup.hs
================================================
import Distribution.Simple
main = defaultMain
================================================
FILE: app/Main.hs
================================================
{-# LANGUAGE ScopedTypeVariables#-}
module Main where
import System.Environment ( getArgs )
import System.Exit ()
import Control.Monad (void)
import qualified Language.Fixpoint.Types as F
import Language.Sprite.Common (crashUserError, doOrDie)
import Language.Sprite.Common.UX ()
import qualified Language.Sprite.L1 as L1
import qualified Language.Sprite.L2 as L2
import qualified Language.Sprite.L3 as L3
import qualified Language.Sprite.L4 as L4
import qualified Language.Sprite.L5 as L5
import qualified Language.Sprite.L6 as L6
import qualified Language.Sprite.L8 as L8
---------------------------------------------------------------------------
main :: IO ()
---------------------------------------------------------------------------
main = do
args <- parseArgs
case args of
Just (i, f) -> doOrDie (sprite i f)
Nothing -> crashUserError "Invalid options!" []
parseArgs :: IO (Maybe (Int, FilePath))
parseArgs = do
args <- getArgs
case args of
[f] -> return $ Just (0, f)
n:f:_ -> return $ Just (read n :: Int, f)
_ -> return Nothing
sprite :: Int -> FilePath -> IO ()
sprite 1 = L1.sprite
sprite 2 = L2.sprite
sprite 3 = L3.sprite
sprite 4 = L4.sprite
sprite 5 = L5.sprite
sprite 6 = L6.sprite
sprite _ = L8.sprite
================================================
FILE: cabal.project
================================================
packages: .
source-repository-package
type: git
location: https://github.com/ucsd-progsys/liquid-fixpoint
tag: 794aed1388442e64ced07a7f53c5aba14ce01a24
================================================
FILE: package.yaml
================================================
name: sprite
version: 0.2.0.0
github: "ranjitjhala/sprite"
license: MIT
author: "Ranjit Jhala"
maintainer: "jhala@cs.ucsd.edu"
copyright: "2019 Ranjit Jhala"
extra-source-files:
- README.md
- ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/githubuser/sprite#readme>
dependencies:
- base >= 4.9.1.0 && < 5
- liquid-fixpoint >= 0.9
- cmdargs
- process
- directory
- filepath
- containers
- unordered-containers
- deepseq
- pretty
- parsec
- parser-combinators
- megaparsec >= 7.0.0 && < 10
- mtl
library:
source-dirs: src
executables:
sprite:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- sprite
tests:
liquid-tutorial-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- sprite
- tasty-rerun
- mtl
- stm
- tasty
- tasty-ant-xml
- tasty-hunit
- tasty-rerun
- transformers
================================================
FILE: sprite.cabal
================================================
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.36.0.
--
-- see: https://github.com/sol/hpack
name: sprite
version: 0.2.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/sprite#readme>
homepage: https://github.com/ranjitjhala/sprite#readme
bug-reports: https://github.com/ranjitjhala/sprite/issues
author: Ranjit Jhala
maintainer: jhala@cs.ucsd.edu
copyright: 2019 Ranjit Jhala
license: MIT
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
ChangeLog.md
source-repository head
type: git
location: https://github.com/ranjitjhala/sprite
library
exposed-modules:
Language.Sprite.Common
Language.Sprite.Common.Misc
Language.Sprite.Common.Parse
Language.Sprite.Common.UX
Language.Sprite.L1
Language.Sprite.L1.Check
Language.Sprite.L1.Constraints
Language.Sprite.L1.Parse
Language.Sprite.L1.Prims
Language.Sprite.L1.Types
Language.Sprite.L2
Language.Sprite.L2.Check
Language.Sprite.L2.Constraints
Language.Sprite.L2.Parse
Language.Sprite.L2.Prims
Language.Sprite.L2.Types
Language.Sprite.L3
Language.Sprite.L3.Check
Language.Sprite.L3.Constraints
Language.Sprite.L3.Parse
Language.Sprite.L3.Prims
Language.Sprite.L3.Types
Language.Sprite.L4
Language.Sprite.L4.Check
Language.Sprite.L4.Constraints
Language.Sprite.L4.Elaborate
Language.Sprite.L4.Parse
Language.Sprite.L4.Prims
Language.Sprite.L4.Types
Language.Sprite.L5
Language.Sprite.L5.Check
Language.Sprite.L5.Constraints
Language.Sprite.L5.Elaborate
Language.Sprite.L5.Parse
Language.Sprite.L5.Prims
Language.Sprite.L5.Types
Language.Sprite.L6
Language.Sprite.L6.Check
Language.Sprite.L6.Constraints
Language.Sprite.L6.Elaborate
Language.Sprite.L6.Parse
Language.Sprite.L6.Prims
Language.Sprite.L6.Types
Language.Sprite.L8
Language.Sprite.L8.Check
Language.Sprite.L8.Constraints
Language.Sprite.L8.Elaborate
Language.Sprite.L8.Parse
Language.Sprite.L8.Prims
Language.Sprite.L8.Reflect
Language.Sprite.L8.Types
other-modules:
Paths_sprite
hs-source-dirs:
src
build-depends:
base >=4.9.1.0 && <5
, cmdargs
, containers
, deepseq
, directory
, filepath
, liquid-fixpoint >=0.9
, megaparsec >=7.0.0 && <10
, mtl
, parsec
, parser-combinators
, pretty
, process
, unordered-containers
default-language: Haskell2010
executable sprite
main-is: Main.hs
other-modules:
Paths_sprite
hs-source-dirs:
app
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.9.1.0 && <5
, cmdargs
, containers
, deepseq
, directory
, filepath
, liquid-fixpoint >=0.9
, megaparsec >=7.0.0 && <10
, mtl
, parsec
, parser-combinators
, pretty
, process
, sprite
, unordered-containers
default-language: Haskell2010
test-suite liquid-tutorial-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_sprite
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.9.1.0 && <5
, cmdargs
, containers
, deepseq
, directory
, filepath
, liquid-fixpoint >=0.9
, megaparsec >=7.0.0 && <10
, mtl
, parsec
, parser-combinators
, pretty
, process
, sprite
, stm
, tasty
, tasty-ant-xml
, tasty-hunit
, tasty-rerun
, transformers
, unordered-containers
default-language: Haskell2010
================================================
FILE: sprite.cabal.orig
================================================
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: d386618d61376de83f983dcbccf020e50d0bbac3bde98b667b01117472310880
name: sprite
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/sprite#readme>
homepage: https://github.com/ranjitjhala/sprite#readme
bug-reports: https://github.com/ranjitjhala/sprite/issues
author: Ranjit Jhala
maintainer: jhala@cs.ucsd.edu
copyright: 2019 Ranjit Jhala
license: MIT
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
ChangeLog.md
source-repository head
type: git
location: https://github.com/ranjitjhala/sprite
library
exposed-modules:
Language.Sprite.Common
Language.Sprite.Common.Misc
Language.Sprite.Common.Parse
Language.Sprite.Common.UX
Language.Sprite.L1
Language.Sprite.L1.Check
Language.Sprite.L1.Constraints
Language.Sprite.L1.Parse
Language.Sprite.L1.Prims
Language.Sprite.L1.Types
Language.Sprite.L2
Language.Sprite.L2.Check
Language.Sprite.L2.Constraints
Language.Sprite.L2.Parse
Language.Sprite.L2.Prims
Language.Sprite.L2.Types
Language.Sprite.L3
Language.Sprite.L3.Check
Language.Sprite.L3.Constraints
Language.Sprite.L3.Parse
Language.Sprite.L3.Prims
Language.Sprite.L3.Types
Language.Sprite.L4
Language.Sprite.L4.Check
Language.Sprite.L4.Constraints
Language.Sprite.L4.Elaborate
Language.Sprite.L4.Parse
Language.Sprite.L4.Prims
Language.Sprite.L4.Types
Language.Sprite.L5
Language.Sprite.L5.Check
Language.Sprite.L5.Constraints
Language.Sprite.L5.Elaborate
Language.Sprite.L5.Parse
Language.Sprite.L5.Prims
Language.Sprite.L5.Types
Language.Sprite.L6
Language.Sprite.L6.Check
Language.Sprite.L6.Constraints
Language.Sprite.L6.Elaborate
Language.Sprite.L6.Parse
Language.Sprite.L6.Prims
Language.Sprite.L6.Types
Language.Sprite.L8
Language.Sprite.L8.Check
Language.Sprite.L8.Constraints
Language.Sprite.L8.Elaborate
Language.Sprite.L8.Parse
Language.Sprite.L8.Prims
Language.Sprite.L8.Reflect
Language.Sprite.L8.Types
other-modules:
Paths_sprite
hs-source-dirs:
src
build-depends:
base >= 4.9.1.0 && < 5
, cmdargs
, containers
, deepseq
, directory
, filepath
, liquid-fixpoint >=0.8.10.7.0
, megaparsec >= 7.0.0 && < 10
, mtl
, parsec
, parser-combinators
, pretty
, process
, unordered-containers
default-language: Haskell2010
executable sprite
main-is: Main.hs
other-modules:
Paths_sprite
hs-source-dirs:
app
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, cmdargs
, containers >= 0.5
, deepseq
, directory
, filepath
, liquid-fixpoint >=0.8
, megaparsec >=7.0.0 && < 10
, mtl
, parsec
, parser-combinators
, pretty
, process
, sprite
, unordered-containers
default-language: Haskell2010
test-suite liquid-tutorial-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_sprite
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, cmdargs
, containers >= 0.5
, deepseq
, directory
, filepath
, liquid-fixpoint >=0.8
, megaparsec >=7.0.0 && < 10
, mtl
, parsec
, parser-combinators
, pretty
, process
, sprite
, stm
, tasty
, tasty-ant-xml
, tasty-hunit
, tasty-rerun
, transformers
, unordered-containers
default-language: Haskell2010
================================================
FILE: src/Language/Sprite/Common/Misc.hs
================================================
module Language.Sprite.Common.Misc where
import qualified Data.Map as M
import qualified Data.List as L
-- import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.Char (isSpace)
import Control.Exception
import Control.Monad
import Text.Printf
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process
import System.Timeout
import System.Console.CmdArgs.Verbosity (whenLoud)
import Debug.Trace (trace)
safeZip :: [a] -> [b] -> Maybe [(a, b)]
safeZip xs ys
| length xs == length ys = Just (zip xs ys)
| otherwise = Nothing
--------------------------------------------------------------------------------
(>->) :: (a -> Either e b) -> (b -> c) -> a -> Either e c
--------------------------------------------------------------------------------
f >-> g = f >=> safe g
where
safe :: (a -> b) -> a -> Either c b
safe h x = Right (h x)
groupBy :: (Ord k) => (a -> k) -> [a] -> [(k, [a])]
groupBy f = M.toList . L.foldl' (\m x -> inserts (f x) x m) M.empty
inserts :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v]
inserts k v m = M.insert k (v : M.findWithDefault [] k m) m
mapSnd :: (b -> c) -> (a, b) -> (a, c)
mapSnd f (x, y) = (x, f y)
-- >>> dupBy fst [(1, "one"), (2, "two"), (3, "three"), (1, "uno")]
-- [[(1,"uno"),(1,"one")]]
--
-- >>> dupBy fst [(1, "one"), (2, "two"), (3, "three")]
-- []
dupBy :: (Ord k) => (a -> k) -> [a] -> [[a]]
dupBy f xs = [ xs' | (_, xs') <- groupBy f xs, 2 <= length xs' ]
trim :: String -> String
trim = f . f where f = reverse . dropWhile isSpace
trimEnd :: String -> String
trimEnd = reverse . dropWhile isSpace . reverse
executeShellCommand :: FilePath -> String -> Int -> IO ExitCode
executeShellCommand logF cmd n = fromMaybe (ExitFailure 100) <$> body
where
body = timeout n . withFile logF AppendMode $ \h -> do
let p = (shell cmd) {std_out = UseHandle h, std_err = UseHandle h}
(_,_,_,ph) <- createProcess p
waitForProcess ph
data Phase = Start | Stop deriving (Show)
phase :: Phase -> String -> IO ()
phase p msg = putStrLn $ printf "**** %s : %s **************************************" (show p) msg
writeLoud :: String -> IO ()
writeLoud s = whenLoud $ putStrLn s >> hFlush stdout
ensurePath :: FilePath -> IO ()
ensurePath = createDirectoryIfMissing True . takeDirectory
safeReadFile :: FilePath -> IO (Either String String)
safeReadFile f = (Right <$> readFile f) `catch` handleIO f
handleIO :: FilePath -> IOException -> IO (Either String a)
handleIO f e = return . Left $ "Warning: Couldn't open " <> f <> ": " <> show e
traceShow :: (Show a) => String -> a -> a
traceShow msg x = x -- trace (printf "TRACE: %s = %s" msg (show x)) x
safeHead :: a -> [a] -> a
safeHead def [] = def
safeHead _ (x:_) = x
getRange :: Int -> Int -> [a] -> [a]
getRange i1 i2
= take (i2 - i1 + 1)
. drop (i1 - 1)
================================================
FILE: src/Language/Sprite/Common/Parse.hs
================================================
module Language.Sprite.Common.Parse where
import qualified Data.Maybe as Mb
import qualified Data.Set as S
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Parse as FP
import qualified Language.Fixpoint.Types.Visitor as FV
import Text.Megaparsec ( (<|>) )
withSpan' :: FP.Parser (F.SrcSpan -> a) -> FP.Parser a
withSpan' p = do
F.Loc l1 l2 f <- FP.located p
pure (f (F.SS l1 l2))
-- | `identifier` parses identifiers: lower-case alphabets followed by alphas or digits
identifier :: FP.Parser F.Symbol
identifier = FP.lowerIdP
identifier' :: FP.Parser F.Symbol
identifier' = FP.lowerIdP <|> FP.upperIdP
parens = FP.parens
colon = FP.colon
comma = FP.comma
braces = FP.braces
reserved = FP.reserved
brackets = FP.brackets
whiteSpace = FP.spaces
reservedOp = FP.reservedOp
-- | list of reserved words
keywords :: S.Set String
keywords = S.fromList
[ "if" , "else"
, "true" , "false"
, "let" , "in"
, "int"
]
isKey :: String -> Bool
isKey x = S.member x keywords
---------------------------------------------------------------------------------------------------------
-- | Pesky hack to work around FP.exprP parsing "foo(x, y, z)" as "foo ((,,) x y z)"
---------------------------------------------------------------------------------------------------------
myPredP :: FP.Parser F.Expr
myPredP = unTupleApp <$> FP.predP
myExprP :: FP.Parser F.Expr
myExprP = unTupleApp <$> FP.exprP
unTupleApp :: F.Expr -> F.Expr
unTupleApp = FV.mapExpr go
where
go e@(F.EApp {}) = Mb.fromMaybe e (unTuple e)
go e = e
unTuple :: F.Expr -> Maybe F.Expr
unTuple e =
case F.splitEApp e of
(f, [arg]) ->
case F.splitEApp arg of
(t, args) -> if isTupleCon (length args) t
then Just (F.eApps f args)
else Nothing
_ -> Nothing
isTupleCon :: Int -> F.Expr -> Bool
isTupleCon n (F.EVar x) = x == tupleSym n
isTupleCon _ _ = False
tupleSym :: Int -> F.Symbol
tupleSym n = F.symbol $ "(" ++ replicate (n-1) ',' ++ ")"
---------------------------------------------------------------------------------------------------------
================================================
FILE: src/Language/Sprite/Common/UX.hs
================================================
-- | This module contains the code for all the user (programmer) facing
-- aspects, i.e. error messages, source-positions, overall results.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Eta reduce" #-}
module Language.Sprite.Common.UX
(
-- * Extraction from Source file
readFileSpan
-- * Constructing spans
, posSpan
, junkSpan
-- * Success and Failure
, UserError
, eMsg
, eSpan
, Result
-- * Throwing & Handling Errors
, mkError
, spanError
, abort
, panic
, panicS
, renderErrors
, fpUserError
-- * Pretty Printing
, Text
, PPrint (..)
, tshow
) where
import Control.Exception
import Control.DeepSeq
import Data.Typeable
-- import qualified Data.List as L
import GHC.Generics
import Text.Printf (printf)
import qualified Text.PrettyPrint.HughesPJ as PJ
import qualified Language.Fixpoint.Misc as Misc
import qualified Language.Fixpoint.Types as F
import Language.Fixpoint.Types (PPrint (..))
import Language.Sprite.Common.Misc
type Text = PJ.Doc
tshow :: (Show a) => a -> PJ.Doc
tshow = PJ.text . show
--------------------------------------------------------------------------------
-- | Source Span Representation
--------------------------------------------------------------------------------
-- instance NFData F.SrcSpan
instance Semigroup F.SrcSpan where
(<>) = mappendSpan
instance Monoid F.SrcSpan where
mempty = junkSpan
mappendSpan :: F.SrcSpan -> F.SrcSpan -> F.SrcSpan
mappendSpan s1 s2
| s1 == junkSpan = s2
| s2 == junkSpan = s1
| otherwise = F.SS (F.sp_start s1) (F.sp_stop s2)
spanInfo :: F.SrcSpan -> (FilePath, Int, Int, Int, Int)
spanInfo s = (f, F.unPos l1, F.unPos c1, F.unPos l2, F.unPos c2)
where
(f,l1,c1) = F.sourcePosElts (F.sp_start s)
(_,l2,c2) = F.sourcePosElts (F.sp_stop s)
--------------------------------------------------------------------------------
-- | Source Span Extraction
--------------------------------------------------------------------------------
readFileSpan :: F.SrcSpan -> IO String
--------------------------------------------------------------------------------
readFileSpan sp = getSpan sp <$> readFile (spanFile sp)
spanFile :: F.SrcSpan -> FilePath
spanFile = Misc.fst3 . F.sourcePosElts . F.sp_start
getSpan :: F.SrcSpan -> String -> String
getSpan sp
| l1 == l2 = getSpanSingle l1 c1 c2
| otherwise = getSpanMulti l1 l2
where
(_, l1, c1, l2, c2) = spanInfo sp
getSpanSingle :: Int -> Int -> Int -> String -> String
getSpanSingle l c1 c2
= highlight l c1 c2
. safeHead ""
. getRange l l
. lines
getSpanMulti :: Int -> Int -> String -> String
getSpanMulti l1 l2
= highlights l1
. getRange l1 l2
. lines
highlight :: Int -> Int -> Int -> String -> String
highlight l c1 c2 s = unlines
[ cursorLine l s
, replicate (12 + c1) ' ' ++ replicate (1 + c2 - c1) '^'
]
highlights :: Int -> [String] -> String
highlights i ls = unlines $ zipWith cursorLine [i..] ls
cursorLine :: Int -> String -> String
cursorLine l s = printf "%s| %s" (lineString l) s
lineString :: Int -> String
lineString n = replicate (10 - nD) ' ' ++ nS
where
nS = show n
nD = length nS
--------------------------------------------------------------------------------
-- | Source Span Construction
--------------------------------------------------------------------------------
posSpan :: F.SourcePos -> F.SrcSpan
--------------------------------------------------------------------------------
posSpan p = F.SS p p
junkSpan :: F.SrcSpan
junkSpan = F.dummySpan -- posSpan (initialPos "unknown")
--------------------------------------------------------------------------------
-- | Representing overall failure / success
--------------------------------------------------------------------------------
type Result a = Either [UserError] a
--------------------------------------------------------------------------------
-- | Representing (unrecoverable) failures
--------------------------------------------------------------------------------
data UserError = Error
{ eMsg :: !Text
, eSpan :: !F.SrcSpan
}
deriving (Show, Typeable, Generic)
instance F.PPrint UserError where
pprintTidy k = F.pprintTidy k . userErrorFP
instance F.Fixpoint UserError where
toFix = eMsg
instance F.Loc UserError where
srcSpan = eSpan
instance NFData UserError
instance Exception [UserError]
fpUserError :: F.Error1 -> UserError
fpUserError e = mkError (F.errMsg e) (F.errLoc e)
userErrorFP :: UserError -> F.Error
userErrorFP (Error d sp) = F.err sp d
--------------------------------------------------------------------------------
panic :: PJ.Doc -> F.SrcSpan -> a
--------------------------------------------------------------------------------
panic msg sp = throw [Error msg sp]
panicS :: String -> F.SrcSpan -> a
panicS = panic . PJ.text
--------------------------------------------------------------------------------
abort :: UserError -> b
--------------------------------------------------------------------------------
abort e = throw [e]
--------------------------------------------------------------------------------
mkError :: Text -> F.SrcSpan -> UserError
--------------------------------------------------------------------------------
mkError = Error
--------------------------------------------------------------------------------
spanError :: F.SrcSpan -> UserError
--------------------------------------------------------------------------------
spanError = mkError mempty
renderErrors :: [UserError] -> IO Text
renderErrors es = do
errs <- mapM renderError es
return $ PJ.vcat ("Errors found!" : "" : errs)
-- return $ L.intercalate "\n" ("Errors found!" : errs)
renderError :: UserError -> IO Text
renderError e = do
let sp = F.srcSpan e
snippet <- readFileSpan sp
return $ PJ.vcat [ F.pprint sp PJ.<> ":" PJ.<+> eMsg e
, " "
, " "
, PJ.text snippet ]
================================================
FILE: src/Language/Sprite/Common.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Eta reduce" #-}
-- | Some types that are common to all languages -------------------------------
module Language.Sprite.Common where
import System.Exit ( ExitCode, exitWith )
import Control.Exception ( catch )
import Control.Monad (when)
import qualified Data.Maybe as Mb
import qualified Text.PrettyPrint.HughesPJ as PJ
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Horn.Solve as H
import qualified Language.Fixpoint.Types.Config as FC
import qualified Language.Fixpoint.Types.Errors as F
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Misc as F
import qualified Language.Fixpoint.Utils.Files as F
import qualified Language.Sprite.Common.UX as UX
import Language.Fixpoint.Solver.Interpreter (Simplifiable(simplify))
type SrcCstr = H.Cstr UX.UserError
type SrcQuery = H.Query UX.UserError
type SrcResult = F.FixResult UX.UserError
type SrcHVar = H.Var UX.UserError
---------------------------------------------------------------------------
query :: [F.Qualifier] -> [H.Var a] -> H.Cstr a -> H.Query a
---------------------------------------------------------------------------
query qs ks c = H.Query qs ks c mempty mempty mempty mempty mempty mempty
---------------------------------------------------------------------------
bind :: F.SrcSpan -> F.Symbol -> F.Sort -> H.Pred -> H.Bind UX.UserError
---------------------------------------------------------------------------
bind sp x t p = H.Bind x t p (UX.mkError mempty sp)
---------------------------------------------------------------------------
crash :: [UX.UserError] -> String -> SrcResult
---------------------------------------------------------------------------
crash errs = F.Crash [(e, Nothing) | e <- errs]
class Label t where
label :: t a -> a
---------------------------------------------------------------------------
doOrDie :: IO a -> IO a
---------------------------------------------------------------------------
doOrDie act = act `catch` crashFPError "Parse error"
`catch` crashUserError "Unexpected error"
crashFPError :: String -> F.Error -> IO a
crashFPError msg ferr = crashUserError msg (UX.fpUserError <$> F.errs (F.traceShow "WTF" ferr))
crashUserError :: String -> [UX.UserError] -> IO a
crashUserError msg es = exitWith =<< resultExit (F.Crash [(e, Nothing) | e <- es] msg)
---------------------------------------------------------------------------
checkValid :: FilePath -> SrcQuery -> IO SrcResult
---------------------------------------------------------------------------
checkValid f = checkValidWithCfg f fpConfig
---------------------------------------------------------------------------
checkValidPLE :: FilePath -> SrcQuery -> IO SrcResult
---------------------------------------------------------------------------
checkValidPLE f q = do
pleCfg <- FC.withPragmas fpConfig ["--rewrite"]
checkValidWithCfg f pleCfg q
checkValidWithCfg :: FilePath -> FC.Config -> SrcQuery -> IO SrcResult
checkValidWithCfg f cfg q0 = do
let q = simplifyQuery q0
dumpQuery f q
fmap snd . F.resStatus <$> H.solve cfg q
fpConfig :: FC.Config
fpConfig = FC.defConfig
{ FC.eliminate = FC.Some }
dumpQuery :: FilePath -> SrcQuery -> IO ()
dumpQuery f q = when True $ do
putStrLn (F.wrapStars "BEGIN: Horn VC")
let smtFile = F.extFileName F.Smt2 f
F.ensurePath smtFile
writeFile smtFile (PJ.render . F.pprint $ q)
putStrLn (F.wrapStars "END: Horn VC")
simplifyQuery :: H.Query a -> H.Query a
simplifyQuery q = q { H.qCstr = simplifyConstraint (H.qCstr q) }
simplifyConstraint :: H.Cstr a -> H.Cstr a
simplifyConstraint c = Mb.fromMaybe trivial (go c)
where
trivial = H.CAnd []
go :: H.Cstr a -> Maybe (H.Cstr a)
go (H.CAnd cs) = case Mb.mapMaybe go cs of
[] -> Nothing
[c] -> Just c
cs' -> Just (H.CAnd cs')
go (H.All b c) = H.All b <$> go c
go (H.Head (H.Reft p) _)
| F.isTautoPred p = Nothing
go c = Just c
---------------------------------------------------------------------------
resultExit :: SrcResult -> IO ExitCode
---------------------------------------------------------------------------
resultExit r = do
F.colorStrLn (F.colorResult r) (resultStr r)
case resultErrs r of
[] -> return ()
es -> putStrLn . PJ.render =<< UX.renderErrors es
return (F.resultExit r)
resultErrs :: SrcResult -> [UX.UserError]
resultErrs (F.Unsafe _ es) = es
resultErrs (F.Crash es _) = fst <$> es
resultErrs _ = []
resultStr :: SrcResult -> String
resultStr (F.Safe {}) = "Safe"
resultStr (F.Unsafe {}) = "Unsafe"
resultStr (F.Crash _ msg) = "Crash!: " ++ msg
---------------------------------------------------------------------------------
nat :: F.Expr -> F.Expr
nat p = F.PAtom F.Le (F.ECon (F.I 0)) p
lt :: F.Expr -> F.Expr -> F.Expr
lt e1 e2 = F.PAtom F.Lt e1 e2
eq :: (F.Expression a, F.Expression b) => a -> b -> F.Expr
eq e1 e2 = F.PAtom F.Eq (F.expr e1) (F.expr e2)
---------------------------------------------------------------------------------
-- predApp f xs = F.eApps (F.expr f) (F.expr <$> xs)
predApp :: (F.Expression e) => F.Symbol -> [e] -> F.Expr
predApp f xs = F.eApps (F.expr pn) (F.expr f : (F.expr <$> xs))
where
pn = pappSym n
n = length xs
pappSym :: Int -> F.Symbol
pappSym n = F.symbol $ "papp" ++ show n
pappSortArgs :: Int -> [F.Sort] -> F.Sort
pappSortArgs tvars args = F.mkFFunc tvars $ ptycon : args ++ [F.boolSort]
where
ptycon = F.fAppTC predFTyCon args
pappSort :: Int -> F.Sort
pappSort n = pappSortArgs n (pappArgs n)
pappArgs :: Int -> [F.Sort]
pappArgs n = F.FVar <$> [0 .. n-1]
pappQual :: Int -> F.Qualifier
pappQual n = F.mkQ name (vt : args ++ [(p, pt)]) pred pos
where
pt = F.fAppTC predFTyCon (snd <$> args ++ [vt])
name = F.symbol ("PApp" ++ show n)
vt = (F.vv Nothing, F.FVar (n-1))
args = [ (x i, F.FVar i) | i <- [0 .. n-2] ]
p = "p"
x i = F.symbol ("x" ++ show i)
pred = predApp p (fst <$> (args ++ [vt]))
pos = F.dummyPos "pappQual"
predFTyCon :: F.FTycon
predFTyCon = F.symbolFTycon (F.dummyLoc "Pred")
================================================
FILE: src/Language/Sprite/L1/Check.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L1.Check (vcgen) where
import Control.Monad (void)
import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L1.Types
import Language.Sprite.L1.Prims
import Language.Sprite.L1.Constraints
-------------------------------------------------------------------------------
vcgen:: SrcExpr -> Either [UX.UserError] SrcQuery
-------------------------------------------------------------------------------
vcgen e = query [] [] <$> check empEnv e (bTrue TInt)
-- | CG Monad -----------------------------------------------------------------
type CG a = Either [UX.UserError] a
failWith :: UX.Text -> F.SrcSpan -> CG a
failWith msg l = Left [UX.mkError msg l]
-------------------------------------------------------------------------------
sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr
-------------------------------------------------------------------------------
{- | [Sub-Base]
(v::t) => q[w := v]
-------------------
b{v:p} <= b{w:q}
-}
sub l s@(TBase b1 (F.Reft (v, _))) (TBase b2 (F.Reft (w, q)))
| b1 == b2 = return (cAll l v s (cHead l (subst q w v)))
| otherwise = failWith "Invalid Subtyping" l
{- | [Sub-Fun]
(v::t) => q[w := v]
-------------------
b{v:p} <: b{w:q}
s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2
-------------------------------------
x1:s1 -> t1 <: x2:s2 -> t2
-}
sub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
cI <- sub l s2 s1
cO <- cAll l x2 t2 <$> sub l t1' t2
return (cAnd cI cO)
where
t1' = subst t1 x1 x2
--------------------------------------------------------------------
-- | 'Checking' constraints
--------------------------------------------------------------------
check :: Env -> SrcExpr -> RType -> CG SrcCstr
--------------------------------------------------------------------
{- [Chk-Lam]
G, x:s |- e <== t
--------------------------
G |- \x.e <== x:s -> t
-}
check g (EFun bx e l) (TFun y s t) | y == x = do
c <- check (extEnv g bx s) e t
return $ cAll l x s c
where
x = bindId bx
{- [Chk-Let]
G |- e1 ==> t1 G, x:t1 |- e2 <== t2
-------------------------------------------
G |- let x = e1 in e2 <== t2
-}
check g (ELet (Decl bx@(Bind x l) e _) e' _) t' = do
(c, s) <- synth g e
c' <- check (extEnv g bx s) e' t'
return $ cAnd c (cAll l x s c')
{- [Chk-Syn]
G |- e ==> s G |- s <: t
----------------------------------[Chk-Syn]
G |- e <== t
-}
check g e t = do
let l = label e
(c, s) <- synth g e
c' <- sub l s t
return (cAnd c c')
{- [Chk-Syn-Imm] -}
checkImm :: Env -> SrcImm -> RType -> CG SrcCstr
checkImm g i t = do
s <- synthImm g i
sub (label i) s t
--------------------------------------------------------------------
-- | 'Synthesis' constraints
--------------------------------------------------------------------
synthImm :: Env -> SrcImm -> CG RType
{- [Syn-Var]
-----------------
G |- x ==> G(x)
-}
synthImm g (EVar x l)
| Just t <- getEnv g x = return t
| otherwise = failWith ("Unbound variable:" <+> F.pprint x) l
{- [Syn-Con]
-----------------
G |- x ==> ty(c)
-}
synthImm g (ECon c l) = return (constTy l c)
synth :: Env -> SrcExpr -> CG (SrcCstr, RType)
{- [Syn-Con], [Syn-Var] -}
synth g (EImm i _) = do
t <- synthImm g i
return (cTrue, t)
{- [Syn-Ann]
G |- e <== t
-----------------
G |- e:t => t
-}
synth g (EAnn e t _) = do
c <- check g e t
return (c, t)
{- [Syn-App]
G |- e ==> x:s -> t
G |- y <== s
-----------------------
G |- e y ==> t[x := y]
-}
synth g (EApp e y l) = do
(ce, te) <- synth g e
case te of
TFun x s t -> do cy <- checkImm g y s
return (cAnd ce cy, substImm t x y)
_ -> failWith "Application to non-function" l
synth _ e =
failWith ("synth: cannot handle: " <+> text (show (void e) )) (label e)
================================================
FILE: src/Language/Sprite/L1/Constraints.hs
================================================
-- | This module has the kit needed to do constraint generation:
-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L1.Constraints
( -- * Constraints
cTrue, cAnd, cHead, cAll
-- * Substitutions
, subst, substImm
-- * Environments
, Env, empEnv, getEnv, extEnv
) where
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L1.Types
--------------------------------------------------------------------------------
-- | Constraints ---------------------------------------------------------------
--------------------------------------------------------------------------------
cTrue :: SrcCstr
cTrue = H.CAnd []
cAnd :: SrcCstr -> SrcCstr -> SrcCstr
cAnd c1 c2 = H.CAnd [c1, c2]
cHead :: F.SrcSpan -> F.Expr -> SrcCstr
cHead l e = H.Head (H.Reft e) (UX.mkError "Subtype error" l)
cAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr
cAll sp x t c = case sortPred x t of
Just (so, p) -> H.All (bind sp x so p) c
_ -> c
sortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)
sortPred x (TBase b (F.Reft (v, p))) = Just (baseSort b, H.Reft (subst p v x))
sortPred x _ = Nothing
baseSort :: Base -> F.Sort
baseSort TInt = F.intSort
--------------------------------------------------------------------------------
-- | Substitution --------------------------------------------------------------
--------------------------------------------------------------------------------
substImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a
substImm thing x y = F.subst su thing
where
su = F.mkSubst [(x, immExpr y)]
subst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a
subst thing x y = substImm thing x (EVar y ())
immExpr :: Imm b -> F.Expr
immExpr (EVar x _) = F.expr x
immExpr (ECon (PInt n) _) = F.expr n
--------------------------------------------------------------------------------
-- | Environments --------------------------------------------------------------
--------------------------------------------------------------------------------
type Env = F.SEnv RType
extEnv :: Env -> Bind a -> RType -> Env
extEnv env bx t = F.insertSEnv (bindId bx) t env
getEnv :: Env -> F.Symbol -> Maybe RType
getEnv env x = F.lookupSEnv x env
empEnv :: Env
empEnv = F.emptySEnv
================================================
FILE: src/Language/Sprite/L1/Parse.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Language.Sprite.L1.Parse
(
-- * Parsing programs
parseFile
, parseWith
-- * Parsing combinators
, rtype
, expr
) where
import qualified Data.Set as S
import qualified Data.List as L
import Control.Monad.Combinators.Expr
import Text.Megaparsec hiding (State, label)
import Text.Megaparsec.Char
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Parse as FP
import Language.Sprite.Common
import Language.Sprite.Common.Parse
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.L1.Types
parseFile :: FilePath -> IO SrcExpr
parseFile = FP.parseFromFile prog
parseWith :: FP.Parser a -> FilePath -> String -> a
parseWith = FP.doParse'
--------------------------------------------------------------------------------
-- | Top-Level Expression Parser
--------------------------------------------------------------------------------
prog :: FP.Parser SrcExpr
prog = declsExpr <$> many decl
expr :: FP.Parser SrcExpr
expr = makeExprParser expr1 binOps
binOps =
[ [InfixR (FP.reservedOp "*" >> pure (op BTimes)) ]
, [InfixR (FP.reservedOp "+" >> pure (op BPlus)) ]
, [InfixL (FP.reservedOp "-" >> pure (op BMinus)) ]
]
op :: PrimOp -> SrcExpr -> SrcExpr -> SrcExpr
op o e1 e2 = case (e1, e2) of
(EImm x lx, EImm y ly) -> mkEApp (EImm (ECon (PBin o) l) l) [x, y]
_ -> UX.panic "Prim-Ops only on variables" l
where
l = stretch [e1, e2]
mkEApp :: SrcExpr -> [SrcImm] -> SrcExpr
mkEApp = L.foldl' (\e y -> EApp e y (label e <> label y))
expr1 :: FP.Parser SrcExpr
expr1 = try appExpr
<|> expr0
expr0 :: FP.Parser SrcExpr
expr0 = try funExpr
<|> letExpr
-- <|> try ifExpr
<|> FP.parens expr
<|> FP.braces expr
<|> immExpr
letExpr :: FP.Parser SrcExpr
letExpr = withSpan' (ELet <$> decl <*> expr)
immExpr :: FP.Parser SrcExpr
immExpr = do
i <- imm
return (EImm i (label i))
imm :: FP.Parser SrcImm
imm = withSpan' $ (EVar <$> identifier) <|> (ECon . PInt <$> FP.natural )
funExpr :: FP.Parser SrcExpr
funExpr = withSpan' $ do
xs <- FP.parens (sepBy1 binder FP.comma)
_ <- FP.reservedOp "=>"
body <- expr
return $ mkEFun xs body
mkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr
mkEFun bs e0 l = foldr (\b e -> EFun b e l) e0 bs
appExpr :: FP.Parser SrcExpr
appExpr = mkEApp <$> expr0 <*> FP.parens (sepBy1 imm FP.comma)
-- | Annotated declaration
decl :: FP.Parser SrcDecl
decl = mkDecl <$> ann <*> plainDecl
type Ann = Maybe (F.Symbol, RType)
ann :: FP.Parser Ann
-- ann = (FP.reservedOp "/*@" >> (Just <$> annot)) <|> pure Nothing
ann = (FP.reserved "/*@" >> (Just <$> annot)) <|> pure Nothing
annot :: FP.Parser (F.Symbol, RType)
annot = do
FP.reserved "val"
x <- identifier
FP.colon
t <- rtype
FP.reservedOp "*/"
return (x, t)
mkDecl :: Ann -> SrcDecl -> SrcDecl
mkDecl (Just (x, t)) (Decl b e l)
| x == bindId b = Decl b (EAnn e t (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl Nothing d = d
plainDecl :: FP.Parser SrcDecl
plainDecl = withSpan' $ do
FP.reserved "let"
b <- binder
FP.reservedOp "="
e <- expr
FP.semi
return (Decl b e)
-- | `binder` parses SrcBind, used for let-binds and function parameters.
binder :: FP.Parser SrcBind
binder = withSpan' (Bind <$> identifier)
pairSpan :: FP.Parser a -> FP.Parser (a, F.SrcSpan)
pairSpan p = withSpan' $ do
x <- p
return (x,)
isKey :: String -> Bool
isKey x = S.member x keywords
stretch :: (Label t, Monoid a) => [t a] -> a
stretch = mconcat . fmap label
--------------------------------------------------------------------------------
-- | Top level Rtype parser
--------------------------------------------------------------------------------
rtype :: FP.Parser RType
rtype = try rfun
<|> rtype0
rtype0 :: FP.Parser RType
rtype0 = FP.parens rtype
<|> rbase
rfun :: FP.Parser RType
rfun = mkTFun <$> funArg <*> (FP.reservedOp "=>" *> rtype)
funArg :: FP.Parser (F.Symbol, RType)
funArg = try ((,) <$> FP.lowerIdP <*> (FP.colon *> rtype0))
<|> ((,) <$> freshArgSymbolP <*> rtype0)
freshArgSymbolP :: FP.Parser F.Symbol
freshArgSymbolP = do
n <- FP.freshIntP
return $ F.symbol ("_arg" ++ show n)
mkTFun :: (F.Symbol, RType) -> RType -> RType
mkTFun (x, s) = TFun x s
rbase :: FP.Parser RType
rbase = TBase <$> tbase <*> refTop
tbase :: FP.Parser Base
tbase = FP.reserved "int" >> pure TInt
refTop :: FP.Parser F.Reft
refTop = FP.brackets reftB <|> pure mempty
reftB :: FP.Parser F.Reft
reftB = mkReft <$> (FP.lowerIdP <* mid) <*> FP.predP
mkReft :: F.Symbol -> F.Pred -> F.Reft
mkReft x r = F.Reft (x, r)
mid :: FP.Parser ()
mid = FP.reservedOp "|"
-- >>> (parseWith rtype "" "int{v|v = 3}")
-- TBase TInt (v = 3)
-- >>> (parseWith rtype "" "int{v|v = x + y}")
-- TBase TInt (v = (x + y))
-- >>> (parseWith rtype "" "int")
-- TBase TInt true
-- >>> parseWith funArg "" "x:int"
-- ("x",TBase TInt true)
-- >>> parseWith rfun "" "int => int"
-- TFun "_" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int"
-- TFun "x" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int{v|0 < v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 < v))
-- >>> parseWith rfun "" "x:int => int{v|0 <= v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 <= v))
-- >>> parseWith rfun "" "x:int{v|0 <= v} => int{v|0 <= v}"
-- TFun "x" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))
-- >>> parseWith ann "" "/*@ val inc: x:int => int[v|v = x + 1] */"
================================================
FILE: src/Language/Sprite/L1/Prims.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L1.Prims where
import qualified Data.Maybe as Mb
import qualified Data.Map as M
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.L1.Types
import Language.Sprite.L1.Parse
-- | Primitive Types --------------------------------------------------
constTy :: F.SrcSpan -> Prim -> RType
constTy _ (PInt n) = TBase TInt (F.exprReft (F.expr n))
constTy l (PBin o) = binOpTy l o
binOpTy :: F.SrcSpan -> PrimOp -> RType
binOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv)
where
err = UX.panicS ("Unknown PrimOp: " ++ show o) l
bTrue :: Base -> RType
bTrue b = TBase b mempty
binOpEnv :: M.Map PrimOp RType
binOpEnv = M.fromList
[ (BPlus , mkTy "x:int => y:int => int[v|v=x+y]")
, (BMinus, mkTy "x:int => y:int => int[v|v=x-y]")
, (BTimes, mkTy "x:int => y:int => int[v|v=x*y]")
-- , (BLt , mkTy "x:int => y:int => bool{v|v <=> (x < y)}")
-- , (BGt , mkTy "x:int => y:int => bool{v|v <=> (x > y)}")
-- , (BEq , mkTy "x:int => y:int => bool{v|v <=> (x = y)}")
]
mkTy :: String -> RType
mkTy = parseWith rtype "prims"
================================================
FILE: src/Language/Sprite/L1/Types.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
module Language.Sprite.L1.Types where
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common.Misc
import Language.Sprite.Common
-- | Basic types --------------------------------------------------------------
data Base = TInt
deriving (Eq, Ord, Show)
-- | Refined Types ------------------------------------------------------------
data Type r
= TBase !Base r -- Int{r}
| TFun !F.Symbol !(Type r) !(Type r) -- x:s -> t
deriving (Eq, Ord, Show)
type RType = Type F.Reft
-- | Primitive Constants ------------------------------------------------------
data PrimOp
= BPlus
| BMinus
| BTimes
| BLt
| BGt
| BEq
deriving (Eq, Ord, Show)
data Prim
= PInt Integer
| PBin !PrimOp
deriving (Eq, Ord, Show)
-- | Terms --------------------------------------------------------------------
data Decl a = Decl (Bind a) (Expr a) a
deriving (Show, Functor)
data Bind a
= Bind !F.Symbol a
deriving (Eq, Ord, Show, Functor)
bindId :: Bind a -> F.Symbol
bindId (Bind x _) = x
data Imm a
= EVar !F.Symbol a
| ECon !Prim a
deriving (Show, Functor)
data Expr a
= EImm !(Imm a) a
| EFun !(Bind a) !(Expr a) a
| EApp !(Expr a) !(Imm a) a
| ELet !(Decl a) !(Expr a) a
| EAnn !(Expr a) !RType a
deriving (Show, Functor)
instance Label Imm where
label (EVar _ l) = l
label (ECon _ l) = l
instance Label Expr where
label (EImm _ l) = l
label (EFun _ _ l) = l
label (EApp _ _ l) = l
label (ELet _ _ l) = l
label (EAnn _ _ l) = l
instance Label Decl where
label (Decl _ _ l) = l
------------------------------------------------------------------------------
declsExpr :: [Decl a] -> Expr a
------------------------------------------------------------------------------
declsExpr [d] = ELet d (intExpr 0 l) l where l = label d
declsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d
declsExpr _ = UX.panic "declsExpr with empty declarations!" UX.junkSpan
intExpr :: Integer -> a -> Expr a
intExpr i l = EImm (ECon (PInt i) l) l
------------------------------------------------------------------------------
type SrcImm = Imm F.SrcSpan
type SrcBind = Bind F.SrcSpan
type SrcDecl = Decl F.SrcSpan
type SrcExpr = Expr F.SrcSpan
instance F.Subable r => F.Subable (Type r) where
-- syms :: a -> [Symbol]
syms (TBase _ r) = F.syms r
syms (TFun _ s t) = F.syms s ++ F.syms t
-- substa :: (Symbol -> Symbol) -> Type r -> Type r
substa f (TBase b r) = TBase b (F.substa f r)
substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)
-- substf :: (Symbol -> Expr) -> Type r -> Type r
substf f (TBase b r) = TBase b (F.substf f r)
substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)
-- subst :: Subst -> a -> a
subst f (TBase b r) = TBase b (F.subst f r)
subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)
================================================
FILE: src/Language/Sprite/L1.hs
================================================
module Language.Sprite.L1 ( sprite ) where
import Control.Monad (void)
import System.Exit
import qualified Language.Fixpoint.Types as F
-- import qualified Language.Fixpoint.Types.Config as F
-- import qualified Language.Fixpoint.Misc as F
-- import Language.Sprite.L1.Types
import Language.Sprite.L1.Check
import Language.Sprite.L1.Parse
import Language.Sprite.Common
sprite :: FilePath -> IO ()
sprite f = do
src <- parseFile f
-- print (void src)
res <- case vcgen src of
Left errs -> pure (crash errs "VCGen failure")
Right vc -> checkValid f vc
ec <- resultExit res
exitWith ec
================================================
FILE: src/Language/Sprite/L2/Check.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L2.Check (vcgen) where
import Control.Monad (void)
-- import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L2.Types
import Language.Sprite.L2.Prims
import Language.Sprite.L2.Constraints
-------------------------------------------------------------------------------
vcgen:: SrcExpr -> Either [UX.UserError] SrcQuery
-------------------------------------------------------------------------------
vcgen e = query [] [] <$> check empEnv e (bTrue TInt)
-- | CG Monad -----------------------------------------------------------------
type CG a = Either [UX.UserError] a
failWith :: UX.Text -> F.SrcSpan -> CG a
failWith msg l = Left [UX.mkError msg l]
-------------------------------------------------------------------------------
sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr
-------------------------------------------------------------------------------
{- | [Sub-Base]
(v::t) => q[w := v]
-------------------
b{v:p} <= b{w:q}
-}
sub l s@(TBase b1 (F.Reft (v, _))) (TBase b2 (F.Reft (w, q)))
| b1 == b2 = return (cAll l v s (cHead l (subst q w v)))
| otherwise = failWith "Invalid Subtyping" l
{- | [Sub-Fun]
(v::t) => q[w := v]
-------------------
b{v:p} <: b{w:q}
s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2
-------------------------------------
x1:s1 -> t1 <: x2:s2 -> t2
-}
sub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
cI <- sub l s2 s1
cO <- cAll l x2 t2 <$> sub l t1' t2
return (cAnd cI cO)
where
t1' = subst t1 x1 x2
--------------------------------------------------------------------
-- | 'Checking' constraints
--------------------------------------------------------------------
check :: Env -> SrcExpr -> RType -> CG SrcCstr
--------------------------------------------------------------------
{- [Chk-Lam]
G, x:s |- e <== t
--------------------------
G |- \x.e <== x:s -> t
-}
check g (EFun bx e l) (TFun y s t) | y == x = do
c <- check (extEnv g bx s') e t'
return $ cAll l x s c
where
x = bindId bx
s' = subst s y x
t' = subst t y x
{- [Chk-Let]
G |- e1 ==> t1 G, x:t1 |- e2 <== t2
-------------------------------------------
G |- let x = e1 in e2 <== t2
-}
check g (ELet (Decl bx@(Bind x l) e _) e' _) t' = do
(c, s) <- synth g e
c' <- check (extEnv g bx s) e' t'
return $ cAnd c (cAll l x s c')
{- [Chk-Rec]
G; f:s |- e <== s G; f:s |- e' <== t'
----------------------------------------[Chk-Rec]
G |- letrec f = (e:s) in e' <== t'
-}
check g (ELet (RDecl bx@(Bind x l) (EAnn e s _) _) e' _) t' = do
c <- check g' e s
c' <- check g' e' t'
return $ cAnd c c'
where
g' = extEnv g bx s
{- [Chk-If]
G |- v <== bool
G, _:{v} |- e1 <== t
G, _:{not v} |- e2 <== t
----------------------------- [Chk-If]
G |- if v e1 e2 <== t
-}
check g (EIf v e1 e2 l) t = do
cv <- check g (EImm v l) rBool
c1 <- cAll l xv tT <$> check g e1 t
c2 <- cAll l xv tF <$> check g e2 t
return (cAnd c1 c2)
where
tT = predRType pv
tF = predRType (F.PNot pv)
pv = immExpr v
xv = grdSym g
{- [Chk-Syn]
G |- e ==> s G |- s <: t
----------------------------------[Chk-Syn]
G |- e <== t
-}
check g e t = do
let l = label e
(c, s) <- synth g e
c' <- sub l s t
return (cAnd c c')
{- [Chk-Syn-Imm] -}
checkImm :: Env -> SrcImm -> RType -> CG SrcCstr
checkImm g i t = do
s <- synthImm g i
sub (label i) s t
--------------------------------------------------------------------
-- | 'Synthesis' constraints
--------------------------------------------------------------------
singleton :: F.Symbol -> RType -> RType
singleton x (TBase b (F.Reft (v, p))) = TBase b (F.Reft (v, F.pAnd [p, v_eq_x]))
where v_eq_x = F.PAtom F.Eq (F.expr v) (F.expr x)
singleton _ t = t
synthImm :: Env -> SrcImm -> CG RType
{- [Syn-Var]
-----------------
G |- x ==> G(x)
-}
synthImm g (EVar x l)
| Just t <- getEnv g x = return (singleton x t)
| otherwise = failWith ("Unbound variable:" <+> F.pprint x) l
{- [Syn-Con]
-----------------
G |- x ==> ty(c)
-}
synthImm g (ECon c l) = return (constTy l c)
synth :: Env -> SrcExpr -> CG (SrcCstr, RType)
{- [Syn-Con], [Syn-Var] -}
synth g (EImm i _) = do
t <- synthImm g i
return (cTrue, t)
{- [Syn-Ann]
G |- e <== t
-----------------
G |- e:t => t
-}
synth g (EAnn e t _) = do
c <- check g e t
return (c, t)
{- [Syn-App]
G |- e ==> x:s -> t
G |- y <== s
-----------------------
G |- e y ==> t[x := y]
-}
synth g (EApp e y l) = do
(ce, te) <- synth g e
case te of
TFun x s t -> do cy <- checkImm g y s
return (cAnd ce cy, substImm t x y)
_ -> failWith "Application to non-function" l
synth _ e =
failWith ("synth: cannot handle: " <+> text (show (void e) )) (label e)
================================================
FILE: src/Language/Sprite/L2/Constraints.hs
================================================
-- | This module has the kit needed to do constraint generation:
-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L2.Constraints
( -- * Constraints
cTrue, cAnd, cHead, cAll
-- * Substitutions
, subst, substImm
-- * Conversions
, immExpr, predRType
-- * Environments
, Env, empEnv, getEnv, extEnv, grdSym
) where
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L2.Types
--------------------------------------------------------------------------------
-- | Constraints ---------------------------------------------------------------
--------------------------------------------------------------------------------
cTrue :: SrcCstr
cTrue = H.CAnd []
cAnd :: SrcCstr -> SrcCstr -> SrcCstr
cAnd c1 c2 = H.CAnd [c1, c2]
cHead :: F.SrcSpan -> F.Expr -> SrcCstr
cHead l e = H.Head (H.Reft e) (UX.mkError "Subtype error" l)
cAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr
cAll l x t c = case sortPred x t of
Just (so, p) -> H.All (bind l x so p) c
_ -> c
sortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)
sortPred x (TBase b (F.Reft (v, p))) = Just (baseSort b, H.Reft (subst p v x))
sortPred x _ = Nothing
baseSort :: Base -> F.Sort
baseSort TInt = F.intSort
baseSort TBool = F.boolSort
--------------------------------------------------------------------------------
-- | Substitution --------------------------------------------------------------
--------------------------------------------------------------------------------
substImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a
substImm thing x y = F.subst su thing
where
su = F.mkSubst [(x, immExpr y)]
subst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a
subst thing x y = substImm thing x (EVar y ())
immExpr :: Imm b -> F.Expr
immExpr (EVar x _) = F.expr x
immExpr (ECon (PInt n) _) = F.expr n
immExpr (ECon (PBool True) _) = F.PTrue
immExpr (ECon (PBool False) _) = F.PFalse
--------------------------------------------------------------------------------
-- | Environments --------------------------------------------------------------
--------------------------------------------------------------------------------
data Env = Env
{ eBinds :: !(F.SEnv RType)
, eSize :: !Integer
}
extEnv :: Env -> Bind a -> RType -> Env
extEnv env bx t = Env
{ eBinds = F.insertSEnv (bindId bx) t (eBinds env)
, eSize = 1 + eSize env
}
grdSym :: Env -> F.Symbol
grdSym env = F.tempSymbol "grd" (eSize env)
predRType :: F.Pred -> RType
predRType p = TBase TBool (F.predReft p)
getEnv :: Env -> F.Symbol -> Maybe RType
getEnv env x = F.lookupSEnv x (eBinds env)
empEnv :: Env
empEnv = Env F.emptySEnv 0
================================================
FILE: src/Language/Sprite/L2/Parse.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Language.Sprite.L2.Parse
(
-- * Parsing programs
parseFile
, parseWith
-- * Parsing combinators
, rtype
, expr
) where
import qualified Data.List as L
import Text.Megaparsec hiding (State, label)
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Parse as FP
import Language.Sprite.Common
import Language.Sprite.Common.Parse
import Language.Sprite.L2.Types
parseFile :: FilePath -> IO SrcExpr
parseFile = FP.parseFromFile prog
parseWith :: FP.Parser a -> FilePath -> String -> a
parseWith = FP.doParse'
--------------------------------------------------------------------------------
-- | Top-Level Expression Parser
--------------------------------------------------------------------------------
prog :: FP.Parser SrcExpr
prog = declsExpr <$> many decl
expr :: FP.Parser SrcExpr
expr = try funExpr
<|> try letExpr
<|> try ifExpr
<|> try (FP.braces (expr <* whiteSpace))
<|> try appExpr
<|> try binExp
<|> expr0
expr0 :: FP.Parser SrcExpr
expr0 = try (FP.parens expr)
<|> immExpr
appExpr :: FP.Parser SrcExpr
appExpr = mkEApp <$> immExpr <*> parens (sepBy1 imm comma)
binExp :: FP.Parser SrcExpr
binExp = withSpan' $ do
x <- imm
o <- op
y <- imm
return (bop o x y)
op :: FP.Parser PrimOp
op = (FP.reservedOp "*" >> pure BTimes)
<|> (FP.reservedOp "+" >> pure BPlus )
<|> (FP.reservedOp "-" >> pure BMinus)
<|> (FP.reservedOp "<" >> pure BLt )
<|> (FP.reservedOp "<=" >> pure BLe )
<|> (FP.reservedOp "==" >> pure BEq )
<|> (FP.reservedOp ">" >> pure BGt )
<|> (FP.reservedOp ">=" >> pure BGe )
<|> (FP.reservedOp "&&" >> pure BAnd )
<|> (FP.reservedOp "||" >> pure BOr )
bop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr
bop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]
mkEApp :: SrcExpr -> [SrcImm] -> SrcExpr
mkEApp = L.foldl' (\e y -> EApp e y (label e <> label y))
letExpr :: FP.Parser SrcExpr
letExpr = withSpan' (ELet <$> decl <*> expr)
ifExpr :: FP.Parser SrcExpr
ifExpr = withSpan' $ do
FP.reserved "if"
v <- parens imm
e1 <- expr
FP.reserved "else"
e2 <- expr
return (EIf v e1 e2)
immExpr :: FP.Parser SrcExpr
immExpr = do
i <- imm
return (EImm i (label i))
imm :: FP.Parser SrcImm
imm = immInt <|> immBool <|> immId
immInt :: FP.Parser SrcImm
immInt = withSpan' (ECon . PInt <$> FP.natural)
immBool :: FP.Parser SrcImm
immBool = withSpan' (ECon . PBool <$> bool)
immId :: FP.Parser SrcImm
immId = withSpan' (EVar <$> identifier)
bool :: FP.Parser Bool
bool = (reserved "true" >> pure True)
<|>(reserved "false" >> pure False)
funExpr :: FP.Parser SrcExpr
funExpr = withSpan' $ do
xs <- parens (sepBy1 binder comma)
_ <- FP.reservedOp "=>"
-- _ <- FP.reservedOp "{"
body <- braces (expr <* whiteSpace)
-- _ <- FP.reservedOp "}"
return $ mkEFun xs body
mkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr
mkEFun bs e0 l = foldr (\b e -> EFun b e l) e0 bs
-- | Annotated declaration
decl :: FP.Parser SrcDecl
decl = mkDecl <$> ann <*> plainDecl
type Ann = Maybe (F.Symbol, RType)
ann :: FP.Parser Ann
ann = (reservedOp "/*@" >> (Just <$> annot)) <|> pure Nothing
annot :: FP.Parser (F.Symbol, RType)
annot = do
reserved "val"
x <- identifier
colon
t <- rtype
reservedOp "*/"
return (x, t)
mkDecl :: Ann -> SrcDecl -> SrcDecl
mkDecl (Just (x, t)) (Decl b e l)
| x == bindId b = Decl b (EAnn e t (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl (Just (x, t)) (RDecl b e l)
| x == bindId b = RDecl b (EAnn e t (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl Nothing d = d
plainDecl :: FP.Parser SrcDecl
plainDecl = withSpan' $ do
ctor <- (FP.reserved "let rec" >> pure RDecl) <|>
(FP.reserved "let" >> pure Decl)
b <- binder
FP.reservedOp "="
e <- expr
FP.semi
return (ctor b e)
-- | `binder` parses SrcBind, used for let-binds and function parameters.
binder :: FP.Parser SrcBind
binder = withSpan' (Bind <$> identifier)
--------------------------------------------------------------------------------
-- | Top level Rtype parser
--------------------------------------------------------------------------------
rtype :: FP.Parser RType
rtype = try rfun
<|> rtype0
rtype0 :: FP.Parser RType
rtype0 = parens rtype
<|> rbase
rfun :: FP.Parser RType
rfun = mkTFun <$> funArg <*> (FP.reservedOp "=>" *> rtype)
funArg :: FP.Parser (F.Symbol, RType)
funArg = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))
<|> ((,) <$> freshArgSymbolP <*> rtype0)
freshArgSymbolP :: FP.Parser F.Symbol
freshArgSymbolP = do
n <- FP.freshIntP
return $ F.symbol ("_arg" ++ show n)
mkTFun :: (F.Symbol, RType) -> RType -> RType
mkTFun (x, s) = TFun x s
rbase :: FP.Parser RType
rbase = TBase <$> tbase <*> refTop
tbase :: FP.Parser Base
tbase = (reserved "int" >> pure TInt)
<|>(reserved "bool" >> pure TBool)
refTop :: FP.Parser F.Reft
refTop = brackets reftB <|> pure mempty
reftB :: FP.Parser F.Reft
reftB = mkReft <$> (FP.lowerIdP <* mid) <*> FP.predP
mkReft :: F.Symbol -> F.Pred -> F.Reft
mkReft x r = F.Reft (x, r)
mid :: FP.Parser ()
mid = FP.reservedOp "|"
-- >>> (parseWith rtype "" "int{v|v = 3}")
-- TBase TInt (v = 3)
-- >>> (parseWith rtype "" "int{v|v = x + y}")
-- TBase TInt (v = (x + y))
-- >>> (parseWith rtype "" "int")
-- TBase TInt true
-- >>> parseWith funArg "" "x:int"
-- ("x",TBase TInt true)
-- >>> parseWith rfun "" "int => int"
-- TFun "_" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int"
-- TFun "x" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int{v|0 < v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 < v))
-- >>> parseWith rfun "" "x:int => int{v|0 <= v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 <= v))
-- >>> parseWith rfun "" "x:int{v|0 <= v} => int{v|0 <= v}"
-- TFun "x" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))
================================================
FILE: src/Language/Sprite/L2/Prims.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L2.Prims where
import qualified Data.Maybe as Mb
import qualified Data.Map as M
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.L2.Types
import Language.Sprite.L2.Parse
-- | Primitive Types --------------------------------------------------
constTy :: F.SrcSpan -> Prim -> RType
constTy _ (PInt n) = TBase TInt (F.exprReft (F.expr n))
constTy _ (PBool True) = TBase TBool (F.propReft F.PTrue)
constTy _ (PBool False) = TBase TBool (F.propReft F.PFalse)
constTy l (PBin o) = binOpTy l o
binOpTy :: F.SrcSpan -> PrimOp -> RType
binOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv)
where
err = UX.panicS ("Unknown PrimOp: " ++ show o) l
bTrue :: Base -> RType
bTrue b = TBase b mempty
binOpEnv :: M.Map PrimOp RType
binOpEnv = M.fromList
[ (BPlus , mkTy "x:int => y:int => int[v|v=x+y]")
, (BMinus, mkTy "x:int => y:int => int[v|v=x-y]")
, (BTimes, mkTy "x:int => y:int => int[v|v=x*y]")
, (BLt , mkTy "x:int => y:int => bool[v|v <=> (x < y)]")
, (BLe , mkTy "x:int => y:int => bool[v|v <=> (x <= y)]")
, (BGt , mkTy "x:int => y:int => bool[v|v <=> (x > y)]")
, (BGe , mkTy "x:int => y:int => bool[v|v <=> (x >= y)]")
, (BEq , mkTy "x:int => y:int => bool[v|v <=> (x == y)]")
, (BAnd , mkTy "x:bool => y:bool => bool[v|v <=> (x && y)]")
, (BOr , mkTy "x:bool => y:bool => bool[v|v <=> (x || y)]")
, (BNot , mkTy "x:bool => bool[v|v <=> not x]")
]
mkTy :: String -> RType
mkTy = parseWith rtype "prims"
================================================
FILE: src/Language/Sprite/L2/Types.hs
================================================
{-# LANGUAGE DeriveFunctor #-}
module Language.Sprite.L2.Types where
-- import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
-- import qualified Language.Sprite.Common.UX as UX
-- import Language.Sprite.Common.Misc
import Language.Sprite.Common
-- | Basic types --------------------------------------------------------------
data Base = TInt | TBool
deriving (Eq, Ord, Show)
-- | Refined Types ------------------------------------------------------------
data Type r
= TBase !Base r -- Int{r}
| TFun !F.Symbol !(Type r) !(Type r) -- x:s -> t
deriving (Eq, Ord, Show)
rInt :: RType
rInt = TBase TInt mempty
rBool :: RType
rBool = TBase TBool mempty
type RType = Type F.Reft
-- | Primitive Constants ------------------------------------------------------
data PrimOp
= BPlus
| BMinus
| BTimes
| BLt
| BLe
| BEq
| BGt
| BGe
| BAnd
| BOr
| BNot
deriving (Eq, Ord, Show)
data Prim
= PInt !Integer -- 0,1,2,...
| PBool !Bool -- true, false
| PBin !PrimOp -- +,-,==,<=,...
deriving (Eq, Ord, Show)
---------------------------------------------------------------------------------
-- | Terms ----------------------------------------------------------------------
---------------------------------------------------------------------------------
-- | Bindings -------------------------------------------------------------------
data Bind a
= Bind !F.Symbol a
deriving (Eq, Ord, Show, Functor)
bindId :: Bind a -> F.Symbol
bindId (Bind x _) = x
-- | "Immediate" terms (can appear as function args & in refinements) -----------
data Imm a
= EVar !F.Symbol a
| ECon !Prim a
deriving (Show, Functor)
-- | Variable definition ---------------------------------------------------------
data Decl a
= Decl (Bind a) (Expr a) a -- plain "let"
| RDecl (Bind a) (Expr a) a -- recursive "let rec"
deriving (Show, Functor)
-- | Terms -----------------------------------------------------------------------
data Expr a
= EImm !(Imm a) a -- x,y,z,... 1,2,3...
| EFun !(Bind a) !(Expr a) a -- \x -> e
| EApp !(Expr a) !(Imm a) a -- e v
| ELet !(Decl a) !(Expr a) a -- let/rec x = e1 in e2
| EAnn !(Expr a) !RType a -- e:t
| EIf !(Imm a) !(Expr a) !(Expr a) a -- if v e1 e2
deriving (Show, Functor)
instance Label Imm where
label (EVar _ l) = l
label (ECon _ l) = l
instance Label Expr where
label (EImm _ l) = l
label (EFun _ _ l) = l
label (EApp _ _ l) = l
label (ELet _ _ l) = l
label (EAnn _ _ l) = l
label (EIf _ _ _ l) = l
instance Label Decl where
label (Decl _ _ l) = l
label (RDecl _ _ l) = l
------------------------------------------------------------------------------
declsExpr :: [Decl a] -> Expr a
------------------------------------------------------------------------------
declsExpr [d] = ELet d (intExpr 0 l) l where l = label d
declsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d
intExpr :: Integer -> a -> Expr a
intExpr i l = EImm (ECon (PInt i) l) l
boolExpr :: Bool -> a -> Expr a
boolExpr b l = EImm (ECon (PBool b) l) l
------------------------------------------------------------------------------
type SrcImm = Imm F.SrcSpan
type SrcBind = Bind F.SrcSpan
type SrcDecl = Decl F.SrcSpan
type SrcExpr = Expr F.SrcSpan
instance F.Subable r => F.Subable (Type r) where
-- syms :: a -> [Symbol]
syms (TBase _ r) = F.syms r
-- substa :: (Symbol -> Symbol) -> Type r -> Type r
substa f (TBase b r) = TBase b (F.substa f r)
substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)
-- substf :: (Symbol -> Expr) -> Type r -> Type r
substf f (TBase b r) = TBase b (F.substf f r)
substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)
-- subst :: Subst -> a -> a
subst f (TBase b r) = TBase b (F.subst f r)
subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)
================================================
FILE: src/Language/Sprite/L2.hs
================================================
module Language.Sprite.L2 ( sprite ) where
import System.Exit
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Types.Config as F
import qualified Language.Fixpoint.Misc as F
import Language.Sprite.L2.Types
import Language.Sprite.L2.Check
import Language.Sprite.L2.Parse
import Language.Sprite.Common
--------------------------------------------------------------------------------
sprite :: FilePath -> IO ()
--------------------------------------------------------------------------------
sprite f = do
src <- parseFile f
res <- case vcgen src of
Left errs -> pure (crash errs "VCGen failure")
Right vc -> checkValid f vc
ec <- resultExit res
exitWith ec
================================================
FILE: src/Language/Sprite/L3/Check.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L3.Check (vcgen) where
import Control.Monad (void)
-- import qualified Data.Maybe as Mb
-- import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L3.Types
import Language.Sprite.L3.Prims
import Language.Sprite.L3.Constraints
-------------------------------------------------------------------------------
vcgen:: ([F.Qualifier], SrcExpr) -> Either [UX.UserError] SrcQuery
-------------------------------------------------------------------------------
vcgen (qs, e) = do
(c, ks) <- run (check empEnv e (bTrue TInt))
return $ query qs ks c
-------------------------------------------------------------------------------
sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr
-------------------------------------------------------------------------------
{- | [Sub-Base]
(v::t) => q[w := v]
-------------------
b{v:p} <= b{w:q}
-}
sub l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))
| b1 == b2 = return (cAll l v s (cHead l (subst q w v)))
| otherwise = failWith "Invalid Subtyping" l
{- | [Sub-Fun]
(v::t) => q[w := v]
-------------------
b{v:p} <: b{w:q}
s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2
-------------------------------------
x1:s1 -> t1 <: x2:s2 -> t2
-}
sub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
cI <- sub l s2 s1
cO <- cAll l x2 s2 <$> sub l t1' t2
return (cAnd cI cO)
where
t1' = subst t1 x1 x2
-- sub l t1 t2 = failWith ("sub: cannot handle:" <+> tshow (t1, t2)) l
tshow :: (Show a) => a -> Doc
tshow = text . show
--------------------------------------------------------------------
-- | 'Checking' constraints
--------------------------------------------------------------------
check :: Env -> SrcExpr -> RType -> CG SrcCstr
--------------------------------------------------------------------
{- [Chk-Lam]
G, x:s[y:=x] |- e <== t[y:=x]
-----------------------------
G |- \x.e <== y:s -> t
-}
check g (EFun bx e l) (TFun y s t) = do
c <- check (extEnv g x s') e t'
return $ cAll l x s c
where
x = bindId bx
s' = subst s y x
t' = subst t y x
{- [Chk-Let]
G |- e ==> s G, x:s |- e' <== t'
-------------------------------------------
G |- let x = e in e' <== t'
-}
check g (ELet (Decl (Bind x l) e _) e' _) t' = do
(c, s) <- synth g e
c' <- check (extEnv g x s) e' t'
return $ cAnd c (cAll l x s c')
{- [Chk-Rec]
t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'
---------------------------------------------------------[Chk-Rec]
G |- letrec f = (e:s) in e' <== t'
-}
check g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do
t <- fresh l g s
let g' = extEnv g x t
c <- check g' e t
c' <- check g' e' t'
return $ cAnd c c'
{- [Chk-If]
G |- v <== bool
G, _:{v} |- e1 <== t
G, _:{not v} |- e2 <== t
----------------------------- [Chk-If]
G |- if v e1 e2 <== t
-}
check g (EIf v e1 e2 l) t = do
_ <- check g (EImm v l) rBool
c1 <- cAll l xv tT <$> check g e1 t
c2 <- cAll l xv tF <$> check g e2 t
return (cAnd c1 c2)
where
tT = predRType pv
tF = predRType (F.PNot pv)
pv = immExpr v
xv = grdSym g
{- [Chk-Syn]
G |- e ==> s G |- s <: t
----------------------------------[Chk-Syn]
G |- e <== t
-}
check g e t = do
let l = label e
(c, s) <- synth g e
c' <- sub l s t
return (cAnd c c')
{- [Chk-Syn-Imm] -}
checkImm :: Env -> SrcImm -> RType -> CG SrcCstr
checkImm g i t = do
s <- synthImm g i
sub (label i) s t
--------------------------------------------------------------------
-- | 'Synthesis' constraints
--------------------------------------------------------------------
singleton :: F.Symbol -> RType -> RType
singleton x (TBase b (Known v p)) = TBase b (Known v (H.PAnd [p, v `peq` x]))
singleton _ t = t
peq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred
peq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))
-- singleton x (TBase b (KReft v p)) = TBase b (KReft v (F.pAnd [p, v_eq_x]))
-- where v_eq_x = F.PAtom F.Eq (F.expr v) (F.expr x)
synthImm :: Env -> SrcImm -> CG RType
{- [Syn-Var]
-----------------
G |- x ==> G(x)
-}
synthImm g (EVar x l)
| Just t <- getEnv g x = return (singleton x t)
| otherwise = failWith ("Unbound variable:" <+> F.pprint x) l
{- [Syn-Con]
-----------------
G |- x ==> ty(c)
-}
synthImm _ (ECon c l) = return (constTy l c)
synth :: Env -> SrcExpr -> CG (SrcCstr, RType)
{- [Syn-Con], [Syn-Var] -}
synth g (EImm i _) = do
t <- synthImm g i
return (cTrue, t)
{- [Syn-Ann]
G |- e <== t t := fresh(s)
---------------------------
G |- e:s => t
-}
synth g (EAnn e s l) = do
t <- fresh l g s
c <- check g e t
return (c, t)
{- [Syn-App]
G |- e ==> x:s -> t
G |- y <== s
-----------------------
G |- e y ==> t[x := y]
-}
synth g (EApp e y l) = do
(ce, te) <- synth g e
case te of
TFun x s t -> do cy <- checkImm g y s
return (cAnd ce cy, substImm t x y)
_ -> failWith "Application to non-function" l
synth _ e =
failWith ("synth: cannot handle: " <+> text (show (void e))) (label e)
-------------------------------------------------------------------------------
-- | Fresh templates for `Unknown` refinements
-------------------------------------------------------------------------------
fresh :: F.SrcSpan -> Env -> RType -> CG RType
fresh l g (TBase b r) = TBase b <$> freshR l g b r
fresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t
freshR :: F.SrcSpan -> Env -> Base -> Reft -> CG Reft
freshR _ _ _ r@(Known {}) = pure r
freshR l g b Unknown = freshK l g b
================================================
FILE: src/Language/Sprite/L3/Constraints.hs
================================================
-- | This module has the kit needed to do constraint generation:
-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L3.Constraints
( -- * Constraints
cTrue, cAnd, cHead, cAll
-- * Substitutions
, subst, substImm
-- * Conversions
, predRType, baseSort
-- * Environments
, Env, empEnv, getEnv, extEnv, grdSym, envSorts
-- * Constraint Generation Monad
, CG, run, failWith, freshK
) where
import qualified Data.Maybe as Mb
import Control.Monad.State
import Control.Monad.Except (throwError)
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L3.Types
--------------------------------------------------------------------------------
-- | Constraints ---------------------------------------------------------------
--------------------------------------------------------------------------------
cTrue :: SrcCstr
cTrue = H.CAnd []
cAnd :: SrcCstr -> SrcCstr -> SrcCstr
cAnd (H.CAnd []) c = c
cAnd c (H.CAnd []) = c
cAnd c1 c2 = H.CAnd [c1, c2]
cHead :: F.SrcSpan -> H.Pred -> SrcCstr
cHead _ (H.PAnd []) = cTrue
cHead _ (H.Reft p)
| F.isTautoPred p = cTrue
cHead l p = H.Head p (UX.mkError "Subtype error" l)
cAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr
cAll l x t c = case sortPred x t of
Just (so, p) -> H.All (bind l x so p) c
_ -> c
sortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)
sortPred x (TBase b (Known v p)) = Just (baseSort b, subst p v x)
sortPred _ _ = Nothing
baseSort :: Base -> F.Sort
baseSort TInt = F.intSort
baseSort TBool = F.boolSort
--------------------------------------------------------------------------------
-- | Environments --------------------------------------------------------------
--------------------------------------------------------------------------------
data Env = Env
{ eBinds :: !(F.SEnv RType)
, eSize :: !Integer
}
extEnv :: Env -> F.Symbol -> RType -> Env
extEnv env x t
| x == junkSymbol = env
| otherwise = Env { eBinds = F.insertSEnv x t (eBinds env)
, eSize = 1 + eSize env
}
grdSym :: Env -> F.Symbol
grdSym env = F.tempSymbol "grd" (eSize env)
predRType :: F.Pred -> RType
predRType p = TBase TBool (known $ F.predReft p)
getEnv :: Env -> F.Symbol -> Maybe RType
getEnv env x = F.lookupSEnv x (eBinds env)
empEnv :: Env
empEnv = Env F.emptySEnv 0
envSorts :: Env -> [(F.Symbol, F.Sort)]
envSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)
, (t, _) <- Mb.maybeToList (sortPred x s) ]
-------------------------------------------------------------------------------
-- | CG Monad -----------------------------------------------------------------
-------------------------------------------------------------------------------
type CG a = StateT CGState (Either [UX.UserError]) a
data CGState = CGState
{ cgCount :: !Integer -- ^ monotonic counter, to get fresh things
, cgKVars :: ![SrcHVar] -- ^ list of generated kvars
}
s0 :: CGState
s0 = CGState 0 []
run :: CG a -> Either [UX.UserError] (a, [SrcHVar])
run act = do
(x, s) <- runStateT act s0
return (x, cgKVars s)
failWith :: UX.Text -> F.SrcSpan -> CG a
failWith msg l = throwError [UX.mkError msg l]
freshK :: F.SrcSpan -> Env -> Base -> CG Reft
freshK l g b = do
v <- freshValueSym
k <- freshKVar l t ts
return $ Known v (H.Var k (v:xs))
where
t = baseSort b
(xs,ts) = unzip (envSorts g)
freshKVar :: F.SrcSpan -> F.Sort -> [F.Sort] -> CG F.Symbol
freshKVar l t ts = do
k <- F.kv . F.intKvar <$> freshInt
_ <- addSrcKVar (H.HVar k (t:ts) (UX.mkError "fake" l))
return k
addSrcKVar :: SrcHVar -> CG ()
addSrcKVar k = modify $ \s -> s { cgKVars = k : cgKVars s }
freshValueSym :: CG F.Symbol
freshValueSym = F.vv . Just <$> freshInt
freshInt :: CG Integer
freshInt = do
s <- get
let n = cgCount s
put s { cgCount = 1 + n}
return n
================================================
FILE: src/Language/Sprite/L3/Parse.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Language.Sprite.L3.Parse
(
-- * Parsing programs
parseFile
, parseWith
-- * Parsing combinators
, rtype
, expr
) where
import qualified Data.Set as S
import qualified Data.List as L
import Control.Monad.Combinators.Expr
import Text.Megaparsec hiding (State, label)
import Text.Megaparsec.Char
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Parse as FP
import Language.Sprite.Common
import Language.Sprite.Common.Parse
import Language.Sprite.L3.Types hiding (immExpr)
import Language.Sprite.L3.Constraints
parseFile :: FilePath -> IO ([F.Qualifier], SrcExpr)
parseFile = FP.parseFromFile prog
parseWith :: FP.Parser a -> FilePath -> String -> a
parseWith = FP.doParse'
--------------------------------------------------------------------------------
-- | Top-Level Expression Parser
--------------------------------------------------------------------------------
prog :: FP.Parser ([F.Qualifier], SrcExpr)
prog = do
qs <- quals
src <- declsExpr <$> many decl
return (qs, src)
quals :: FP.Parser [F.Qualifier]
quals = try ((:) <$> between annL annR qual <*> quals)
<|> pure []
qual ::FP.Parser F.Qualifier
qual = FP.reserved "qualif" >> FP.qualifierP (baseSort <$> tbase)
expr :: FP.Parser SrcExpr
expr = try funExpr
<|> try letExpr
<|> try ifExpr
<|> try (FP.braces (expr <* FP.spaces))
<|> try appExpr
<|> try binExp
<|> expr0
expr0 :: FP.Parser SrcExpr
expr0 = try (FP.parens expr)
<|> immExpr
appExpr :: FP.Parser SrcExpr
appExpr = mkEApp <$> immExpr <*> FP.parens (sepBy1 imm FP.comma)
binExp :: FP.Parser SrcExpr
binExp = withSpan' $ do
x <- imm
o <- op
y <- imm
return (bop o x y)
op :: FP.Parser PrimOp
op = (FP.reservedOp "*" >> pure BTimes)
<|> (FP.reservedOp "+" >> pure BPlus )
<|> (FP.reservedOp "-" >> pure BMinus)
<|> (FP.reservedOp "<" >> pure BLt )
<|> (FP.reservedOp "<=" >> pure BLe )
<|> (FP.reservedOp "==" >> pure BEq )
<|> (FP.reservedOp ">" >> pure BGt )
<|> (FP.reservedOp ">=" >> pure BGe )
<|> (FP.reservedOp "&&" >> pure BAnd )
<|> (FP.reservedOp "||" >> pure BOr )
bop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr
bop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]
mkEApp :: SrcExpr -> [SrcImm] -> SrcExpr
mkEApp = L.foldl' (\e y -> EApp e y (label e <> label y))
letExpr :: FP.Parser SrcExpr
letExpr = withSpan' (ELet <$> decl <*> expr)
ifExpr :: FP.Parser SrcExpr
ifExpr = withSpan' $ do
FP.reserved "if"
v <- FP.parens imm
e1 <- expr
FP.reserved "else"
e2 <- expr
return (EIf v e1 e2)
immExpr :: FP.Parser SrcExpr
immExpr = do
i <- imm
return (EImm i (label i))
imm :: FP.Parser SrcImm
imm = immInt <|> immBool <|> immId
immInt :: FP.Parser SrcImm
immInt = withSpan' (ECon . PInt <$> FP.natural)
immBool :: FP.Parser SrcImm
immBool = withSpan' (ECon . PBool <$> bool)
immId :: FP.Parser SrcImm
immId = withSpan' (EVar <$> identifier)
bool :: FP.Parser Bool
bool = (FP.reserved "true" >> pure True)
<|>(FP.reserved "false" >> pure False)
funExpr :: FP.Parser SrcExpr
funExpr = withSpan' $ do
xs <- FP.parens (sepBy1 binder FP.comma)
_ <- FP.reservedOp "=>"
body <- FP.braces (expr <* FP.spaces)
return $ mkEFun xs body
mkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr
mkEFun bs e0 l = foldr (\b e -> EFun b e l) e0 bs
-- | Annotated declaration
decl :: FP.Parser SrcDecl
decl = mkDecl <$> ann <*> plainDecl
type Ann = Maybe (F.Symbol, RType)
annL, annR :: FP.Parser ()
annL = FP.reservedOp "/*@"
annR = FP.reservedOp "*/"
ann :: FP.Parser Ann
ann = (annL >> (Just <$> annot)) <|> pure Nothing
annot :: FP.Parser (F.Symbol, RType)
annot = do
FP.reserved "val"
x <- identifier
FP.colon
t <- rtype
annR
return (x, t)
{-
between :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a
between lP rP xP = do
lP
x <- xP
rP
return x
-}
mkDecl :: Ann -> SrcDecl -> SrcDecl
mkDecl (Just (x, t)) (Decl b e l)
| x == bindId b = Decl b (EAnn e t (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl (Just (x, t)) (RDecl b e l)
| x == bindId b = RDecl b (EAnn e t (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl Nothing d = d
plainDecl :: FP.Parser SrcDecl
plainDecl = withSpan' $ do
ctor <- (FP.reserved "let rec" >> pure RDecl) <|>
(FP.reserved "let" >> pure Decl)
b <- binder
FP.reservedOp "="
e <- expr
FP.semi
return (ctor b e)
-- | `binder` parses SrcBind, used for let-binds and function parameters.
binder :: FP.Parser SrcBind
binder = withSpan' (Bind <$> identifier)
--------------------------------------------------------------------------------
-- | Top level Rtype parser
--------------------------------------------------------------------------------
rtype :: FP.Parser RType
rtype = try rfun
<|> rtype0
rtype0 :: FP.Parser RType
rtype0 = parens rtype
<|> rbase
rfun :: FP.Parser RType
rfun = mkTFun <$> funArg <*> (FP.reservedOp "=>" *> rtype)
funArg :: FP.Parser (F.Symbol, RType)
funArg = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))
<|> ((,) <$> freshArgSymbolP <*> rtype0)
freshArgSymbolP :: FP.Parser F.Symbol
freshArgSymbolP = do
n <- FP.freshIntP
return $ F.symbol ("_arg" ++ show n)
mkTFun :: (F.Symbol, RType) -> RType -> RType
mkTFun (x, s) = TFun x s
rbase :: FP.Parser RType
rbase = TBase <$> tbase <*> refTop
tbase :: FP.Parser Base
tbase = (reserved "int" >> pure TInt)
<|>(reserved "bool" >> pure TBool)
refTop :: FP.Parser Reft
refTop = brackets reftB <|> pure mempty
reftB :: FP.Parser Reft
reftB = (question >> pure Unknown)
<|> KReft <$> (FP.lowerIdP <* mid) <*> FP.predP
mid :: FP.Parser ()
mid = FP.reservedOp "|"
question :: FP.Parser ()
question = FP.reservedOp "?"
-- >>> (parseWith rtype "" "int{v|v = 3}")
-- TBase TInt (v = 3)
-- >>> (parseWith rtype "" "int{v|v = x + y}")
-- TBase TInt (v = (x + y))
-- >>> (parseWith rtype "" "int")
-- TBase TInt true
-- >>> parseWith funArg "" "x:int"
-- ("x",TBase TInt true)
-- >>> parseWith rfun "" "int => int"
-- TFun "_" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int"
-- TFun "x" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int{v|0 < v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 < v))
-- >>> parseWith rfun "" "x:int => int{v|0 <= v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 <= v))
-- >>> parseWith rfun "" "x:int{v|0 <= v} => int{v|0 <= v}"
-- TFun "x" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))
-- | list of reserved words
keywords :: S.Set String
keywords = S.fromList
[ "if" , "else"
, "true" , "false"
, "let" , "in"
, "int"
]
================================================
FILE: src/Language/Sprite/L3/Prims.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L3.Prims where
import qualified Data.Maybe as Mb
import qualified Data.Map as M
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
-- import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.L3.Types
import Language.Sprite.L3.Parse
-- | Primitive Types --------------------------------------------------
constTy :: F.SrcSpan -> Prim -> RType
constTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n))
constTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)
constTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)
constTy l (PBin o) = binOpTy l o
binOpTy :: F.SrcSpan -> PrimOp -> RType
binOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv)
where
err = UX.panicS ("Unknown PrimOp: " ++ show o) l
bTrue :: Base -> RType
bTrue b = TBase b mempty
binOpEnv :: M.Map PrimOp RType
binOpEnv = M.fromList
[ (BPlus , mkTy "x:int => y:int => int[v|v=x+y]")
, (BMinus, mkTy "x:int => y:int => int[v|v=x-y]")
, (BTimes, mkTy "x:int => y:int => int[v|v=x*y]")
, (BLt , mkTy "x:int => y:int => bool[v|v <=> (x < y)]")
, (BLe , mkTy "x:int => y:int => bool[v|v <=> (x <= y)]")
, (BGt , mkTy "x:int => y:int => bool[v|v <=> (x > y)]")
, (BGe , mkTy "x:int => y:int => bool[v|v <=> (x >= y)]")
, (BEq , mkTy "x:int => y:int => bool[v|v <=> (x == y)]")
, (BAnd , mkTy "x:bool => y:bool => bool[v|v <=> (x && y)]")
, (BOr , mkTy "x:bool => y:bool => bool[v|v <=> (x || y)]")
, (BNot , mkTy "x:bool => bool[v|v <=> not x]")
]
mkTy :: String -> RType
mkTy = {- Misc.traceShow "mkTy" . -} rebind . parseWith rtype "prims"
rebind :: RType -> RType
rebind t@(TBase {}) = t
rebind (TFun x s t) = TFun x' s' t'
where
x' = F.mappendSym "spec#" x
s' = subst (rebind s) x x'
t' = subst (rebind t) x x'
================================================
FILE: src/Language/Sprite/L3/Types.hs
================================================
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L3.Types where
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
-- import Language.Sprite.Common.Misc
import Language.Sprite.Common
-- | Basic types --------------------------------------------------------------
data Base = TInt | TBool
deriving (Eq, Ord, Show)
-- | Refined Types ------------------------------------------------------------
data Type r
= TBase !Base r -- ^ Int{r}
| TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t
deriving (Eq, Ord, Show)
rInt :: RType
rInt = TBase TInt mempty
rBool :: RType
rBool = TBase TBool mempty
data Reft
= Known !F.Symbol !H.Pred -- ^ Known refinement
| Unknown -- ^ Unknown, to-be-synth refinement
deriving (Show)
known :: F.Reft -> Reft
known (F.Reft (v, r)) = KReft v r
pattern KReft v p = Known v (H.Reft p)
instance Semigroup Reft where
Unknown <> r = r
r <> Unknown = r
KReft v1 r1 <> KReft v2 r2 = KReft v r
where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)
instance Monoid Reft where
mempty = KReft v r where F.Reft (v, r) = mempty
type RType = Type Reft
-- | Primitive Constants ------------------------------------------------------
data PrimOp
= BPlus
| BMinus
| BTimes
| BLt
| BLe
| BEq
| BGt
| BGe
| BAnd
| BOr
| BNot
deriving (Eq, Ord, Show)
data Prim
= PInt !Integer -- 0,1,2,...
| PBool !Bool -- true, false
| PBin !PrimOp -- +,-,==,<=,...
deriving (Eq, Ord, Show)
---------------------------------------------------------------------------------
-- | Terms ----------------------------------------------------------------------
---------------------------------------------------------------------------------
-- | Bindings -------------------------------------------------------------------
data Bind a
= Bind !F.Symbol a
deriving (Eq, Ord, Show, Functor)
bindId :: Bind a -> F.Symbol
bindId (Bind x _) = x
junkSymbol :: F.Symbol
junkSymbol = "_"
-- | "Immediate" terms (can appear as function args & in refinements) -----------
data Imm a
= EVar !F.Symbol a
| ECon !Prim a
deriving (Show, Functor)
-- | Variable definition ---------------------------------------------------------
data Decl a
= Decl (Bind a) (Expr a) a -- plain "let"
| RDecl (Bind a) (Expr a) a -- recursive "let rec"
deriving (Show, Functor)
-- | Terms -----------------------------------------------------------------------
data Expr a
= EImm !(Imm a) a -- x,y,z,... 1,2,3...
| EFun !(Bind a) !(Expr a) a -- \x -> e
| EApp !(Expr a) !(Imm a) a -- e v
| ELet !(Decl a) !(Expr a) a -- let/rec x = e1 in e2
| EAnn !(Expr a) !RType a -- e:t
| EIf !(Imm a) !(Expr a) !(Expr a) a -- if v e1 e2
deriving (Show, Functor)
instance Label Imm where
label (EVar _ l) = l
label (ECon _ l) = l
instance Label Expr where
label (EImm _ l) = l
label (EFun _ _ l) = l
label (EApp _ _ l) = l
label (ELet _ _ l) = l
label (EAnn _ _ l) = l
label (EIf _ _ _ l) = l
instance Label Decl where
label (Decl _ _ l) = l
label (RDecl _ _ l) = l
------------------------------------------------------------------------------
declsExpr :: [Decl a] -> Expr a
------------------------------------------------------------------------------
declsExpr [d] = ELet d (intExpr 0 l) l where l = label d
declsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d
intExpr :: Integer -> a -> Expr a
intExpr i l = EImm (ECon (PInt i) l) l
boolExpr :: Bool -> a -> Expr a
boolExpr b l = EImm (ECon (PBool b) l) l
------------------------------------------------------------------------------
type SrcImm = Imm F.SrcSpan
type SrcBind = Bind F.SrcSpan
type SrcDecl = Decl F.SrcSpan
type SrcExpr = Expr F.SrcSpan
-- | should/need only be defined on "Known" variants. TODO:LIQUID
instance F.Subable Reft where
syms (Known v r) = v : F.syms r
substa f (Known v r) = Known (f v) (F.substa f r)
substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r)
subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)
subst1 (Known v r) su = Known v (F.subst1Except [v] r su)
instance F.Subable r => F.Subable (Type r) where
-- syms :: a -> [Symbol]
syms (TBase _ r) = F.syms r
-- substa :: (Symbol -> Symbol) -> Type r -> Type r
substa f (TBase b r) = TBase b (F.substa f r)
substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)
-- substf :: (Symbol -> Expr) -> Type r -> Type r
substf f (TBase b r) = TBase b (F.substf f r)
substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)
-- subst :: Subst -> a -> a
subst f (TBase b r) = TBase b (F.subst f r)
subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)
--------------------------------------------------------------------------------
-- | Substitution --------------------------------------------------------------
--------------------------------------------------------------------------------
substImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a
substImm thing x y = F.subst su thing
where
su = F.mkSubst [(x, immExpr y)]
subst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a
subst thing x y = substImm thing x (EVar y ())
immExpr :: Imm b -> F.Expr
immExpr (EVar x _) = F.expr x
immExpr (ECon (PInt n) _) = F.expr n
immExpr (ECon (PBool True) _) = F.PTrue
immExpr (ECon (PBool False) _) = F.PFalse
================================================
FILE: src/Language/Sprite/L3.hs
================================================
module Language.Sprite.L3 ( sprite ) where
import System.Exit
import qualified Language.Fixpoint.Types as F
-- import qualified Language.Fixpoint.Types.Config as F
-- import qualified Language.Fixpoint.Misc as F
-- import Language.Sprite.L3.Types
import Language.Sprite.L3.Check
import Language.Sprite.L3.Parse
import Language.Sprite.Common
--------------------------------------------------------------------------------
sprite :: FilePath -> IO ()
--------------------------------------------------------------------------------
sprite f = do
src <- parseFile f
res <- case vcgen src of
Left errs -> pure (crash errs "VCGen failure")
Right vc -> checkValid f vc
ec <- resultExit res
exitWith ec
================================================
FILE: src/Language/Sprite/L4/Check.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L4.Check (vcgen) where
import Control.Monad (void)
-- import qualified Data.Maybe as Mb
-- import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
-- import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.Common
import Language.Sprite.L4.Types
import Language.Sprite.L4.Prims
import Language.Sprite.L4.Constraints
import Language.Sprite.L4.Elaborate
-- import Debug.Trace (trace)
-------------------------------------------------------------------------------
vcgen:: ([F.Qualifier], SrcExpr) -> Either [UX.UserError] SrcQuery
-------------------------------------------------------------------------------
vcgen (qs, e) = do
let eL = elaborate e
(c, ks) <- run (check empEnv eL (bTrue TInt))
return $ query qs ks c
-------------------------------------------------------------------------------
sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr
-------------------------------------------------------------------------------
{- | [Sub-Base]
(v::t) => q[w := v]
-------------------
b{v:p} <= b{w:q}
-}
sub l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))
| b1 == b2 = return (cAll l v s (cHead l (subst q w v)))
| otherwise = failWith "Invalid Subtyping" l
{- | [Sub-Fun]
(v::t) => q[w := v]
-------------------
b{v:p} <: b{w:q}
s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2
-------------------------------------
x1:s1 -> t1 <: x2:s2 -> t2
-}
sub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
cI <- sub l s2 s1
cO <- cAll l x2 s2 <$> sub l t1' t2
return (cAnd cI cO)
where
t1' = subst t1 x1 x2
-- sub l (TAll a1 t1) (TAll a2 t2) = do
-- failWith "TBD:sub-All" l
sub l t1 t2 = failWith ("sub: cannot handle:" <+> UX.tshow (t1, t2)) l
--------------------------------------------------------------------
-- | 'Checking' constraints
--------------------------------------------------------------------
check :: Env -> SrcExpr -> RType -> CG SrcCstr
--------------------------------------------------------------------
{- [Chk-Lam]
G, x:s[y:=x] |- e <== t[y:=x]
-----------------------------
G |- \x.e <== y:s -> t
-}
check g (EFun bx e l) (TFun y s t) = do
c <- check (extEnv g x s') e t'
return $ cAll l x s c
where
x = bindId bx
s' = subst s y x
t' = subst t y x
{- [Chk-Let]
G |- e ==> s G, x:s |- e' <== t'
-------------------------------------------
G |- let x = e in e' <== t'
-}
check g (ELet (Decl (Bind x l) e _) e' _) t' = do
(c, s) <- synth g e
c' <- check (extEnv g x s) e' t'
return $ cAnd c (cAll l x s c')
{- [Chk-Rec]
t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'
---------------------------------------------------------[Chk-Rec]
G |- letrec f = (e:s) in e' <== t'
-}
check g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do
t <- fresh l g s
let g' = extEnv g x t
c <- check g' e t
c' <- check g' e' t'
return $ cAnd c c'
{- [Chk-If]
G |- v <== bool
G, _:{v} |- e1 <== t
G, _:{not v} |- e2 <== t
----------------------------- [Chk-If]
G |- if v e1 e2 <== t
-}
check g (EIf v e1 e2 l) t = do
_ <- check g (EImm v l) rBool
c1 <- cAll l xv tT <$> check g e1 t
c2 <- cAll l xv tF <$> check g e2 t
return (cAnd c1 c2)
where
tT = predRType pv
tF = predRType (F.PNot pv)
pv = immExpr v
xv = grdSym g
{- [Chk-TLam]
G, a |- e <== t
------------------------ [Chk-TLam]
G |- Λ a. e <== all a. t
-}
check g (ETLam a e _) (TAll b t) | a == b = do
check g e t
{- [Chk-Syn]
G |- e ==> s G |- s <: t
----------------------------------[Chk-Syn]
G |- e <== t
-}
check g e t = do
let l = label e
(c, s) <- synth g e
c' <- sub l s t
return (cAnd c c')
{- [Chk-Syn-Imm] -}
checkImm :: Env -> SrcImm -> RType -> CG SrcCstr
checkImm g i t = do
s <- synthImm g i
sub (label i) s t
--------------------------------------------------------------------
-- | 'Synthesis' constraints
--------------------------------------------------------------------
singleton :: F.Symbol -> RType -> RType
singleton x (TBase b (Known v p)) = TBase b (Known v (H.PAnd [p, v `peq` x]))
singleton _ t = t
peq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred
peq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))
synthImm :: Env -> SrcImm -> CG RType
{- [Syn-Var]
-----------------
G |- x ==> G(x)
-}
synthImm g (EVar x l)
| Just t <- getEnv g x = return (singleton x t)
| otherwise = failWith ("Unbound variable:" <+> F.pprint x) l
{- [Syn-Con]
-----------------
G |- x ==> ty(c)
-}
synthImm _ (ECon c l) = return (constTy l c)
synth :: Env -> SrcExpr -> CG (SrcCstr, RType)
{- [Syn-Con], [Syn-Var] -}
synth g (EImm i _) = do
t <- synthImm g i
return (cTrue, t)
{- [Syn-Ann]
G |- e <== t t := fresh(s)
---------------------------
G |- e:s => t
-}
synth g (EAnn e s l) = do
t <- fresh l g s
c <- check g e t
return (c, t)
{- [Syn-App]
G |- e ==> x:s -> t
G |- y <== s
-----------------------
G |- e y ==> t[x := y]
-}
synth g (EApp e y l) = do
(ce, te) <- synth g e
case te of
TFun x s t -> do cy <- checkImm g y s
return (cAnd ce cy, substImm t x y)
_ -> failWith "Application to non-function" l
{- [Syn-TApp]
G |- e ==> all a. s
---------------------------
G |- e[t] ==> s [ a := t]
-}
synth g (ETApp e t l) = do
(ce, te) <- synth g e
case te of
TAll a s -> do tt <- {- Misc.traceShow "REFRESH" <$> -} refresh l g t
return (ce, tsubst a tt s)
_ -> failWith "Type Application to non-forall" l
synth _ e =
failWith ("synth: cannot handle: " <+> text (show (void e))) (label e)
-------------------------------------------------------------------------------
-- | Fresh templates for `Unknown` refinements
-------------------------------------------------------------------------------
refresh :: F.SrcSpan -> Env -> RType -> CG RType
refresh l g = fresh l g . go
where
go (TBase b _) = TBase b Unknown
go (TFun b s t) = TFun b (go s) (go t)
go (TAll a t) = TAll a (go t)
fresh :: F.SrcSpan -> Env -> RType -> CG RType
fresh l g (TBase b r) = TBase b <$> freshR l g b r
fresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t
fresh l g (TAll a t) = TAll a <$> fresh l g t
freshR :: F.SrcSpan -> Env -> Base -> Reft -> CG Reft
freshR _ _ _ r@(Known {}) = pure r
freshR l g b Unknown = freshK l g b
================================================
FILE: src/Language/Sprite/L4/Constraints.hs
================================================
-- | This module has the kit needed to do constraint generation:
-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L4.Constraints
( -- * Constraints
cTrue, cAnd, cHead, cAll
-- * Substitutions
, subst, substImm
-- * Conversions
, predRType, baseSort
-- * Environments
, Env, empEnv, getEnv, extEnv, extEnvTV, grdSym, envSorts
-- * Constraint Generation Monad
, CG, run, failWith, freshK
) where
import qualified Data.Maybe as Mb
import Control.Monad.State
import Control.Monad.Except (throwError)
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import Language.Sprite.L4.Types
--------------------------------------------------------------------------------
-- | Constraints ---------------------------------------------------------------
--------------------------------------------------------------------------------
cTrue :: SrcCstr
cTrue = H.CAnd []
cAnd :: SrcCstr -> SrcCstr -> SrcCstr
cAnd (H.CAnd []) c = c
cAnd c (H.CAnd []) = c
cAnd c1 c2 = H.CAnd [c1, c2]
cHead :: F.SrcSpan -> H.Pred -> SrcCstr
cHead _ (H.PAnd []) = cTrue
cHead _ (H.Reft p)
| F.isTautoPred p = cTrue
cHead l p = H.Head p (UX.mkError "Subtype error" l)
cAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr
cAll l x t c = case sortPred x t of
Just (so, p) -> H.All (bind l x so p) c
_ -> c
sortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)
sortPred x (TBase b (Known v p)) = Just (baseSort b, subst p v x)
sortPred _ _ = Nothing
baseSort :: Base -> F.Sort
baseSort TInt = F.intSort
baseSort TBool = F.boolSort
baseSort (TVar a) = F.FObj (F.symbol a)
--------------------------------------------------------------------------------
-- | Environments --------------------------------------------------------------
--------------------------------------------------------------------------------
data Env = Env
{ eBinds :: !(F.SEnv RType) -- ^ value binders
, eSize :: !Integer -- ^ number of binders?
, eTVars :: !(F.SEnv ()) -- ^ type variables
}
extEnv :: Env -> F.Symbol -> RType -> Env
extEnv env x t
| x == junkSymbol = env
| otherwise = env { eBinds = F.insertSEnv x t (eBinds env)
, eSize = 1 + eSize env
}
extEnvTV :: Env -> TVar -> Env
extEnvTV env (TV a) = env { eTVars = F.insertSEnv a () (eTVars env) }
grdSym :: Env -> F.Symbol
grdSym env = F.tempSymbol "grd" (eSize env)
predRType :: F.Pred -> RType
predRType p = TBase TBool (known $ F.predReft p)
getEnv :: Env -> F.Symbol -> Maybe RType
getEnv env x = F.lookupSEnv x (eBinds env)
empEnv :: Env
empEnv = Env F.emptySEnv 0 F.emptySEnv
envSorts :: Env -> [(F.Symbol, F.Sort)]
envSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)
, (t, _) <- Mb.maybeToList (sortPred x s) ]
-------------------------------------------------------------------------------
-- | CG Monad -----------------------------------------------------------------
-------------------------------------------------------------------------------
type CG a = StateT CGState (Either [UX.UserError]) a
data CGState = CGState
{ cgCount :: !Integer -- ^ monotonic counter, to get fresh things
, cgKVars :: ![SrcHVar] -- ^ list of generated kvars
}
s0 :: CGState
s0 = CGState 0 []
run :: CG a -> Either [UX.UserError] (a, [SrcHVar])
run act = do
(x, s) <- runStateT act s0
return (x, cgKVars s)
failWith :: UX.Text -> F.SrcSpan -> CG a
failWith msg l = throwError [UX.mkError msg l]
freshK :: F.SrcSpan -> Env -> Base -> CG Reft
freshK l g b = do
v <- freshValueSym
k <- freshKVar l t ts
return $ Known v (H.Var k (v:xs))
where
t = baseSort b
(xs,ts) = unzip (envSorts g)
freshKVar :: F.SrcSpan -> F.Sort -> [F.Sort] -> CG F.Symbol
freshKVar l t ts = do
k <- F.kv . F.intKvar <$> freshInt
_ <- addSrcKVar (H.HVar k (t:ts) (UX.mkError "fake" l))
return k
addSrcKVar :: SrcHVar -> CG ()
addSrcKVar k = modify $ \s -> s { cgKVars = k : cgKVars s }
freshValueSym :: CG F.Symbol
freshValueSym = F.vv . Just <$> freshInt
freshInt :: CG Integer
freshInt = do
s <- get
let n = cgCount s
put s { cgCount = 1 + n}
return n
================================================
FILE: src/Language/Sprite/L4/Elaborate.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Language.Sprite.L4.Elaborate (elaborate) where
import qualified Data.Maybe as Mb
import qualified Data.List as L
import Control.Exception (throw)
import Control.Monad.State
import Control.Monad.Except (throwError)
import Text.PrettyPrint.HughesPJ
-- import Text.Printf (printf)
import qualified Language.Fixpoint.Types as F
import Language.Sprite.Common
-- import qualified Language.Sprite.Common.Misc as Misc
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.L4.Prims
import Language.Sprite.L4.Types
import Language.Sprite.L4.Constraints
import Control.Monad (void)
-- import Debug.Trace (trace)
-------------------------------------------------------------------------------
elaborate :: SrcExpr -> ElbExpr
-------------------------------------------------------------------------------
elaborate e = {- trace msg -} e''
where
_msg = "elaborate: " ++ show (void e, void e'')
e'' = subsTy su e'
(su, e') = runElabM act
act = elabC empEnv e (bTrue TInt)
runElabM :: ElabM a -> (TvSub, a)
runElabM act = case runStateT act s0 of
Left errs -> throw errs
Right (v, s) -> (eSub s, v)
where s0 = ElabS mempty 0
type TvSub = F.SEnv RType
data ElabS = ElabS { eSub :: !TvSub, eNum :: !Int }
type ElabM a = StateT ElabS (Either [UX.UserError]) a
unifyV :: F.SrcSpan -> TVar -> RType -> ElabM RType
unifyV _ a t@(TBase (TVar b) r)
| a == b
= return t
| nonRigid a
= assign a t >> return t
| nonRigid b
= assign b t' >> return t' where t' = TBase (TVar a) r
unifyV l a t
| a `elem` freeTVars t
= occurError l a t
| nonRigid a
= assign a t >> return t
| otherwise
= rigidError l a t
unify :: F.SrcSpan -> RType -> RType -> ElabM RType
unify l (TBase (TVar a) _) t =
unifyV l a t
unify l t (TBase (TVar a) _) =
unifyV l a t
unify _ t1@(TBase b1 _) (TBase b2 _) | b1 == b2 =
return t1
unify l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
x <- pure (unifyX l x1 x2)
s <- unify l s1 s2
t1' <- subsTyM t1
t2' <- subsTyM t2
t <- unify l t1' t2'
return (TFun x s t)
unify l t1 t2 =
unifyError l t1 t2
unifyX :: F.SrcSpan -> F.Symbol -> F.Symbol -> F.Symbol
unifyX _ x _ = x
unifyError :: F.SrcSpan -> RType -> RType -> ElabM a
unifyError l t1 t2 = throwError [UX.mkError msg l]
where msg = "type error: cannot unify" <+> UX.tshow t1 <+> "and" <+> UX.tshow t2
rigidError :: F.SrcSpan -> TVar -> RType -> ElabM a
rigidError l a t = throwError [UX.mkError msg l]
where msg = "type error: cannot assign rigid" <+> UX.tshow a <+> "the type" <+> UX.tshow t
occurError :: F.SrcSpan -> TVar -> RType -> ElabM a
occurError l a t = throwError [UX.mkError msg l]
where msg = "type error: occurs check" <+> UX.tshow a <+> "occurs in" <+> UX.tshow t
-------------------------------------------------------------------------------
elabC :: Env -> SrcExpr -> RType -> ElabM ElbExpr
elabC g (EFun b e l) (TFun _ s t) = do
e' <- elabC (extEnv g (bindId b) s) e t
return $ EFun b e' l
-- let rec x:s = e1 in e2
elabC g (ELet (RDecl (Bind x l) (EAnn e1 s1 l1) ld) e2 l2) t2 = do
let g' = extEnv g x s1
let (as, t1) = splitTAll s1
e1' <- elabC (extEnvTVs g' as) e1 t1
e2' <- elabC g' e2 t2
return $ ELet (RDecl (Bind x l) (EAnn (mkTLam e1' as) s1 l1) ld) e2' l2
-- let x = e in e'
elabC g (ELet (Decl (Bind x l) e1 l1) e2 l2) t2 = do
(e1', s) <- elabS g e1
e2' <- elabC (extEnv g x s) e2 t2
return $ ELet (Decl (Bind x l) e1' l1) e2' l2
-- if b e1 e2
elabC g (EIf b e1 e2 l) t = do
e1' <- elabC g e1 t
e2' <- elabC g e2 t
return $ EIf b e1' e2' l
elabC g e t = do
(e', t') <- elabS g e
unify (label e) t t'
return e'
immS :: Env -> SrcImm -> ElabM ([RType], RType)
immS g i = instantiate =<< immTy g i
extEnvTVs :: Env -> [TVar] -> Env
extEnvTVs = foldr (flip extEnvTV)
-------------------------------------------------------------------------------
elabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType)
elabS g e@(EImm i _) = do
(ts, t') <- {- Misc.traceShow ("elabS" ++ show i) <$> -} immS g i
return (mkTApp e ts, t')
elabS g (EAnn e s l) = do
let (as, t) = splitTAll s
e' <- elabC (extEnvTVs g as) e t
return (EAnn (mkTLam e' as) s l, s)
elabS g (EApp e y l) = do
(e', te) <- elabS g e
case te of
TFun _ s t -> do unify l s =<< immTy g y
return (EApp e' y l, t)
_ -> elabErr "Application to non-function" l
elabS _ e =
elabErr ("elabS unexpected:" <+> UX.tshow (void e)) (label e)
-------------------------------------------------------------------------------
elabErr :: UX.Text -> F.SrcSpan -> ElabM a
elabErr msg l = throwError [UX.mkError msg l]
instantiate :: RType -> ElabM ([RType], RType)
instantiate = go []
where
go ts (TAll a s) = do v <- fresh
let vt = TBase (TVar v) mempty
go (vt:ts) (tsubst a vt s)
go ts s = return (reverse ts, s)
splitTAll :: RType -> ([TVar], RType)
splitTAll (TAll a s) = (a:as, t) where (as, t) = splitTAll s
splitTAll t = ([] , t)
fresh :: ElabM TVar
fresh = do
s <- get
let n = eNum s
put s { eNum = n + 1 }
return (nonRigidTV n)
nonRigidTV :: Int -> TVar
nonRigidTV = TV . F.intSymbol "fv"
nonRigid :: TVar -> Bool
nonRigid (TV a) = F.isPrefixOfSym "fv" a
immTy :: Env -> SrcImm -> ElabM RType
immTy g (EVar x l)
| Just t <- getEnv g x = return ({- Misc.traceShow ("immTy: " ++ show x) -} t)
| otherwise = elabErr ("Unbound variable:" <+> F.pprint x) l
immTy _ (ECon c l) = return (constTy l c)
mkTLam :: SrcExpr -> [TVar] -> ElbExpr
mkTLam = foldr (\a e -> ETLam a e (label e))
mkTApp :: SrcExpr -> [RType] -> ElbExpr
mkTApp = L.foldl' (\e t -> ETApp e t (label e))
-- | Type Substitutions --------------------------------------------------------------
class SubsTy a where
subsTy :: TvSub -> a -> a
subsTy1 :: TVar -> RType -> a -> a
subsTy1 a t x = subsTy (singTvSub a t) x
singTvSub :: TVar -> RType -> TvSub
singTvSub a t = F.fromListSEnv [(F.symbol a, t)]
instance SubsTy RType where
subsTy su t@(TBase (TVar a) _) = Mb.fromMaybe t t'
where
t' = F.lookupSEnv (F.symbol a) su
subsTy _su t@(TBase {}) = t
subsTy su (TFun x s t) = TFun x s' t'
where
s' = subsTy su s
t' = subsTy su t
subsTy su (TAll a t) = TAll a t'
where
t' = subsTy su' t
su' = F.deleteSEnv (F.symbol a) su
instance SubsTy TvSub where
subsTy = F.mapSEnv . subsTy
-- applies the substs to the ETApp types
instance SubsTy ElbExpr where
subsTy = subsTyExpr
instance SubsTy ElbDecl where
subsTy su (Decl b e l) = Decl b (subsTy su e) l
subsTy su (RDecl b e l) = RDecl b (subsTy su e) l
subsTyExpr :: TvSub -> ElbExpr -> ElbExpr
subsTyExpr su = go
where
go (EFun b e l) = EFun b (go e) l
go (EApp e i l) = EApp (go e) i l
go (ELet d e l) = ELet d' (go e) l where d' = subsTy su d
go (EAnn e t l) = EAnn (go e) t l
go (EIf i e1 e2 l) = EIf i (go e1) (go e2) l
go (ETLam a e l) = ETLam a (go e) l
go (ETApp e t l) = ETApp (go e) (subsTy su t) l
go e@(EImm {}) = e
subsTyM :: (SubsTy a) => a -> ElabM a
subsTyM x = do
su <- gets eSub
return (subsTy su x)
assign :: TVar -> RType -> ElabM ()
assign a t = modify $ \s -> s { eSub = updSub a t (eSub s)}
updSub :: TVar -> RType -> TvSub -> TvSub
updSub a t su = F.insertSEnv (F.symbol a) t (subsTy1 a t su)
================================================
FILE: src/Language/Sprite/L4/Parse.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Language.Sprite.L4.Parse
(
-- * Parsing programs
parseFile
, parseWith
-- * Parsing combinators
, rtype
, expr
) where
import qualified Data.Set as S
import qualified Data.List as L
import Control.Monad.Combinators.Expr
import Text.Megaparsec hiding (State, label)
import Text.Megaparsec.Char
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Parse as FP
import Language.Sprite.Common
import Language.Sprite.Common.Parse
import Language.Sprite.L4.Types hiding (immExpr)
import Language.Sprite.L4.Constraints
parseFile :: FilePath -> IO ([F.Qualifier], SrcExpr)
parseFile = FP.parseFromFile prog
parseWith :: FP.Parser a -> FilePath -> String -> a
parseWith = FP.doParse'
--------------------------------------------------------------------------------
-- | Top-Level Expression Parser
--------------------------------------------------------------------------------
prog :: FP.Parser ([F.Qualifier], SrcExpr)
prog = do
qs <- quals
src <- declsExpr <$> many decl
return (qs, src)
quals :: FP.Parser [F.Qualifier]
quals = try ((:) <$> between annL annR qual <*> quals)
<|> pure []
qual ::FP.Parser F.Qualifier
qual = reserved "qualif" >> FP.qualifierP (baseSort <$> tbase)
expr :: FP.Parser SrcExpr
expr = try funExpr
<|> try letExpr
<|> try ifExpr
<|> try (FP.braces (expr <* whiteSpace))
<|> try appExpr
<|> try binExp
<|> expr0
expr0 :: FP.Parser SrcExpr
expr0 = try (FP.parens expr)
<|> immExpr
appExpr :: FP.Parser SrcExpr
appExpr = mkEApp <$> immExpr <*> parens (sepBy1 imm comma)
binExp :: FP.Parser SrcExpr
binExp = withSpan' $ do
x <- imm
o <- op
y <- imm
return (bop o x y)
op :: FP.Parser PrimOp
op = (FP.reservedOp "*" >> pure BTimes)
<|> (FP.reservedOp "+" >> pure BPlus )
<|> (FP.reservedOp "-" >> pure BMinus)
<|> (FP.reservedOp "<" >> pure BLt )
<|> (FP.reservedOp "<=" >> pure BLe )
<|> (FP.reservedOp "==" >> pure BEq )
<|> (FP.reservedOp ">" >> pure BGt )
<|> (FP.reservedOp ">=" >> pure BGe )
<|> (FP.reservedOp "&&" >> pure BAnd )
<|> (FP.reservedOp "||" >> pure BOr )
bop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr
bop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]
mkEApp :: SrcExpr -> [SrcImm] -> SrcExpr
mkEApp = L.foldl' (\e y -> EApp e y (label e <> label y))
letExpr :: FP.Parser SrcExpr
letExpr = withSpan' (ELet <$> decl <*> expr)
ifExpr :: FP.Parser SrcExpr
ifExpr = withSpan' $ do
FP.reserved "if"
v <- parens imm
e1 <- expr
FP.reserved "else"
e2 <- expr
return (EIf v e1 e2)
immExpr :: FP.Parser SrcExpr
immExpr = do
i <- imm
return (EImm i (label i))
imm :: FP.Parser SrcImm
imm = immInt <|> immBool <|> immId
immInt :: FP.Parser SrcImm
immInt = withSpan' (ECon . PInt <$> FP.natural)
immBool :: FP.Parser SrcImm
immBool = withSpan' (ECon . PBool <$> bool)
immId :: FP.Parser SrcImm
immId = withSpan' (EVar <$> identifier)
bool :: FP.Parser Bool
bool = (reserved "true" >> pure True)
<|>(reserved "false" >> pure False)
funExpr :: FP.Parser SrcExpr
funExpr = withSpan' $ do
xs <- parens (sepBy1 binder comma)
_ <- FP.reservedOp "=>"
-- _ <- FP.reservedOp "{"
body <- braces (expr <* whiteSpace)
-- _ <- FP.reservedOp "}"
return $ mkEFun xs body
mkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr
mkEFun bs e0 l = foldr (\b e -> EFun b e l) e0 bs
-- | Annotated declaration
decl :: FP.Parser SrcDecl
decl = mkDecl <$> ann <*> plainDecl
type Ann = Maybe (F.Symbol, RType)
annL, annR :: FP.Parser ()
annL = reservedOp "/*@"
annR = reservedOp "*/"
ann :: FP.Parser Ann
ann = (annL >> (Just <$> annot)) <|> pure Nothing
annot :: FP.Parser (F.Symbol, RType)
annot = do
reserved "val"
x <- identifier
colon
t <- rtype
annR
return (x, t)
{-
between :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a
between lP rP xP = do
lP
x <- xP
rP
return x
-}
mkDecl :: Ann -> SrcDecl -> SrcDecl
mkDecl (Just (x, t)) (Decl b e l)
| x == bindId b = Decl b (EAnn e (generalize t) (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl (Just (x, t)) (RDecl b e l)
| x == bindId b = RDecl b (EAnn e (generalize t) (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl Nothing d = d
plainDecl :: FP.Parser SrcDecl
plainDecl = withSpan' $ do
ctor <- (FP.reserved "let rec" >> pure RDecl) <|>
(FP.reserved "let" >> pure Decl)
b <- binder
FP.reservedOp "="
e <- expr
FP.semi
return (ctor b e)
-- | `binder` parses SrcBind, used for let-binds and function parameters.
binder :: FP.Parser SrcBind
binder = withSpan' (Bind <$> identifier)
--------------------------------------------------------------------------------
-- | Top level Rtype parser
--------------------------------------------------------------------------------
rtype :: FP.Parser RType
rtype = try rfun <|> rtype0
rtype0 :: FP.Parser RType
rtype0 = parens rtype
<|> rbase
rfun :: FP.Parser RType
rfun = mkTFun <$> funArg <*> (FP.reservedOp "=>" *> rtype)
funArg :: FP.Parser (F.Symbol, RType)
funArg = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))
<|> ((,) <$> freshArgSymbolP <*> rtype0)
freshArgSymbolP :: FP.Parser F.Symbol
freshArgSymbolP = do
n <- FP.freshIntP
return $ F.symbol ("_arg" ++ show n)
mkTFun :: (F.Symbol, RType) -> RType -> RType
mkTFun (x, s) = TFun x s
rbase :: FP.Parser RType
rbase = TBase <$> tbase <*> refTop
tbase :: FP.Parser Base
tbase = (reserved "int" >> pure TInt)
<|> (reserved "bool" >> pure TBool)
<|> tvarP
tvarP :: FP.Parser Base
tvarP = FP.reservedOp "'" >> FP.lowerIdP >>= return . TVar . TV
-- tVar :: F.Symbol -> Base
-- tVar = TVar . TV
refTop :: FP.Parser Reft
refTop = brackets reftB <|> pure mempty
reftB :: FP.Parser Reft
reftB = (question >> pure Unknown)
<|> KReft <$> (FP.lowerIdP <* mid) <*> FP.predP
mid :: FP.Parser ()
mid = FP.reservedOp "|"
question :: FP.Parser ()
question = FP.reservedOp "?"
-- >>> (parseWith rtype "" "int{v|v = 3}")
-- TBase TInt (v = 3)
-- >>> (parseWith rtype "" "int{v|v = x + y}")
-- TBase TInt (v = (x + y))
-- >>> (parseWith rtype "" "int")
-- TBase TInt true
-- >>> parseWith funArg "" "x:int"
-- ("x",TBase TInt true)
-- >>> parseWith rfun "" "int => int"
-- TFun "_" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int"
-- TFun "x" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int{v|0 < v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 < v))
-- >>> parseWith rfun "" "x:int => int{v|0 <= v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 <= v))
-- >>> parseWith rfun "" "x:int{v|0 <= v} => int{v|0 <= v}"
-- TFun "x" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))
-- | list of reserved words
keywords :: S.Set String
keywords = S.fromList
[ "if" , "else"
, "true" , "false"
, "let" , "in"
, "int"
]
================================================
FILE: src/Language/Sprite/L4/Prims.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L4.Prims where
import qualified Data.Maybe as Mb
import qualified Data.Map as M
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
-- import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.L4.Types
import Language.Sprite.L4.Parse
-- | Primitive Types --------------------------------------------------
constTy :: F.SrcSpan -> Prim -> RType
constTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n))
constTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)
constTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)
constTy l (PBin o) = binOpTy l o
binOpTy :: F.SrcSpan -> PrimOp -> RType
binOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv)
where
err = UX.panicS ("Unknown PrimOp: " ++ show o) l
bTrue :: Base -> RType
bTrue b = TBase b mempty
binOpEnv :: M.Map PrimOp RType
binOpEnv = M.fromList
[ (BPlus , mkTy "x:int => y:int => int[v|v=x+y]")
, (BMinus, mkTy "x:int => y:int => int[v|v=x-y]")
, (BTimes, mkTy "x:int => y:int => int[v|v=x*y]")
, (BLt , mkTy "x:int => y:int => bool[v|v <=> (x < y)]")
, (BLe , mkTy "x:int => y:int => bool[v|v <=> (x <= y)]")
, (BGt , mkTy "x:int => y:int => bool[v|v <=> (x > y)]")
, (BGe , mkTy "x:int => y:int => bool[v|v <=> (x >= y)]")
, (BEq , mkTy "x:int => y:int => bool[v|v <=> (x == y)]")
, (BAnd , mkTy "x:bool => y:bool => bool[v|v <=> (x && y)]")
, (BOr , mkTy "x:bool => y:bool => bool[v|v <=> (x || y)]")
, (BNot , mkTy "x:bool => bool[v|v <=> not x]")
]
mkTy :: String -> RType
mkTy = rebind . parseWith rtype "prims"
rebind :: RType -> RType
rebind t@(TBase {}) = t
rebind (TAll a t) = TAll a (rebind t)
rebind (TFun x s t) = TFun x' s' t'
where
x' = F.mappendSym "spec#" x
s' = subst (rebind s) x x'
t' = subst (rebind t) x x'
================================================
FILE: src/Language/Sprite/L4/Types.hs
================================================
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L4.Types where
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Misc as Misc
import Language.Sprite.Common
import qualified Data.Set as S
-- | Basic types --------------------------------------------------------------
newtype TVar = TV F.Symbol
deriving (Eq, Ord, Show)
instance F.Symbolic TVar where
symbol (TV a) = a
data Base = TInt | TBool | TVar TVar
deriving (Eq, Ord, Show)
-- | Refined Types ------------------------------------------------------------
data Type r
= TBase !Base r -- ^ Int{r}
| TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t
| TAll !TVar !(Type r)
deriving (Eq, Ord, Show)
rInt :: RType
rInt = TBase TInt mempty
rBool :: RType
rBool = TBase TBool mempty
data Reft
= Known !F.Symbol !H.Pred -- ^ Known refinement
| Unknown -- ^ Unknown, to-be-synth refinement
deriving (Show)
known :: F.Reft -> Reft
known (F.Reft (v, r)) = KReft v r
pattern KReft v p = Known v (H.Reft p)
instance Semigroup Reft where
Unknown <> r = r
r <> Unknown = r
-- KReft v1 r1 <> KReft v2 r2 = KReft v r where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)
Known v p <> Known v' p'
| v == v' = Known v (p <> p')
| v == F.dummySymbol = Known v' (p' <> (p `F.subst1` (v , F.EVar v')))
| otherwise = Known v (p <> (p' `F.subst1` (v', F.EVar v )))
-- _ <> _ = error "Semigroup Reft: TBD"
instance Monoid Reft where
mempty = KReft v r where F.Reft (v, r) = mempty
type RType = Type Reft
-- | Primitive Constants ------------------------------------------------------
data PrimOp
= BPlus
| BMinus
| BTimes
| BLt
| BLe
| BEq
| BGt
| BGe
| BAnd
| BOr
| BNot
deriving (Eq, Ord, Show)
data Prim
= PInt !Integer -- 0,1,2,...
| PBool !Bool -- true, false
| PBin !PrimOp -- +,-,==,<=,...
deriving (Eq, Ord, Show)
---------------------------------------------------------------------------------
-- | Terms ----------------------------------------------------------------------
---------------------------------------------------------------------------------
-- | Bindings -------------------------------------------------------------------
data Bind a
= Bind !F.Symbol a
deriving (Eq, Ord, Show, Functor)
bindId :: Bind a -> F.Symbol
bindId (Bind x _) = x
junkSymbol :: F.Symbol
junkSymbol = "_"
-- | "Immediate" terms (can appear as function args & in refinements) -----------
data Imm a
= EVar !F.Symbol a
| ECon !Prim a
deriving (Show, Functor)
-- | Variable definition ---------------------------------------------------------
data Decl a
= Decl (Bind a) (Expr a) a -- plain "let"
| RDecl (Bind a) (Expr a) a -- recursive "let rec"
deriving (Show, Functor)
-- | Terms -----------------------------------------------------------------------
data Expr a
= EImm !(Imm a) a -- ^ x,y,z,... 1,2,3...
| EFun !(Bind a) !(Expr a) a -- ^ \x -> e
| EApp !(Expr a) !(Imm a) a -- ^ e v
| ELet !(Decl a) !(Expr a) a -- ^ let/rec x = e1 in e2
| EAnn !(Expr a) !RType a -- ^ e:t
| EIf !(Imm a) !(Expr a) !(Expr a) a -- ^ if v e1 e2
| ETLam !TVar !(Expr a) a -- ^ Λ a. e (type abstraction)
| ETApp !(Expr a) !RType a -- ^ e [t] (type application)
deriving (Show, Functor)
instance Label Imm where
label (EVar _ l) = l
label (ECon _ l) = l
instance Label Expr where
label (EImm _ l) = l
label (EFun _ _ l) = l
label (EApp _ _ l) = l
label (ELet _ _ l) = l
label (EAnn _ _ l) = l
label (EIf _ _ _ l) = l
label (ETLam _ _ l) = l
label (ETApp _ _ l) = l
instance Label Decl where
label (Decl _ _ l) = l
label (RDecl _ _ l) = l
------------------------------------------------------------------------------
declsExpr :: [Decl a] -> Expr a
------------------------------------------------------------------------------
declsExpr [d] = ELet d (intExpr 0 l) l where l = label d
declsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d
declsExpr _ = error "impossible"
intExpr :: Integer -> a -> Expr a
intExpr i l = EImm (ECon (PInt i) l) l
boolExpr :: Bool -> a -> Expr a
boolExpr b l = EImm (ECon (PBool b) l) l
------------------------------------------------------------------------------
type SrcImm = Imm F.SrcSpan
type SrcBind = Bind F.SrcSpan
type SrcDecl = Decl F.SrcSpan
type SrcExpr = Expr F.SrcSpan
type ElbDecl = Decl F.SrcSpan
type ElbExpr = Expr F.SrcSpan
------------------------------------------------------------------------------
-- | should/need only be defined on "Known" variants. TODO:LIQUID
instance F.Subable Reft where
syms (Known v r) = v : F.syms r
syms Unknown = []
substa f (Known v r) = Known (f v) (F.substa f r)
substa _ (Unknown) = Unknown
substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r)
substf _ (Unknown) = Unknown
subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)
subst _ (Unknown) = Unknown
subst1 (Known v r) su = Known v (F.subst1Except [v] r su)
subst1 (Unknown) _ = Unknown
instance F.Subable r => F.Subable (Type r) where
-- syms :: a -> [Symbol]
syms (TBase _ r) = F.syms r
syms (TAll _ t) = F.syms t
syms (TFun _ s t) = F.syms s ++ F.syms t
-- substa :: (Symbol -> Symbol) -> Type r -> Type r
substa f (TBase b r) = TBase b (F.substa f r)
substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)
substa f (TAll a t) = TAll a (F.substa f t)
-- substf :: (Symbol -> Expr) -> Type r -> Type r
substf f (TBase b r) = TBase b (F.substf f r)
substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)
substf f (TAll a t) = TAll a (F.substf f t)
-- subst :: Subst -> a -> a
subst f (TBase b r) = TBase b (F.subst f r)
subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)
subst f (TAll a t) = TAll a (F.subst f t)
--------------------------------------------------------------------------------
-- | Substitution --------------------------------------------------------------
--------------------------------------------------------------------------------
substImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a
substImm thing x y = F.subst su thing
where
su = F.mkSubst [(x, immExpr y)]
subst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a
subst thing x y = substImm thing x (EVar y ())
immExpr :: Imm b -> F.Expr
immExpr (EVar x _) = F.expr x
immExpr (ECon (PInt n) _) = F.expr n
immExpr (ECon (PBool True) _) = F.PTrue
immExpr (ECon (PBool False) _) = F.PFalse
immExpr _ = error "impossible"
--------------------------------------------------------------------------------
-- | Dealing with Type Variables -----------------------------------------------
--------------------------------------------------------------------------------
tsubst :: TVar -> RType -> RType -> RType
tsubst a t = go
where
go (TAll b s)
| a == b = TAll b s
| otherwise = TAll b (go s)
go (TFun x s1 s2) = TFun x (go s1) (go s2)
go (TBase b r) = bsubst a t b r
bsubst :: TVar -> RType -> Base -> Reft -> RType
bsubst a t (TVar v) r
| v == a = strengthenTop t r
bsubst _ _ b r = TBase b r
strengthenTop :: RType -> Reft -> RType
strengthenTop t@(TFun {}) _ = t
strengthenTop t@(TAll {}) _ = t
strengthenTop (TBase b r) r' = TBase b (r <> r')
generalize :: RType -> RType
generalize t = foldr TAll t (freeTVars t)
freeTVars :: RType -> [TVar]
freeTVars = Misc.sortNub . S.toList . go
where
go (TAll a t) = S.delete a (go t)
go (TFun _ s t) = S.union (go s) (go t)
go (TBase b _) = goB b
goB (TVar a) = S.singleton a
goB _ = S.empty
================================================
FILE: src/Language/Sprite/L4.hs
================================================
module Language.Sprite.L4 ( sprite ) where
import System.Exit
import qualified Language.Fixpoint.Types as F
import Language.Sprite.L4.Check
import Language.Sprite.L4.Parse
import Language.Sprite.Common
--------------------------------------------------------------------------------
sprite :: FilePath -> IO ()
--------------------------------------------------------------------------------
sprite f = do
src <- parseFile f
res <- case vcgen src of
Left errs -> pure (crash errs "VCGen failure")
Right vc -> checkValid f vc
ec <- resultExit res
exitWith ec
================================================
FILE: src/Language/Sprite/L5/Check.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use uncurry" #-}
module Language.Sprite.L5.Check (vcgen) where
import Control.Monad (void)
import qualified Data.HashMap.Strict as M
-- import qualified Data.Maybe as Mb
-- import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Misc as Misc
import qualified Language.Sprite.Common.UX as UX
-- import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.Common
import Language.Sprite.L5.Types
import Language.Sprite.L5.Prims
import Language.Sprite.L5.Constraints
import Language.Sprite.L5.Elaborate
-- import Debug.Trace (trace)
-------------------------------------------------------------------------------
vcgen:: SrcProg -> Either [UX.UserError] SrcQuery
-------------------------------------------------------------------------------
vcgen (Prog qs ms e typs) = do
let env = empEnv typs
let eL = elaborate env e
(c, ks) <- run (check env eL (bTrue TInt))
return $ H.Query qs ks c (M.fromList ms) mempty mempty mempty mempty mempty
-------------------------------------------------------------------------------
sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr
-------------------------------------------------------------------------------
{- | [Sub-Base]
(v::t) => q[w := v]
-------------------
b{v:p} <= b{w:q}
-}
sub l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))
| b1 == b2 = return (cAll l v s (cHead l (subst q w v)))
| otherwise = failWith ("Invalid Subtyping: " <+> F.pprint (b1, b2)) l
{- | [Sub-Fun]
(v::t) => q[w := v]
-------------------
b{v:p} <: b{w:q}
s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2
-------------------------------------
x1:s1 -> t1 <: x2:s2 -> t2
-}
sub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
cI <- sub l s2 s1
cO <- cAll l x2 s2 <$> sub l t1' t2
return (cAnd cI cO)
where
t1' = subst t1 x1 x2
{- | [Sub-TCon]
G,v:int{p} |- q[w:=v] G |- si <: ti
-----------------------------------------
G |- (C s1...)[v|p] <: (C t1...)[w|q]
-}
sub l s@(TCon c1 t1s (Known v _)) (TCon c2 t2s (Known w q)) | c1 == c2 = do
let cTop = cAll l v s (cHead l (subst q w v))
cIns <- subs l t1s t2s
return (Misc.traceShow "SUB-LIST" $ cAnd cTop cIns)
sub l t1 t2 = failWith ("sub: cannot handle:" <+> UX.tshow (t1, t2)) l
subs :: F.SrcSpan -> [RType] -> [RType] -> CG SrcCstr
subs _ [] [] = return cTrue
subs l (t1:t1s) (t2:t2s) = cAnd <$> sub l t1 t2 <*> subs l t1s t2s
subs l _ _ = failWith "subs: invalid args" l
--------------------------------------------------------------------
-- | 'Checking' constraints
--------------------------------------------------------------------
check :: Env -> SrcExpr -> RType -> CG SrcCstr
--------------------------------------------------------------------
{- [Chk-Lam]
G, x:s[y:=x] |- e <== t[y:=x]
-----------------------------
G |- \x.e <== y:s -> t
-}
check g (EFun bx e l) (TFun y s t) = do
c <- check (extEnv g x s') e t'
return $ cAll l x s c
where
x = bindId bx
s' = subst s y x
t' = subst t y x
{- [Chk-Let]
G |- e ==> s G, x:s |- e' <== t'
-------------------------------------------
G |- let x = e in e' <== t'
-}
check g (ELet (Decl (Bind x l) e _) e' _) t' = do
(c, s) <- synth g e
c' <- check (extEnv g x s) e' t'
return $ cAnd c (cAll l x s c')
{- [Chk-Rec]
t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'
---------------------------------------------------------[Chk-Rec]
G |- letrec f = (e:s) in e' <== t'
-}
check g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do
t <- fresh l g s
let g' = extEnv g x t
c <- check g' e t
c' <- check g' e' t'
return $ cAnd c c'
{- [Chk-If]
G |- v <== bool
G, _:{v} |- e1 <== t
G, _:{not v} |- e2 <== t
----------------------------- [Chk-If]
G |- if v e1 e2 <== t
-}
check g (EIf v e1 e2 l) t = do
_ <- check g (EImm v l) rBool
c1 <- cAll l xv tT <$> check g e1 t
c2 <- cAll l xv tF <$> check g e2 t
return (cAnd c1 c2)
where
tT = predRType pv
tF = predRType (F.PNot pv)
pv = immExpr v
xv = grdSym g
{- [Chk-Switch]
G | y |- a_i <== t
---------------------------
G |- switch y {a_1...} <== t
-}
check g (ECase y alts _) t = do
H.CAnd <$> mapM (checkAlt g y t) alts
{- [Chk-TLam]
G, a |- e <== t
------------------------ [Chk-TLam]
G |- Λ a. e <== all a. t
-}
check g (ETLam a e _) (TAll b t) | a == b = do
check g e t
{- [Chk-Syn]
G |- e ==> s G |- s <: t
----------------------------------[Chk-Syn]
G |- e <== t
-}
check g e t = do
let l = label e
(c, s) <- synth g e
c' <- sub l s t
return (cAnd c c')
{- [Chk-Syn-Imm] -}
checkImm :: Env -> SrcImm -> RType -> CG SrcCstr
checkImm g i t = do
s <- synthImm g i
sub (label i) s t
{- [Chk-Alt]
unfold(G, c, y) === s G | y + z... * s ~~> G' G' |- e <== t
---------------------------------------------------------------
G | y |- C z... -> e <== t
-}
checkAlt :: Env -> Ident -> RType -> SrcAlt -> CG SrcCstr
checkAlt g y t (Alt c zs e l) = do
let al = mconcat (label <$> zs)
case unfoldEnv g y c zs of
Nothing -> failWith "checkAlt: incompatible pattern" al
Just zts -> cAlls l zts <$> check (extEnvs g zts) e t
cAlls :: F.SrcSpan -> [(F.Symbol, RType)] -> SrcCstr -> SrcCstr
cAlls l xts c = foldr (\(x, t) -> cAll l x t) c (reverse xts)
-- cAlls l [] c = c
-- cAlls l ((x,t):xts) c = cAll l xts (cAll l x t c)
--------------------------------------------------------------------
-- | 'Synthesis' constraints
--------------------------------------------------------------------
singleton :: F.Symbol -> RType -> RType
singleton x (TBase b (Known v p)) = TBase b (Known v (pAnd [p, v `peq` x]))
singleton x (TCon c ts (Known v p)) = TCon c ts (Known v (pAnd [p, v `peq` x]))
singleton _ t = t
peq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred
peq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))
synthImm :: Env -> SrcImm -> CG RType
{- [Syn-Var]
-----------------
G |- x ==> G(x)
-}
synthImm g (EVar x l)
| Just t <- getEnv g x = return (singleton x t)
| otherwise = failWith ("Unbound variable:" <+> F.pprint x) l
{- [Syn-Con]
-----------------
G |- x ==> ty(c)
-}
synthImm _ (ECon c l) = return (constTy l c)
synth :: Env -> SrcExpr -> CG (SrcCstr, RType)
{- [Syn-Con], [Syn-Var] -}
synth g (EImm i _) = do
t <- synthImm g i
return (cTrue, t)
{- [Syn-Ann]
G |- e <== t t := fresh(s)
---------------------------
G |- e:s => t
-}
synth g (EAnn e s l) = do
t <- fresh l g s
c <- check g e t
return (c, t)
{- [Syn-App]
G |- e ==> x:s -> t
G |- y <== s
-----------------------
G |- e y ==> t[x := y]
-}
synth g (EApp e y l) = do
(ce, te) <- synth g e
case te of
TFun x s t -> do cy <- checkImm g y s
return (cAnd ce cy, substImm t x y)
_ -> failWith "Application to non-function" l
{- [Syn-TApp]
G |- e ==> all a. s
---------------------------
G |- e[t] ==> s [ a := t]
-}
synth g (ETApp e t l) = do
(ce, te) <- synth g e
case te of
TAll a s -> do tt <- {- Misc.traceShow "REFRESH" <$> -} refresh l g t
return (ce, Misc.traceShow "SYN-TApp: " $ tsubst a tt s)
_ -> failWith "Type Application to non-forall" l
synth _ e =
failWith ("synth: cannot handle: " <+> text (show (void e))) (label e)
-------------------------------------------------------------------------------
-- | Fresh templates for `Unknown` refinements
-------------------------------------------------------------------------------
refresh :: F.SrcSpan -> Env -> RType -> CG RType
refresh l g = fresh l g . go
where
go (TBase b _) = TBase b Unknown
go (TFun b s t) = TFun b (go s) (go t)
go (TCon c ts _) = TCon c (go <$> ts) Unknown
go (TAll a t) = TAll a (go t)
fresh :: F.SrcSpan -> Env -> RType -> CG RType
fresh l g t@(TBase b r) = TBase b <$> freshR l g (rTypeSort t) r
fresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t
fresh l g t@(TCon c ts r) = TCon c <$> mapM (fresh l g) ts <*> freshR l g (rTypeSort t) r
fresh l g (TAll a t) = TAll a <$> fresh l g t
freshR :: F.SrcSpan -> Env -> F.Sort -> Reft -> CG Reft
freshR _ _ _ r@(Known {}) = pure r
freshR l g t Unknown = freshK l g t
================================================
FILE: src/Language/Sprite/L5/Constraints.hs
================================================
-- | This module has the kit needed to do constraint generation:
-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L5.Constraints
( -- * Constraints
cTrue, cAnd, cHead, cAll, pAnd
-- * Substitutions
, subst, substImm
-- * Conversions
, predRType, rTypeSort
-- * Environments
, Env, empEnv, getEnv, extEnv, extEnvs
, extEnvTV, grdSym, envSorts
-- * Case-Related manipulation
, unfoldEnv, unfoldEnv'
-- * Constraint Generation Monad
, CG, run, failWith, freshK
) where
import qualified Data.List as L
import qualified Data.Maybe as Mb
import Control.Monad.State
import Control.Monad.Except (throwError)
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.Common
import Language.Sprite.L5.Types
import Language.Sprite.L5.Prims
--------------------------------------------------------------------------------
-- | Constraints ---------------------------------------------------------------
--------------------------------------------------------------------------------
cTrue :: SrcCstr
cTrue = H.CAnd []
cAnd :: SrcCstr -> SrcCstr -> SrcCstr
cAnd (H.CAnd []) c = c
cAnd c (H.CAnd []) = c
cAnd c1 c2 = H.CAnd [c1, c2]
cHead :: F.SrcSpan -> H.Pred -> SrcCstr
cHead _ (H.Reft p)
| F.isTautoPred p = cTrue
cHead l (H.PAnd ps) = case filter (not . pTrivial) ps of
[] -> cTrue
[p] -> mkHead l p
qs -> mkHead l (H.PAnd qs)
cHead l p = mkHead l p
mkHead :: F.SrcSpan -> H.Pred -> SrcCstr
mkHead l p = case smash p of
[] -> cTrue
[q] -> mk1 l q
qs -> H.CAnd (mk1 l <$> qs)
mk1 :: F.SrcSpan -> H.Pred -> SrcCstr
mk1 l p = H.Head p (UX.mkError "Subtype error" l)
smash :: H.Pred -> [H.Pred]
smash (H.PAnd ps) = concatMap smash ps
smash p = [p]
cAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr
cAll l x t c = case sortPred x t of
Just (so, p) -> H.All (bind l x so p) c
_ -> c
pAnd :: [H.Pred] -> H.Pred
pAnd ps = case filter (not . pTrivial) ps of
[p] -> p
ps' -> H.PAnd ps'
pTrivial :: H.Pred -> Bool
pTrivial (H.PAnd []) = True
pTrivial (H.Reft p) = F.isTautoPred p
pTrivial _ = False
sortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)
sortPred x t@(TBase _ (Known v p)) = Just (rTypeSort t, subst p v x)
sortPred x t@(TCon _ _ (Known v p)) = Just (rTypeSort t, subst p v x)
sortPred _ _ = Nothing
--------------------------------------------------------------------------------
-- | Environments --------------------------------------------------------------
--------------------------------------------------------------------------------
data Env = Env
{ eBinds :: !(F.SEnv RType) -- ^ value binders
, eSize :: !Integer -- ^ number of binders?
, eTVars :: !(F.SEnv ()) -- ^ type variables
}
extEnv :: Env -> F.Symbol -> RType -> Env
extEnv env x t
| x == junkSymbol = env
| otherwise = env { eBinds = F.insertSEnv x t (eBinds env)
, eSize = 1 + eSize env
}
extEnvs :: Env -> [(F.Symbol, RType)] -> Env
extEnvs = L.foldl' (\g (x, t) -> extEnv g x t)
extEnvTV :: Env -> TVar -> Env
extEnvTV env (TV a) = env { eTVars = F.insertSEnv a () (eTVars env) }
grdSym :: Env -> F.Symbol
grdSym env = F.tempSymbol "grd" (eSize env)
predRType :: F.Pred -> RType
predRType p = TBase TBool (known $ F.predReft p)
getEnv :: Env -> F.Symbol -> Maybe RType
getEnv env x = F.lookupSEnv x (eBinds env)
empEnv :: [SrcData] -> Env
empEnv typs = Env ctorEnv 0 F.emptySEnv
where
ctorEnv = F.fromListSEnv (prelude ++ concatMap dataSigs typs)
dataSigs :: SrcData -> [(F.Symbol, RType)]
dataSigs (Data _ _ ctors) = [(F.symbol b, t) | (b, t) <- ctors]
envSorts :: Env -> [(F.Symbol, F.Sort)]
envSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)
, (t, _) <- Mb.maybeToList (sortPred x s) ]
--------------------------------------------------------------------------------
-- | Case-Related Environment Manipulation -------------------------------------
--------------------------------------------------------------------------------
unfoldEnv' :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe Env
unfoldEnv' g y c zs = extEnvs g <$> unfoldEnv g y c zs
unfoldEnv :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe [(F.Symbol, RType)]
unfoldEnv g y c zs = unfold g c y >>= extCase y zs
unfold:: Env -> DaCon -> Ident -> Maybe (RType, RType)
unfold g c y = do
sig <- getEnv g c
ty@(TCon _ ts _) <- getEnv g y
let (as, t) = bkAll sig
ats <- Misc.safeZip as ts
return (ty, tsubsts ats t)
extCase :: Ident -> [SrcBind] -> (RType, RType) -> Maybe [(F.Symbol, RType)]
extCase y zs (ty, t) = go [] (F.symbol <$> zs) t
where
go acc (z:zs) (TFun x s t) = go ((z, s) : acc) zs (subst t x z)
go acc [] t = Just ((y, meet ty t) : acc)
go _ _ _ = Nothing
meet :: RType -> RType -> RType
meet t1 t2 = case rTypeReft t2 of
Just r2 -> strengthenTop t1 r2
Nothing -> t1
{-
extCaseEnv :: Env -> [Bind F.SrcSpan] -> RType -> Maybe Env
extCaseEnv g (z:zs) (TFun _ s t) = extCaseEnv g' zs t
where
g' = extEnv g (F.symbol z) s
extCaseEnv g [] _ = Just g
extCaseEnv _ _ _ = Nothing
-}
-------------------------------------------------------------------------------
-- | CG Monad -----------------------------------------------------------------
-------------------------------------------------------------------------------
type CG a = StateT CGState (Either [UX.UserError]) a
data CGState = CGState
{ cgCount :: !Integer -- ^ monotonic counter, to get fresh things
, cgKVars :: ![SrcHVar] -- ^ list of generated kvars
}
s0 :: CGState
s0 = CGState 0 []
run :: CG a -> Either [UX.UserError] (a, [SrcHVar])
run act = do
(x, s) <- runStateT act s0
return (x, cgKVars s)
failWith :: UX.Text -> F.SrcSpan -> CG a
failWith msg l = throwError [UX.mkError msg l]
freshK :: F.SrcSpan -> Env -> F.Sort -> CG Reft
freshK l g t = do
v <- freshValueSym
k <- freshKVar l t ts
return $ Known v (H.Var k (v:xs))
where
-- t = baseSort b
(xs,ts) = unzip (envSorts g)
freshKVar :: F.SrcSpan -> F.Sort -> [F.Sort] -> CG F.Symbol
freshKVar l t ts = do
k <- F.kv . F.intKvar <$> freshInt
_ <- addSrcKVar (H.HVar k (t:ts) (UX.mkError "fake" l))
return k
addSrcKVar :: SrcHVar -> CG ()
addSrcKVar k = modify $ \s -> s { cgKVars = k : cgKVars s }
freshValueSym :: CG F.Symbol
freshValueSym = F.vv . Just <$> freshInt
freshInt :: CG Integer
freshInt = do
s <- get
let n = cgCount s
put s { cgCount = 1 + n}
return n
================================================
FILE: src/Language/Sprite/L5/Elaborate.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Language.Sprite.L5.Elaborate (elaborate) where
import qualified Data.Maybe as Mb
import qualified Data.List as L
import Control.Exception (throw)
import Control.Monad.State
import Control.Monad.Except (throwError)
import Text.PrettyPrint.HughesPJ
-- import Text.Printf (printf)
import qualified Language.Fixpoint.Types as F
import Language.Sprite.Common
-- import qualified Language.Sprite.Common.Misc as Misc
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.L5.Prims
import Language.Sprite.L5.Types
import Language.Sprite.L5.Constraints
import Debug.Trace (trace)
import Control.Monad (void)
-------------------------------------------------------------------------------
elaborate :: Env -> SrcExpr -> ElbExpr
-------------------------------------------------------------------------------
elaborate g e = {- trace _msg -} e''
where
_msg = "elaborate: " ++ show (F.toListSEnv su, void e, void e'')
e'' = subsTy su e'
(su, e') = runElabM act
act = elabC g e (bTrue TInt)
runElabM :: ElabM a -> (TvSub, a)
runElabM act = case runStateT act s0 of
Left errs -> throw errs
Right (v, s) -> (eSub s, v)
where s0 = ElabS mempty 0
type TvSub = F.SEnv RType
data ElabS = ElabS { eSub :: !TvSub, eNum :: !Int }
type ElabM a = StateT ElabS (Either [UX.UserError]) a
unifyV :: F.SrcSpan -> TVar -> RType -> ElabM RType
unifyV _ a t@(TBase (TVar b) r)
| a == b
= return t
| nonRigid a
= assign a t >> return t
| nonRigid b
= assign b t' >> return t' where t' = TBase (TVar a) r
unifyV l a t
| a `elem` freeTVars t
= occurError l a t
| nonRigid a
= assign a t >> return t
| otherwise
= rigidError l a t
unify :: F.SrcSpan -> RType -> RType -> ElabM RType
unify l (TBase (TVar a) _) t =
unifyV l a t
unify l t (TBase (TVar a) _) =
unifyV l a t
unify _ t1@(TBase b1 _) (TBase b2 _) | b1 == b2 =
return t1
unify l (TFun x1 s1 t1) (TFun x2 s2 t2) = do
x <- pure (unifyX l x1 x2)
s <- unify l s1 s2
t1' <- subsTyM t1
t2' <- subsTyM t2
t <- unify l t1' t2'
return (TFun x s t)
unify l (TCon c1 t1s _) (TCon c2 t2s _) | c1 == c2 = do
ts <- unifys l t1s t2s
return (TCon c1 ts mempty)
unify l t1 t2 =
unifyError l t1 t2
unifys :: F.SrcSpan -> [RType] -> [RType] -> ElabM [RType]
unifys _ [] [] =
return []
unifys l (t1:t1s) (t2:t2s) = do
t <- unify l t1 t2
t1s' <- mapM subsTyM t1s
t2s' <- mapM subsTyM t2s
ts <- unifys l t1s' t2s'
return (t:ts)
unifys l _ _ =
throwError [UX.mkError "unifys-mismatched args" l]
unifyX :: F.SrcSpan -> F.Symbol -> F.Symbol -> F.Symbol
unifyX _ x _ = x
unifyError :: F.SrcSpan -> RType -> RType -> ElabM a
unifyError l t1 t2 = throwError [UX.mkError msg l]
where msg = "type error: cannot unify" <+> UX.tshow t1 <+> "and" <+> UX.tshow t2
rigidError :: F.SrcSpan -> TVar -> RType -> ElabM a
rigidError l a t = throwError [UX.mkError msg l]
where msg = "type error: cannot assign rigid" <+> UX.tshow a <+> "the type" <+> UX.tshow t
occurError :: F.SrcSpan -> TVar -> RType -> ElabM a
occurError l a t = throwError [UX.mkError msg l]
where msg = "type error: occurs check" <+> UX.tshow a <+> "occurs in" <+> UX.tshow t
matchError :: F.SrcSpan -> Doc -> ElabM a
matchError l msg = throwError [UX.mkError ("case-alt error:" <+> msg) l]
-------------------------------------------------------------------------------
elabC :: Env -> SrcExpr -> RType -> ElabM ElbExpr
elabC g (EFun b e l) (TFun _ s t) = do
e' <- elabC (extEnv g (bindId b) s) e t
return $ EFun b e' l
-- let rec x:s = e1 in e2
elabC g (ELet (RDecl (Bind x l) (EAnn e1 s1 l1) ld) e2 l2) t2 = do
let g' = extEnv g x s1
let (as, t1) = splitTAll s1
e1' <- elabC (extEnvTVs g' as) e1 t1
e2' <- elabC g' e2 t2
return $ ELet (RDecl (Bind x l) (EAnn (mkTLam e1' as) s1 l1) ld) e2' l2
-- let x = e in e'
elabC g (ELet (Decl (Bind x l) e1 l1) e2 l2) t2 = do
(e1', s) <- elabS g e1
e2' <- elabC (extEnv g x s) e2 t2
return $ ELet (Decl (Bind x l) e1' l1) e2' l2
-- if b e1 e2
elabC g (EIf b e1 e2 l) t = do
e1' <- elabC g e1 t
e2' <- elabC g e2 t
return $ EIf b e1' e2' l
-- switch (y) { | C(z..) => e | ... }
elabC g (ECase y alts l) t = do
alts' <- mapM (elabAlt g y t) alts
return $ ECase y alts' l
elabC g e t = do
(e', t') <- elabS g e
unify (label e) t t'
return e'
elabAlt :: Env -> Ident -> RType -> SrcAlt -> ElabM SrcAlt
elabAlt g y t (Alt c zs e l) = do
let al = mconcat (label <$> zs)
case unfoldEnv' g y c zs of
Nothing -> matchError al "bad pattern match"
Just g' -> (\e' -> Alt c zs e' l) <$> elabC g' e t
immS :: Env -> SrcImm -> ElabM ([RType], RType)
immS g i = instantiate =<< immTy g i
extEnvTVs :: Env -> [TVar] -> Env
extEnvTVs = foldr (flip extEnvTV)
-------------------------------------------------------------------------------
elabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType)
elabS g e@(EImm i _) = do
(ts, t') <- {- Misc.traceShow ("elabS: " ++ show i) <$> -} immS g i
return (mkTApp e ts, t')
elabS g (EAnn e s l) = do
let (as, t) = splitTAll s
e' <- elabC (extEnvTVs g as) e t
return (EAnn (mkTLam e' as) s l, s)
elabS g (EApp e y l) = do
(e', te) <- elabS g e
case te of
TFun _ s t -> do (\yt -> unify l s ({- Misc.traceShow ("elabS1 " ++ show s) -} yt) ) =<< immTy g y
t' <- subsTyM t
return (EApp e' y l, t')
_ -> elabErr "Application to non-function" l
elabS _ e =
elabErr ("elabS unexpected:" <+> UX.tshow (void e)) (label e)
-------------------------------------------------------------------------------
elabErr :: UX.Text -> F.SrcSpan -> ElabM a
elabErr msg l = throwError [UX.mkError msg l]
instantiate :: RType -> ElabM ([RType], RType)
instantiate = go []
where
go ts (TAll a s) = do v <- fresh
let vt = TBase (TVar v) mempty
go (vt:ts) (tsubst a vt s)
go ts s = return (reverse ts, s)
splitTAll :: RType -> ([TVar], RType)
splitTAll (TAll a s) = (a:as, t) where (as, t) = splitTAll s
splitTAll t = ([] , t)
fresh :: ElabM TVar
fresh = do
s <- get
let n = eNum s
put s { eNum = n + 1 }
return (nonRigidTV n)
nonRigidTV :: Int -> TVar
nonRigidTV = TV . F.intSymbol "fv"
nonRigid :: TVar -> Bool
nonRigid (TV a) = F.isPrefixOfSym "fv" a
immTy :: Env -> SrcImm -> ElabM RType
immTy g (EVar x l)
| Just t <- getEnv g x = return ({- Misc.traceShow ("immTy: " ++ show x) -} t)
| otherwise = elabErr ("Unbound variable:" <+> F.pprint x) l
immTy _ (ECon c l) = return (constTy l c)
mkTLam :: SrcExpr -> [TVar] -> ElbExpr
mkTLam = foldr (\a e -> ETLam a e (label e))
mkTApp :: SrcExpr -> [RType] -> ElbExpr
mkTApp = L.foldl' (\e t -> ETApp e t (label e))
-- | Type Substitutions --------------------------------------------------------------
class SubsTy a where
subsTy :: TvSub -> a -> a
subsTy1 :: TVar -> RType -> a -> a
subsTy1 a t x = subsTy (singTvSub a t) x
singTvSub :: TVar -> RType -> TvSub
singTvSub a t = F.fromListSEnv [(F.symbol a, t)]
instance SubsTy RType where
subsTy su t@(TBase (TVar a) _) = Mb.fromMaybe t t'
where
t' = F.lookupSEnv (F.symbol a) su
subsTy _su t@(TBase {}) = t
subsTy su (TCon c ts r) = TCon c (subsTy su <$> ts) r
subsTy su (TFun x s t) = TFun x s' t'
where
s' = subsTy su s
t' = subsTy su t
subsTy su (TAll a t) = TAll a t'
where
t' = subsTy su' t
su' = F.deleteSEnv (F.symbol a) su
instance SubsTy TvSub where
subsTy = F.mapSEnv . subsTy
-- applies the substs to the ETApp types
instance SubsTy ElbExpr where
subsTy = subsTyExpr
instance SubsTy ElbDecl where
subsTy su (Decl b e l) = Decl b (subsTy su e) l
subsTy su (RDecl b e l) = RDecl b (subsTy su e) l
subsTyExpr :: TvSub -> ElbExpr -> ElbExpr
subsTyExpr su = go
where
go (EFun b e l) = EFun b (go e) l
go (EApp e i l) = EApp (go e) i l
go (ELet d e l) = ELet d' (go e) l where d' = subsTy su d
go (EAnn e t l) = EAnn (go e) t l
go (EIf i e1 e2 l) = EIf i (go e1) (go e2) l
go (ETLam a e l) = ETLam a (go e) l
go (ETApp e t l) = ETApp (go e) (subsTy su t) l
go (ECase x as l) = ECase x (goA <$> as) l
go e@(EImm {}) = e
goA alt = alt -- { altTyArgs = fmap (subsTy su) <$> altTyArgs alt }
{ altExpr = go $ altExpr alt }
subsTyM :: (SubsTy a) => a -> ElabM a
subsTyM x = do
su <- gets eSub
return (subsTy su x)
assign :: TVar -> RType -> ElabM ()
assign a t = modify $ \s -> s { eSub = updSub a t (eSub s)}
updSub :: TVar -> RType -> TvSub -> TvSub
updSub a t su = F.insertSEnv (F.symbol a) t (subsTy1 a t su)
================================================
FILE: src/Language/Sprite/L5/Parse.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L5.Parse
(
-- * Parsing programs
parseFile
, parseWith
-- * Parsing combinators
, measureP
, rtype
, expr
, typP
, switchExpr
, altP
) where
import qualified Data.Maybe as Mb
import qualified Data.Set as S
import qualified Data.List as L
import Control.Monad.Combinators.Expr
import Text.Megaparsec hiding (State, label)
import Text.Megaparsec.Char
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Parse as FP
import Language.Sprite.Common
import Language.Sprite.Common.Parse
import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.L5.Types hiding (immExpr)
-- import Language.Sprite.L5.Constraints
parseFile :: FilePath -> IO SrcProg
parseFile = FP.parseFromFile prog
parseWith :: FP.Parser a -> FilePath -> String -> a
parseWith = FP.doParse'
--------------------------------------------------------------------------------
-- | Top-Level Expression Parser
--------------------------------------------------------------------------------
prog :: FP.Parser SrcProg
prog = do
qs <- quals
ms <- try (many measureP) <|> return []
typs <- many typP
src <- declsExpr <$> many decl
return (Prog qs ms src (Misc.traceShow "prog-types" typs))
measureP :: FP.Parser (F.Symbol, F.Sort)
measureP = annL >> (Misc.mapSnd (rTypeSort . generalize) <$> tyBindP "measure")
typP :: FP.Parser SrcData
typP = do
reserved "type"
tc <- FP.lowerIdP
args <- typArgs
FP.reservedOp "=" >> whiteSpace
ctors <- ctorsP
return (Data tc args (mkCtor tc args <$> ctors))
data Ctor = Ctor SrcBind [FunArg] (Maybe Reft)
type FunArg = (F.Symbol, RType)
ctorsP :: FP.Parser [Ctor]
ctorsP = try (FP.semi >> return [])
<|> (:) <$> ctorP <*> ctorsP
ctorP :: FP.Parser Ctor
ctorP = Ctor <$> (whiteSpace *> mid *> cbind) <*> commaList funArgP <*> ctorResP
cbind :: FP.Parser SrcBind
cbind = withSpan' (Bind <$> FP.upperIdP)
typArgs :: FP.Parser [F.Symbol]
typArgs = commaList tvarP
ctorResP :: FP.Parser (Maybe Reft)
ctorResP = Just <$> (FP.reservedOp "=>" *> brackets concReftB)
<|> return Nothing
mkCtor :: Ident -> [Ident] -> Ctor -> (SrcBind, RType)
mkCtor tc args c = (dc, generalize dcType)
where
dcType = foldr (\(x, t) s -> TFun x t s) dcRes xts
dcRes = TCon tc (rVar <$> args) dcReft
Ctor dc xts r = c
dcReft = Mb.fromMaybe mempty r
commaList :: FP.Parser a -> FP.Parser [a]
commaList p = try (parens (sepBy p comma)) <|> return []
quals :: FP.Parser [F.Qualifier]
quals = try ((:) <$> between annL annR qual <*> quals)
<|> pure []
qual ::FP.Parser F.Qualifier
qual = reserved "qualif" >> FP.qualifierP (rTypeSort <$> rtype)
expr :: FP.Parser SrcExpr
expr = try funExpr
<|> try letExpr
<|> try ifExpr
<|> try switchExpr
<|> try (FP.braces (expr <* whiteSpace))
<|> try appExpr
<|> try binExp
<|> expr0
expr0 :: FP.Parser SrcExpr
expr0 = try (FP.parens expr)
<|> immExpr
appExpr :: FP.Parser SrcExpr
appExpr = mkEApp <$> immExpr <*> parens (sepBy1 imm comma)
binExp :: FP.Parser SrcExpr
binExp = withSpan' $ do
x <- imm
o <- op
y <- imm
return (bop o x y)
op :: FP.Parser PrimOp
op = (FP.reservedOp "*" >> pure BTimes)
<|> (FP.reservedOp "+" >> pure BPlus )
<|> (FP.reservedOp "-" >> pure BMinus)
<|> (FP.reservedOp "<" >> pure BLt )
<|> (FP.reservedOp "<=" >> pure BLe )
<|> (FP.reservedOp "==" >> pure BEq )
<|> (FP.reservedOp ">" >> pure BGt )
<|> (FP.reservedOp ">=" >> pure BGe )
<|> (FP.reservedOp "&&" >> pure BAnd )
<|> (FP.reservedOp "||" >> pure BOr )
bop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr
bop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]
mkEApp :: SrcExpr -> [SrcImm] -> SrcExpr
mkEApp = L.foldl' (\e y -> EApp e y (label e <> label y))
letExpr :: FP.Parser SrcExpr
letExpr = withSpan' (ELet <$> decl <*> expr)
ifExpr :: FP.Parser SrcExpr
ifExpr = withSpan' $ do
FP.reserved "if"
v <- parens imm
e1 <- expr
FP.reserved "else"
e2 <- expr
return (EIf v e1 e2)
switchExpr :: FP.Parser SrcExpr
switchExpr = withSpan' $ do
FP.reserved "switch"
x <- parens FP.lowerIdP
alts <- braces (many altP)
return (ECase x alts)
altP :: FP.Parser SrcAlt
altP = withSpan' $ Alt
<$> (whiteSpace *> mid *> FP.upperIdP)
-- <*> pure Nothing
<*> commaList binder
<*> (FP.reservedOp "=>" *> expr)
immExpr :: FP.Parser SrcExpr
immExpr = do
i <- imm
return (EImm i (label i))
imm :: FP.Parser SrcImm
imm = immInt <|> immBool <|> immId
immInt :: FP.Parser SrcImm
immInt = withSpan' (ECon . PInt <$> FP.natural)
immBool :: FP.Parser SrcImm
immBool = withSpan' (ECon . PBool <$> bool)
immId :: FP.Parser SrcImm
immId = withSpan' (EVar <$> identifier')
bool :: FP.Parser Bool
bool = (reserved "true" >> pure True)
<|>(reserved "false" >> pure False)
funExpr :: FP.Parser SrcExpr
funExpr = withSpan' $ do
xs <- parens (sepBy1 binder comma)
_ <- FP.reservedOp "=>"
-- _ <- FP.reservedOp "{"
body <- braces (expr <* whiteSpace)
-- _ <- FP.reservedOp "}"
return $ mkEFun xs body
mkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr
mkEFun bs e0 l = foldr (\b e -> EFun b e l) e0 bs
-- | Annotated declaration
decl :: FP.Parser SrcDecl
decl = mkDecl <$> ann <*> plainDecl
where
ann = (annL >> (Just <$> tyBindP "val")) <|> pure Nothing
type Ann = Maybe (F.Symbol, RType)
annL, annR :: FP.Parser ()
annL = reservedOp "/*@"
annR = reservedOp "*/"
tyBindP :: String -> FP.Parser (F.Symbol, RType)
tyBindP kw = do
reserved kw
x <- identifier
colon
t <- rtype
annR
return (x, t)
{-
between :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a
between lP rP xP = do
lP
x <- xP
rP
return x
-}
mkDecl :: Ann -> SrcDecl -> SrcDecl
mkDecl (Just (x, t)) (Decl b e l)
| x == bindId b = Decl b (EAnn e (generalize t) (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl (Just (x, t)) (RDecl b e l)
| x == bindId b = RDecl b (EAnn e (generalize t) (label e)) l
| otherwise = error $ "bad annotation: " ++ show (x, bindId b)
mkDecl Nothing d = d
plainDecl :: FP.Parser SrcDecl
plainDecl = withSpan' $ do
ctor <- (FP.reserved "let rec" >> pure RDecl) <|>
(FP.reserved "let" >> pure Decl)
b <- binder
FP.reservedOp "="
e <- expr
FP.semi
return (ctor b e)
-- | `binder` parses SrcBind, used for let-binds and function parameters.
binder :: FP.Parser SrcBind
binder = withSpan' (Bind <$> identifier)
--------------------------------------------------------------------------------
-- | Top level Rtype parser
--------------------------------------------------------------------------------
rtype :: FP.Parser RType
rtype = try rfun <|> rtype0
rtype0 :: FP.Parser RType
rtype0 = parens rtype
<|> rbase
rfun :: FP.Parser RType
rfun = mkTFun <$> funArgP <*> (FP.reservedOp "=>" *> rtype)
funArgP :: FP.Parser FunArg
funArgP = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))
<|> ((,) <$> freshArgSymbolP <*> rtype0)
freshArgSymbolP :: FP.Parser F.Symbol
freshArgSymbolP = do
n <- FP.freshIntP
return $ F.symbol ("_arg" ++ show n)
mkTFun :: (F.Symbol, RType) -> RType -> RType
mkTFun (x, s) = TFun x s
rbase :: FP.Parser RType
rbase = try (TBase <$> tbase <*> refTop)
<|> TCon <$> identifier' <*> commaList rtype <*> refTop
tbase :: FP.Parser Base
tbase = (reserved "int" >> pure TInt)
<|> (reserved "bool" >> pure TBool)
<|> (tvarP >>= return . TVar. TV)
tvarP :: FP.Parser F.Symbol
tvarP = FP.reservedOp "'" >> FP.lowerIdP -- >>= return . TVar . TV
refTop :: FP.Parser Reft
refTop = brackets reftB <|> pure mempty
reftB :: FP.Parser Reft
reftB = (question >> pure Unknown)
<|> concReftB
concReftB :: FP.Parser Reft
concReftB = KReft <$> (FP.lowerIdP <* mid) <*> myPredP
mid :: FP.Parser ()
mid = FP.reservedOp "|"
question :: FP.Parser ()
question = FP.reservedOp "?"
-- >>> (parseWith rtype "" "int{v|v = 3}")
-- TBase TInt (v = 3)
-- >>> (parseWith rtype "" "int{v|v = x + y}")
-- TBase TInt (v = (x + y))
-- >>> (parseWith rtype "" "int")
-- TBase TInt true
-- >>> parseWith funArg "" "x:int"
-- ("x",TBase TInt true)
-- >>> parseWith rfun "" "int => int"
-- TFun "_" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int"
-- TFun "x" (TBase TInt true) (TBase TInt true)
-- >>> parseWith rfun "" "x:int => int{v|0 < v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 < v))
-- >>> parseWith rfun "" "x:int => int{v|0 <= v}"
-- TFun "x" (TBase TInt true) (TBase TInt (0 <= v))
-- >>> parseWith rfun "" "x:int{v|0 <= v} => int{v|0 <= v}"
-- TFun "x" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))
-- | list of reserved words
keywords :: S.Set String
keywords = S.fromList
[ "if" , "else"
, "true" , "false"
, "let" , "in"
, "int"
]
================================================
FILE: src/Language/Sprite/L5/Prims.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L5.Prims where
import qualified Data.Maybe as Mb
import qualified Data.Map as M
import qualified Language.Fixpoint.Types as F
import qualified Language.Sprite.Common.UX as UX
-- import qualified Language.Sprite.Common.Misc as Misc
import Language.Sprite.L5.Types
import Language.Sprite.L5.Parse
-- | "Prelude" Environment --------------------------------------------
prelude :: [(F.Symbol, RType)]
prelude =
[ ("diverge" , mkTy "x:int => 'a")
, ("impossible", mkTy "x:int[v|false] => 'a")
]
-- | Primitive Types --------------------------------------------------
constTy :: F.SrcSpan -> Prim -> RType
constTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n))
constTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)
constTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)
constTy l (PBin o) = binOpTy l o
binOpTy :: F.SrcSpan -> PrimOp -> RType
binOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv)
where
err = UX.panicS ("Unknown PrimOp: " ++ show o) l
bTrue :: Base -> RType
bTrue b = TBase b mempty
binOpEnv :: M.Map PrimOp RType
binOpEnv = M.fromList
[ (BPlus , mkTy "x:int => y:int => int[v|v=x+y]")
, (BMinus, mkTy "x:int => y:int => int[v|v=x-y]")
, (BTimes, mkTy "x:int => y:int => int[v|v=x*y]")
, (BLt , mkTy "x:'a => y:'a => bool[v|v <=> (x < y)]")
, (BLe , mkTy "x:'a => y:'a => bool[v|v <=> (x <= y)]")
, (BGt , mkTy "x:'a => y:'a => bool[v|v <=> (x > y)]")
, (BGe , mkTy "x:'a => y:'a => bool[v|v <=> (x >= y)]")
, (BEq , mkTy "x:'a => y:'a => bool[v|v <=> (x == y)]")
, (BAnd , mkTy "x:bool => y:bool => bool[v|v <=> (x && y)]")
, (BOr , mkTy "x:bool => y:bool => bool[v|v <=> (x || y)]")
, (BNot , mkTy "x:bool => bool[v|v <=> not x]")
]
mkTy :: String -> RType
mkTy = {- Misc.traceShow "mkTy" . -} rebind . generalize . parseWith rtype "prims"
rebind :: RType -> RType
rebind t@(TBase {}) = t
rebind (TAll a t) = TAll a (rebind t)
rebind (TCon c ts r) = TCon c (rebind <$> ts) r
rebind (TFun x s t) = TFun x' s' t'
where
x' = F.mappendSym "spec#" x
s' = subst (rebind s) x x'
t' = subst (rebind t) x x'
================================================
FILE: src/Language/Sprite/L5/Types.hs
================================================
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Sprite.L5.Types where
import qualified Language.Fixpoint.Horn.Types as H
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Misc as Misc
import qualified Language.Sprite.Common.Misc as Misc
import qualified Language.Sprite.Common.UX as UX
import Language.Sprite.Common
import qualified Data.Set as S
import qualified Data.List as L
-- | Basic types --------------------------------------------------------------
newtype TVar = TV F.Symbol
deriving (Eq, Ord, Show)
instance F.Symbolic TVar where
symbol (TV a) = a
data Base = TInt | TBool | TVar TVar
deriving (Eq, Ord, Show)
instance F.PPrint Base where
pprintTidy _ = UX.tshow
-- | Refined Types ------------------------------------------------------------
data Type r
= TBase !Base r -- ^ Int{r}
| TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t
| TAll !TVar !(Type r) -- ^ all a. t
| TCon !TyCon ![Type r] r -- ^ C t1...tn
deriving (Eq, Ord, Show)
rVar :: F.Symbol -> RType
rVar a = TBase (TVar (TV a)) mempty
rInt :: RType
rInt = TBase TInt mempty
rBool :: RType
rBool = TBase TBool mempty
data Reft
= Known !F.Symbol !H.Pred -- ^ Known refinement
| Unknown -- ^ Unknown, to-be-synth refinement
deriving (Show)
known :: F.Reft -> Reft
known (F.Reft (v, r)) = KReft v r
pattern KReft v p = Known v (H.Reft p)
instance Semigroup Reft where
Unknown <> r = r
r <> Unknown = r
-- KReft v1 r1 <> KReft v2 r2 = KReft v r where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)
Known v p <> Known v' p'
| v == v' = Known v (p <> p')
| v == F.dummySymbol = Known v' (p' <> (p `F.subst1` (v , F.EVar v')))
| otherwise = Known v (p <> (p' `F.subst1` (v', F.EVar v )))
-- _ <> _ = error "Semigroup Reft: TBD"
instance Monoid Reft where
mempty = KReft v r where F.Reft (v, r) = mempty
type RType = Type Reft
-- | Primitive Constants ------------------------------------------------------
data PrimOp
= BPlus
| BMinus
| BTimes
| BLt
| BLe
| BEq
| BGt
| BGe
| BAnd
| BOr
| BNot
deriving (Eq, Ord, Show)
data Prim
= PInt !Integer -- 0,1,2,...
| PBool !Bool -- true, false
| PBin !PrimOp -- +,-,==,<=,...
deriving (Eq, Ord, Show)
---------------------------------------------------------------------------------
-- | Terms ----------------------------------------------------------------------
---------------------------------------------------------------------------------
-- | Bindings -------------------------------------------------------------------
data Bind a
= Bind !Ident a
deriving (Eq, Ord, Show, Functor)
instance F.Symbolic (Bind a) where
symbol = bindId
bindId :: Bind a -> F.Symbol
bindId (Bind x _) = x
junkSymbol :: F.Symbol
junkSymbol = "_"
-- | Names of things ------------------------------------------------------------
type Ident = F.Symbol -- ^ Identifiers
type DaCon = F.Symbol -- ^ Data constructors
type TyCon = F.Symbol -- ^ Type constructors
-- | "Immediate" terms (can appear as function args & in refinements) -----------
data Imm a
= EVar !Ident a
| ECon !Prim a
deriving (Show, Functor)
-- | Variable definition ---------------------------------------------------------
data Decl a
= Decl (Bind a) (Expr a) a -- ^ plain "let"
| RDecl (Bind a) (Expr a) a -- ^ recursive "let rec"
deriving (Show, Functor)
-- | Case-Alternatives -----------------------------------------------------------
data Alt a = Alt
{ altDaCon :: !DaCon -- ^ Data constructor
, altBinds :: ![Bind a] -- ^ Binders x1...xn
, altExpr :: !(Expr a) -- ^ Body-expr
, altLabel :: a -- ^ Label
}
deriving (Show, Functor)
-- | Terms -----------------------------------------------------------------------
data Expr a
= EImm !(Imm a) a -- ^ x,y,z,... 1,2,3...
| EFun !(Bind a) !(Expr a) a -- ^ \x -> e
| EApp !(Expr a) !(Imm a) a -- ^ e v
| ELet !(Decl a) !(Expr a) a -- ^ let/rec x = e1 in e2
| EAnn !(Expr a) !RType a -- ^ e:t
| EIf !(Imm a) !(Expr a) !(Expr a) a -- ^ if v e1 e2
| ETLam !TVar !(Expr a) a -- ^ Λ a. e (type abstraction)
| ETApp !(Expr a) !RType a -- ^ e [t] (type application)
| ECase !Ident ![Alt a] a -- ^ switch (x) { a1 ... }
deriving (Show, Functor)
instance Label Bind where
label (Bind _ l) = l
instance Label Alt where
label = altLabel
instance Label Imm where
label (EVar _ l) = l
label (ECon _ l) = l
instance Label Expr where
label (EImm _ l) = l
label (EFun _ _ l) = l
label (EApp _ _ l) = l
label (ELet _ _ l) = l
label (EAnn _ _ l) = l
label (EIf _ _ _ l) = l
label (ETLam _ _ l) = l
label (ETApp _ _ l) = l
label (ECase _ _ l) = l
instance Label Decl where
label (Decl _ _ l) = l
label (RDecl _ _ l) = l
------------------------------------------------------------------------------
-- | Top-level `Program` datatype
------------------------------------------------------------------------------
data Prog a = Prog
{ prQuals :: ![F.Qualifier]
, prMeas :: ![(F.Symbol, F.Sort)]
, prExpr :: !(Expr a)
, prData :: ![Data a]
}
deriving (Show, Functor)
data Data a = Data
{ dcName :: !Ident -- ^ name of the datatype
, dcVars :: ![Ident] -- ^ type variables
, dcCtors :: ![(Bind a, RType)] -- ^ constructors
}
deriving (Show, Functor)
------------------------------------------------------------------------------
declsExpr :: [Decl a] -> Expr a
------------------------------------------------------------------------------
declsExpr [d] = ELet d (intExpr 0 l) l where l = label d
declsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d
declsExpr _ = error "impossible"
intExpr :: Integer -> a -> Expr a
intExpr i l = EImm (ECon (PInt i) l) l
boolExpr :: Bool -> a -> Expr a
boolExpr b l = EImm (ECon (PBool b) l) l
------------------------------------------------------------------------------
type SrcImm = Imm F.SrcSpan
type SrcBind = Bind F.SrcSpan
type SrcDecl = Decl F.SrcSpan
type SrcExpr = Expr F.SrcSpan
type ElbDecl = Decl F.SrcSpan
type ElbExpr = Expr F.SrcSpan
type SrcProg = Prog F.SrcSpan
type SrcData = Data F.SrcSpan
type SrcAlt = Alt F.SrcSpan
------------------------------------------------------------------------------
-- | should/need only be defined on "Known" variants. TODO:LIQUID
instance F.Subable Reft where
syms (Known v r) = v : F.syms r
syms Unknown = []
substa f (Known v r) = Known (f v) (F.substa f r)
substa _ Unknown = Unknown
substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r)
substf _ Unknown = Unknown
subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)
subst _ Unknown = Unknown
subst1 (Known v r) su = Known v (F.subst1Except [v] r su)
subst1 Unknown _ = Unknown
instance F.Subable r => F.Subable (Type r) where
-- syms :: a -> [Symbol]
syms (TBase _ r) = F.syms r
syms (TAll _ t) = F.syms t
syms (TFun _ s t) = F.syms s ++ F.syms t
syms (TCon _ ts r) = concatMap F.syms ts ++ F.syms r
-- substa :: (Symbol -> Symbol) -> Type r -> Type r
substa f (TBase b r) = TBase b (F.substa f r)
substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)
substa f (TAll a t) = TAll a (F.substa f t)
substa f (TCon c ts r) = TCon c (F.substa f <$> ts) (F.substa f r)
-- substf :: (Symbol -> Expr) -> Type r -> Type r
substf f (TBase b r) = TBase b (F.substf f r)
substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)
substf f (TAll a t) = TAll a (F.substf f t)
substf f (TCon c ts r) = TCon c (F.substf f <$> ts) (F.substf f r)
-- subst :: Subst -> a -> a
subst f (TBase b r) = TBase b (F.subst f r)
subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)
subst f (TAll a t) = TAll a (F.subst f t)
subst f (TCon c ts r) = TCon c (F.subst f <$> ts) (F.subst f r)
--------------------------------------------------------------------------------
-- | Substitution --------------------------------------------------------------
--------------------------------------------------------------------------------
substImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a
substImm thing x y = F.subst su thing
where
su = F.mkSubst [(x, immExpr y)]
subst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a
subst thing x y = substImm thing x (EVar y ())
immExpr :: Imm b -> F.Expr
immExpr (EVar x _) = F.expr x
immExpr (ECon (PInt n) _) = F.expr n
immExpr (ECon (PBool True) _) = F.PTrue
immExpr (ECon (PBool False) _) = F.PFalse
immExpr _ = error "impossible"
--------------------------------------------------------------------------------
-- | Dealing with Type Variables -----------------------------------------------
--------------------------------------------------------------------------------
tsubst :: TVar -> RType -> RType -> RType
tsubst a t = go
where
go (TAll b s)
| a == b = TAll b s
| otherwise = TAll b (go s)
go (TFun x s1 s2) = TFun x (go s1) (go s2)
go (TBase b r) = bsubst a t b r
go (TCon c ts r) = TCon c (go <$> ts) r
tsubsts :: [(TVar, RType)] -> RType -> RType
tsubsts ats s = L.foldl' (\s (a, t) -> tsubst a t s) s ats
bsubst :: TVar -> RType -> Base -> Reft -> RType
bsubst a t (TVar v) r
| v == a = strengthenTop t r
bsubst _ _ b r = TBase b r
rTypeReft :: RType -> Maybe Reft
rTypeReft (TBase _ r) = Just r
rTypeReft (TCon _ _ r) = Just r
rTypeReft _ = Nothing
strengthenTop :: RType -> Reft -> RType
strengthenTop t@(TFun {}) _ = t
gitextract_nx1wz071/
├── .gitignore
├── ChangeLog.md
├── LICENSE
├── NOTES.md
├── README.md
├── Setup.hs
├── app/
│ └── Main.hs
├── cabal.project
├── package.yaml
├── sprite.cabal
├── sprite.cabal.orig
├── src/
│ └── Language/
│ └── Sprite/
│ ├── Common/
│ │ ├── Misc.hs
│ │ ├── Parse.hs
│ │ └── UX.hs
│ ├── Common.hs
│ ├── L1/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L1.hs
│ ├── L2/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L2.hs
│ ├── L3/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L3.hs
│ ├── L4/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L4.hs
│ ├── L5/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L5.hs
│ ├── L6/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ └── Types.hs
│ ├── L6.hs
│ ├── L8/
│ │ ├── Check.hs
│ │ ├── Constraints.hs
│ │ ├── Elaborate.hs
│ │ ├── Parse.hs
│ │ ├── Prims.hs
│ │ ├── Reflect.hs
│ │ └── Types.hs
│ └── L8.hs
├── stack.yaml
├── stack.yaml.github
└── test/
├── L1/
│ ├── neg/
│ │ ├── inc00.re
│ │ ├── inc01.re
│ │ ├── inc02.re
│ │ └── int01.re
│ └── pos/
│ ├── inc00.re
│ ├── inc01.re
│ ├── inc02.re
│ ├── int00.re
│ └── int01.re
├── L2/
│ ├── neg/
│ │ ├── abs00.re
│ │ ├── abs01.re
│ │ ├── cmp00.re
│ │ ├── cmp01.re
│ │ └── sum00.re
│ └── pos/
│ ├── abs00.re
│ ├── abs01.re
│ ├── cmp00.re
│ ├── cmp01.re
│ └── sum00.re
├── L3/
│ ├── neg/
│ │ ├── abs01.re
│ │ ├── abs02-bad.re
│ │ ├── abs02.re
│ │ ├── assert00.re
│ │ ├── rebind.re
│ │ └── sum01.re
│ └── pos/
│ ├── abs01.re
│ ├── abs02-debug.re
│ ├── abs02.re
│ ├── assert00.re
│ └── sum01.re
├── L4/
│ ├── neg/
│ │ ├── choose00.re
│ │ ├── choose01.re
│ │ ├── foldn00.re
│ │ ├── foldn01.re
│ │ └── id00.re
│ └── pos/
│ ├── choose00.re
│ ├── choose01.re
│ ├── foldn00.re
│ ├── foldn01.re
│ └── id00.re
├── L5/
│ ├── neg/
│ │ ├── append00.re
│ │ ├── cons00.re
│ │ ├── head00.re
│ │ ├── head01.re
│ │ ├── isort00.re
│ │ ├── isort01.re
│ │ ├── listSet.re
│ │ ├── nil00.re
│ │ ├── olist00.re
│ │ ├── olist01.re
│ │ ├── olist02.re
│ │ ├── single00.re
│ │ ├── tail01.re
│ │ └── tuple00.re
│ └── pos/
│ ├── append00.re
│ ├── cons00.re
│ ├── fold_right00.re
│ ├── head00.re
│ ├── head01.re
│ ├── isort00.re
│ ├── isort01.re
│ ├── listSet.re
│ ├── nil00.re
│ ├── olist00.re
│ ├── olist01.re
│ ├── olist02.re
│ ├── single00.re
│ ├── tail01.re
│ └── tuple00.re
├── L6/
│ ├── neg/
│ │ ├── deptup00.re
│ │ ├── isort02.re
│ │ ├── maxint1.re
│ │ ├── maxint2.re
│ │ ├── maxlist.re
│ │ ├── maxlist00_1.re
│ │ ├── maxlist00_2.re
│ │ └── maxlist01.re
│ └── pos/
│ ├── apply00.re
│ ├── deptup00.re
│ ├── deptup000.re
│ ├── deptup001.re
│ ├── deptup002.re
│ ├── deptup002a.re
│ ├── deptup003.re
│ ├── deptup01.re
│ ├── isort02.re
│ ├── maxint.re
│ ├── maxlist00.re
│ ├── maxlist01.re
│ ├── maxpoly.re
│ └── plaintup00.re
├── L7/
│ ├── neg/
│ │ ├── ack.re
│ │ ├── list00.re
│ │ ├── listSet.re
│ │ ├── range.re
│ │ ├── sum.re
│ │ └── sumAcc.re
│ └── pos/
│ ├── ack.re
│ ├── append.re
│ ├── braid.re
│ ├── listSet.re
│ ├── range.re
│ ├── sum.re
│ ├── sumAcc.re
│ └── sumNat.re
├── L8/
│ ├── neg/
│ │ ├── append.re
│ │ ├── listSet.re
│ │ └── sum.re
│ └── pos/
│ ├── adttup00.re
│ ├── append.re
│ ├── listSet.re
│ ├── poly.re
│ └── sum.re
├── Spec.hs
└── logs/
└── cur/
└── summary.csv
Condensed preview — 179 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (431K chars).
[
{
"path": ".gitignore",
"chars": 234,
"preview": "dist\ndist-*\ncabal-dev\n*.o\n*.hi\n*.hie\n*.chi\n*.chs.h\n*.dyn_o\n*.dyn_hi\n.hpc\n.hsenv\n.cabal-sandbox/\ncabal.sandbox.config\n*.p"
},
{
"path": "ChangeLog.md",
"chars": 55,
"preview": "# Changelog for liquid-tutorial\n\n## Unreleased changes\n"
},
{
"path": "LICENSE",
"chars": 1529,
"preview": "Copyright Author name here (c) 2019\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or wi"
},
{
"path": "NOTES.md",
"chars": 11908,
"preview": "# SPRITE\n\nAn tutorial-style implementation of liquid/refinement types for a subset of Ocaml/Reason.\n\n## TODO: Paper\n\n- ["
},
{
"path": "README.md",
"chars": 1252,
"preview": "# SPRITE\n\nA tutorial-style implementation of liquid/refinement types for a subset of Ocaml/Reason.\n\n## Install\n\n**1. Get"
},
{
"path": "Setup.hs",
"chars": 46,
"preview": "import Distribution.Simple\nmain = defaultMain\n"
},
{
"path": "app/Main.hs",
"chars": 1368,
"preview": "\n{-# LANGUAGE ScopedTypeVariables#-}\nmodule Main where\n\nimport System.Environment ( getArgs ) \nimport "
},
{
"path": "cabal.project",
"chars": 167,
"preview": "packages: .\n\nsource-repository-package\n type: git\n location: https://github.com/ucsd-progsys/liquid-fixpoint\n t"
},
{
"path": "package.yaml",
"chars": 1497,
"preview": "name: sprite\nversion: 0.2.0.0\ngithub: \"ranjitjhala/sprite\"\nlicense: "
},
{
"path": "sprite.cabal",
"chars": 3814,
"preview": "cabal-version: 1.12\n\n-- This file has been generated from package.yaml by hpack version 0.36.0.\n--\n-- see: https://githu"
},
{
"path": "sprite.cabal.orig",
"chars": 3942,
"preview": "cabal-version: 1.12\n\n-- This file has been generated from package.yaml by hpack version 0.33.0.\n--\n-- see: https://githu"
},
{
"path": "src/Language/Sprite/Common/Misc.hs",
"chars": 3037,
"preview": "module Language.Sprite.Common.Misc where\n\nimport qualified Data.Map as M\nimport qualified Data.List as L\n-- import "
},
{
"path": "src/Language/Sprite/Common/Parse.hs",
"chars": 2212,
"preview": "module Language.Sprite.Common.Parse where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Set "
},
{
"path": "src/Language/Sprite/Common/UX.hs",
"chars": 6153,
"preview": "-- | This module contains the code for all the user (programmer) facing\n-- aspects, i.e. error messages, source-positi"
},
{
"path": "src/Language/Sprite/Common.hs",
"chars": 6417,
"preview": "\n{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Eta reduce\" #-}\n\n"
},
{
"path": "src/Language/Sprite/L1/Check.hs",
"chars": 4257,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L1.Check (vcgen) where\n\nimport Control.Monad (void)\n"
},
{
"path": "src/Language/Sprite/L1/Constraints.hs",
"chars": 2538,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L1/Parse.hs",
"chars": 5723,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L1.Parse\n (\n -- * Pars"
},
{
"path": "src/Language/Sprite/L1/Prims.hs",
"chars": 1240,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L1.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L1/Types.hs",
"chars": 3169,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE DeriveFunctor #-}\n\nmodule Language.Sprite.L1.Types where \n\nimport qu"
},
{
"path": "src/Language/Sprite/L1.hs",
"chars": 694,
"preview": "module Language.Sprite.L1 ( sprite ) where\n\nimport Control.Monad (void)\nimport System.Exit\nimport qu"
},
{
"path": "src/Language/Sprite/L2/Check.hs",
"chars": 5329,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L2.Check (vcgen) where\n\nimport Control.Monad "
},
{
"path": "src/Language/Sprite/L2/Constraints.hs",
"chars": 2969,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L2/Parse.hs",
"chars": 6179,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L2.Parse\n (\n -- * Pars"
},
{
"path": "src/Language/Sprite/L2/Prims.hs",
"chars": 1667,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L2.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L2/Types.hs",
"chars": 4227,
"preview": "{-# LANGUAGE DeriveFunctor #-}\nmodule Language.Sprite.L2.Types where \n\n-- import qualified Language.Fixpoint.Horn.Types "
},
{
"path": "src/Language/Sprite/L2.hs",
"chars": 787,
"preview": "module Language.Sprite.L2 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types "
},
{
"path": "src/Language/Sprite/L3/Check.hs",
"chars": 6145,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L3.Check (vcgen) where\n\nimport Control.Monad "
},
{
"path": "src/Language/Sprite/L3/Constraints.hs",
"chars": 4309,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L3/Parse.hs",
"chars": 6991,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L3.Parse\n (\n -- * Pars"
},
{
"path": "src/Language/Sprite/L3/Prims.hs",
"chars": 1984,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L3.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L3/Types.hs",
"chars": 5916,
"preview": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Languag"
},
{
"path": "src/Language/Sprite/L3.hs",
"chars": 796,
"preview": "module Language.Sprite.L3 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types "
},
{
"path": "src/Language/Sprite/L4/Check.hs",
"chars": 6953,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L4.Check (vcgen) where\n\nimport Control.Monad "
},
{
"path": "src/Language/Sprite/L4/Constraints.hs",
"chars": 4593,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L4/Elaborate.hs",
"chars": 8063,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LA"
},
{
"path": "src/Language/Sprite/L4/Parse.hs",
"chars": 7199,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L4.Parse\n (\n -- * Pars"
},
{
"path": "src/Language/Sprite/L4/Prims.hs",
"chars": 1994,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L4.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L4/Types.hs",
"chars": 8407,
"preview": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Languag"
},
{
"path": "src/Language/Sprite/L4.hs",
"chars": 639,
"preview": "module Language.Sprite.L4 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types "
},
{
"path": "src/Language/Sprite/L5/Check.hs",
"chars": 8889,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Use uncurry\" #-}\nmodu"
},
{
"path": "src/Language/Sprite/L5/Constraints.hs",
"chars": 7267,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L5/Elaborate.hs",
"chars": 9417,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LA"
},
{
"path": "src/Language/Sprite/L5/Parse.hs",
"chars": 9136,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L5.Parse\n (\n -- * Parsing programs\n parseFile\n , "
},
{
"path": "src/Language/Sprite/L5/Prims.hs",
"chars": 2327,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L5.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L5/Types.hs",
"chars": 12116,
"preview": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Languag"
},
{
"path": "src/Language/Sprite/L5.hs",
"chars": 634,
"preview": "module Language.Sprite.L5 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F"
},
{
"path": "src/Language/Sprite/L6/Check.hs",
"chars": 12173,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-"
},
{
"path": "src/Language/Sprite/L6/Constraints.hs",
"chars": 7946,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L6/Elaborate.hs",
"chars": 10086,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LA"
},
{
"path": "src/Language/Sprite/L6/Parse.hs",
"chars": 10703,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L6.Parse\n (\n -- * Pars"
},
{
"path": "src/Language/Sprite/L6/Prims.hs",
"chars": 2408,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L6.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L6/Types.hs",
"chars": 18648,
"preview": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE Ov"
},
{
"path": "src/Language/Sprite/L6.hs",
"chars": 634,
"preview": "module Language.Sprite.L6 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F"
},
{
"path": "src/Language/Sprite/L8/Check.hs",
"chars": 17723,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-"
},
{
"path": "src/Language/Sprite/L8/Constraints.hs",
"chars": 10054,
"preview": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, an"
},
{
"path": "src/Language/Sprite/L8/Elaborate.hs",
"chars": 10102,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LA"
},
{
"path": "src/Language/Sprite/L8/Parse.hs",
"chars": 10857,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L8.Parse\n (\n -- * Pars"
},
{
"path": "src/Language/Sprite/L8/Prims.hs",
"chars": 2513,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L8.Prims where\n\nimport qualified Data.Maybe "
},
{
"path": "src/Language/Sprite/L8/Reflect.hs",
"chars": 5937,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n{-# LANGUAGE FlexibleInstances #-}\n\nmodul"
},
{
"path": "src/Language/Sprite/L8/Types.hs",
"chars": 19800,
"preview": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE Fl"
},
{
"path": "src/Language/Sprite/L8.hs",
"chars": 637,
"preview": "module Language.Sprite.L8 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F"
},
{
"path": "stack.yaml",
"chars": 461,
"preview": "resolver: nightly-2024-01-26\n\npackages:\n - '.'\n\nextra-deps:\n- store-0.7.18@sha256:af32079e0d31413b97a1759f8ad8555507857"
},
{
"path": "stack.yaml.github",
"chars": 299,
"preview": "# resolver: lts-13.20\nresolver: lts-16.10\n\npackages:\n - '.'\n\nextra-deps:\n- intern-0.9.2\n- located-base-0.1.1.1\n- text-f"
},
{
"path": "test/L1/neg/inc00.re",
"chars": 96,
"preview": "\n\n/*@ val inc: x:int => int[v|v = x + 1] */\nlet inc = (x) => {\n x - 1\n};\n\nlet bar = inc(10);\n"
},
{
"path": "test/L1/neg/inc01.re",
"chars": 262,
"preview": "/*@ val inc: x:int[v|0<=v] => int[v|0<=v] */\nlet inc = (x) => {\n x + 1\n};\n\n/*@ val dec : x:int => int[v | v == x - 1]"
},
{
"path": "test/L1/neg/inc02.re",
"chars": 265,
"preview": "/*@ val dec : x:int => int[v|v==x-1] */\nlet dec = (x) => {\n x - 1\n};\n\n/*@ val incf: x:int[v|0<=v] => int[v|0<=v] */\nl"
},
{
"path": "test/L1/neg/int01.re",
"chars": 80,
"preview": "let v1 = 1;\n\nlet v2 = 2;\n\n/*@ val top : int[v|v = 30] */ \nlet top = v1 + v2;\n\n\n\n"
},
{
"path": "test/L1/pos/inc00.re",
"chars": 96,
"preview": "\n\n/*@ val inc: x:int => int[v|v = x + 1] */\nlet inc = (x) => {\n x + 1\n};\n\nlet bar = inc(10);\n"
},
{
"path": "test/L1/pos/inc01.re",
"chars": 184,
"preview": "\n/*@ val inc: x:int => int[v | v == x + 1] */\nlet inc = (x) => {\n x + 1\n};\n\n/*@ val inc2: x:int[v|0<=v] => int[v|0<=v"
},
{
"path": "test/L1/pos/inc02.re",
"chars": 265,
"preview": "\n\n/*@ val inc: x:int => int[v|v=x+1] */\nlet inc = (x) => {\n x + 1\n};\n\n/*@ val incf: x:int[v|0<=v] => int[v|0<=v] */\nl"
},
{
"path": "test/L1/pos/int00.re",
"chars": 48,
"preview": "let v1 = 1;\n\nlet v2 = 2;\n\nlet top = v1 + v2;\n\n\n\n"
},
{
"path": "test/L1/pos/int01.re",
"chars": 75,
"preview": "let v1 = 1;\n\nlet v2 = 2;\n\n/*@ val top : int[v|v = 3] */ \nlet top = v1 + v2;"
},
{
"path": "test/L2/neg/abs00.re",
"chars": 142,
"preview": "/*@ val abs : x:int => int[v|0<=v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n 0 - x\n } else"
},
{
"path": "test/L2/neg/abs01.re",
"chars": 286,
"preview": "/*@ val abs : x:int => int[v| 0<=v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n x\n } else {\n"
},
{
"path": "test/L2/neg/cmp00.re",
"chars": 155,
"preview": "/*@ val cmp : x:int => bool[b|b <=> (x < 0)] */\nlet cmp = (x) => {\n let cond = x < 10;\n if (cond) {\n true\n "
},
{
"path": "test/L2/neg/cmp01.re",
"chars": 166,
"preview": "/*@ val cmp : x:int => y:int => bool[b|b <=> (x < y)] */\nlet cmp = (x, y) => {\n let cond = x > y;\n if (cond) {\n "
},
{
"path": "test/L2/neg/sum00.re",
"chars": 203,
"preview": "/*@ val sum : n:int => int[v|0 <= v && n <= v] */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n "
},
{
"path": "test/L2/pos/abs00.re",
"chars": 142,
"preview": "/*@ val abs : x:int => int[v|0<=v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n x\n } else {\n "
},
{
"path": "test/L2/pos/abs01.re",
"chars": 296,
"preview": "/*@ val abs : x:int => int[v| 0<=v && x <= v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n x\n "
},
{
"path": "test/L2/pos/cmp00.re",
"chars": 156,
"preview": "/*@ val cmp : x:int => bool[b|b <=> (x < 10)] */\nlet cmp = (x) => {\n let cond = x < 10;\n if (cond) {\n true\n"
},
{
"path": "test/L2/pos/cmp01.re",
"chars": 166,
"preview": "/*@ val cmp : x:int => y:int => bool[b|b <=> (x < y)] */\nlet cmp = (x, y) => {\n let cond = x < y;\n if (cond) {\n "
},
{
"path": "test/L2/pos/sum00.re",
"chars": 207,
"preview": "/*@ val sum : n:int => int[v|0 <= v && n <= v] */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n "
},
{
"path": "test/L3/neg/abs01.re",
"chars": 278,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n "
},
{
"path": "test/L3/neg/abs02-bad.re",
"chars": 520,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n "
},
{
"path": "test/L3/neg/abs02.re",
"chars": 401,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) =>"
},
{
"path": "test/L3/neg/assert00.re",
"chars": 180,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val main : int => int */\nlet main = (x) => {\n"
},
{
"path": "test/L3/neg/rebind.re",
"chars": 173,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val check : int => int */\nlet check = (y) => {\n "
},
{
"path": "test/L3/neg/sum01.re",
"chars": 389,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val sum : n:int => int[?] */\nlet rec sum = (n) =>"
},
{
"path": "test/L3/pos/abs01.re",
"chars": 295,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n "
},
{
"path": "test/L3/pos/abs02-debug.re",
"chars": 304,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[v1|v1>=0] */\nlet abs = (x)"
},
{
"path": "test/L3/pos/abs02.re",
"chars": 400,
"preview": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n "
},
{
"path": "test/L3/pos/assert00.re",
"chars": 178,
"preview": "\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val main : int => int */\nlet main = (x) => {"
},
{
"path": "test/L3/pos/sum01.re",
"chars": 573,
"preview": "/*@ qualif Pos(v:int): (0 <= v) */\n/*@ qualif Geq(v:int, n:int): (n <= v) */\n\n\n/*@ val cassert : bool[b|b] => int"
},
{
"path": "test/L4/neg/choose00.re",
"chars": 208,
"preview": "\n/*@ val choose : 'a => 'b => 'a */\nlet choose = (x, y) => { x };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0"
},
{
"path": "test/L4/neg/choose01.re",
"chars": 208,
"preview": "\n/*@ val choose : 'a => 'b => 'b */\nlet choose = (x, y) => { y };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0"
},
{
"path": "test/L4/neg/foldn00.re",
"chars": 410,
"preview": "/*@ val foldn : ('a => int => 'a) => 'a => int => int => 'a */\nlet rec foldn = (f, acc, i, n) => {\n let leq = i < n;\n "
},
{
"path": "test/L4/neg/foldn01.re",
"chars": 437,
"preview": "// No quals!\n\n/*@ val foldn : ('a => int[?] => 'a) => 'a => i:int[?] => n:int[?] => 'a */\nlet rec foldn = (f, acc, i, n)"
},
{
"path": "test/L4/neg/id00.re",
"chars": 171,
"preview": "/*@ val id : 'a => 'a */\nlet id = (x) => { x };\n\n/*@ val check1 : x:int[v|0<=v] => int[v|0<=v] */\nlet check1 = (y) => {\n"
},
{
"path": "test/L4/pos/choose00.re",
"chars": 228,
"preview": "\n/*@ val choose : 'a => 'b => 'a */\nlet choose = (x, y) => { x };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0"
},
{
"path": "test/L4/pos/choose01.re",
"chars": 208,
"preview": "\n/*@ val choose : 'a => 'b => 'b */\nlet choose = (x, y) => { y };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0"
},
{
"path": "test/L4/pos/foldn00.re",
"chars": 477,
"preview": "/*@ qualif Pos(v:int): (0 <= v) */\n\n/*@ val foldn : ('a => int[v|0<=v] => 'a) => 'a => i:int[v|0 <= v] => n:int[v|i<=v] "
},
{
"path": "test/L4/pos/foldn01.re",
"chars": 617,
"preview": "/*@ qualif Pos(v:int): (0 <= v) */\n/*@ qualif Geq(v:int, n:int): (n <= v) */\n\n/*@ val foldn : ('a => int[?] => 'a"
},
{
"path": "test/L4/pos/id00.re",
"chars": 150,
"preview": "/*@ val id : 'a => 'a */\nlet id = (x) => { x };\n\n/*@ val check1 : x:int[v|0<=v] => int[v|0<=v] */\nlet check1 = (y) => {\n"
},
{
"path": "test/L5/neg/append00.re",
"chars": 365,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/neg/cons00.re",
"chars": 272,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/neg/head00.re",
"chars": 389,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n\n/*@ val singleton : 'a => list('a) */\nlet singleton = (x) => {\n l"
},
{
"path": "test/L5/neg/head01.re",
"chars": 501,
"preview": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, x"
},
{
"path": "test/L5/neg/isort00.re",
"chars": 868,
"preview": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, x"
},
{
"path": "test/L5/neg/isort01.re",
"chars": 817,
"preview": "type list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x <= v])) "
},
{
"path": "test/L5/neg/listSet.re",
"chars": 442,
"preview": "/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) =\n | Nil => [v| elts(v) = Set_empty(0"
},
{
"path": "test/L5/neg/nil00.re",
"chars": 262,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/neg/olist00.re",
"chars": 192,
"preview": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val bar : apple:int => horse: olist(int) ="
},
{
"path": "test/L5/neg/olist01.re",
"chars": 239,
"preview": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val foo : n:int => olist(int) */\nlet foo ="
},
{
"path": "test/L5/neg/olist02.re",
"chars": 313,
"preview": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val mkOList : lo:int => hi:int => olist(in"
},
{
"path": "test/L5/neg/single00.re",
"chars": 159,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val singleton : int => list(int[v|0 <= v]) */\nlet singleton = ("
},
{
"path": "test/L5/neg/tail01.re",
"chars": 339,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/neg/tuple00.re",
"chars": 375,
"preview": "\ntype coord = \n | C (x:int, y:int[v|x < v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n"
},
{
"path": "test/L5/pos/append00.re",
"chars": 411,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/pos/cons00.re",
"chars": 271,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/pos/fold_right00.re",
"chars": 298,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('alice => 'bob => 'bob) => 'bob => list('alic"
},
{
"path": "test/L5/pos/head00.re",
"chars": 386,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val singleton : 'a => list('a) */\nlet singleton = (x) => {\n le"
},
{
"path": "test/L5/pos/head01.re",
"chars": 509,
"preview": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, x"
},
{
"path": "test/L5/pos/isort00.re",
"chars": 890,
"preview": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, x"
},
{
"path": "test/L5/pos/isort01.re",
"chars": 817,
"preview": "type list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x <= v])) "
},
{
"path": "test/L5/pos/listSet.re",
"chars": 442,
"preview": "/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) =\n | Nil => [v| elts(v) = Set_empty(0"
},
{
"path": "test/L5/pos/nil00.re",
"chars": 262,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/pos/olist00.re",
"chars": 204,
"preview": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val bar : apple:int => horse: olist(int[v|"
},
{
"path": "test/L5/pos/olist01.re",
"chars": 240,
"preview": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val foo : n:int => olist(int) */\nlet foo ="
},
{
"path": "test/L5/pos/olist02.re",
"chars": 311,
"preview": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val mkOList : lo:int => hi:int => olist(in"
},
{
"path": "test/L5/pos/single00.re",
"chars": 170,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val singleton : int[v|0 <= v] => list(int[v|0 <= v]) */\nlet si"
},
{
"path": "test/L5/pos/tail01.re",
"chars": 338,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L5/pos/tuple00.re",
"chars": 374,
"preview": "\ntype coord = \n | C (x:int, y:int[v|x < v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n"
},
{
"path": "test/L6/neg/deptup00.re",
"chars": 210,
"preview": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val check2 : x:int => pair(int, int)("
},
{
"path": "test/L6/neg/isort02.re",
"chars": 900,
"preview": "type list('a)(p : 'a => 'a => bool) =\n | Nil\n | Cons(x:'a, list('a[v|p x v])((x1:'a, x2:'a) => p x1 x2))\n ;\n\n/*@ val "
},
{
"path": "test/L6/neg/maxint1.re",
"chars": 284,
"preview": "/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let "
},
{
"path": "test/L6/neg/maxint2.re",
"chars": 283,
"preview": "/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let "
},
{
"path": "test/L6/neg/maxlist.re",
"chars": 908,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */\nle"
},
{
"path": "test/L6/neg/maxlist00_1.re",
"chars": 639,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|"
},
{
"path": "test/L6/neg/maxlist00_2.re",
"chars": 636,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|"
},
{
"path": "test/L6/neg/maxlist01.re",
"chars": 999,
"preview": "/*@ qualif Geq(v:int, n:int): (n <= v) */\n/*@ qualif AbsPred(v:int, f:int => bool): (f v) */\n\ntype list('a) =\n | Nil\n "
},
{
"path": "test/L6/pos/apply00.re",
"chars": 282,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */\nle"
},
{
"path": "test/L6/pos/deptup00.re",
"chars": 342,
"preview": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val check1 : x:int => pair(int, int)("
},
{
"path": "test/L6/pos/deptup000.re",
"chars": 206,
"preview": "type pair()(pp : int => int => bool) =\n | MkPair(x:int, y:int[v|pp x v])\n ;\n\n/*@ val check1 : x:int => pair()((el1:int"
},
{
"path": "test/L6/pos/deptup001.re",
"chars": 210,
"preview": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val check1 : x:int => pair(int, int)("
},
{
"path": "test/L6/pos/deptup002.re",
"chars": 280,
"preview": "type pair() =\n | MkPair(x:int, y:int[v|x < v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => {\n 0\n};"
},
{
"path": "test/L6/pos/deptup002a.re",
"chars": 337,
"preview": "type pair()(zog : int => int => bool) =\n | MkPair(x:int, y:int[v|zog x v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nl"
},
{
"path": "test/L6/pos/deptup003.re",
"chars": 348,
"preview": "type pair('a, 'b)(zog : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|zog x v])\n ;\n\n/*@ val cassert : bool[b|b] => int */"
},
{
"path": "test/L6/pos/deptup01.re",
"chars": 250,
"preview": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val myTuple: junk:int => pair(int[v|0"
},
{
"path": "test/L6/pos/isort02.re",
"chars": 899,
"preview": "type list('a)(p : 'a => 'a => bool) =\n | Nil\n | Cons(x:'a, list('a[v|p x v])((x1:'a, x2:'a) => p x1 x2))\n ;\n\n/*@ val "
},
{
"path": "test/L6/pos/maxint.re",
"chars": 392,
"preview": "/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let "
},
{
"path": "test/L6/pos/maxlist00.re",
"chars": 693,
"preview": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|"
},
{
"path": "test/L6/pos/maxlist01.re",
"chars": 1008,
"preview": "/*@ qualif Geq(v:int, n:int): (n <= v) */\n/*@ qualif AbsPred(v:int, f:int => bool): (f v) */\n\ntype list('a) =\n | Nil\n "
},
{
"path": "test/L6/pos/maxpoly.re",
"chars": 192,
"preview": "/*@ val silly : forall (p : 'a => bool). x:'a[v|p v] => 'a[v|p v] */\nlet silly = (x) => {\n x\n};\n\n/*@ val test1 : a:int["
},
{
"path": "test/L6/pos/plaintup00.re",
"chars": 189,
"preview": "type pair('a, 'b) =\n | MkPair(x:'a, y:'b)\n ;\n\n/*@ val myTuple: junk:int => pair(int[v|0 < v], int[v|v < 0]) */\nlet myT"
},
{
"path": "test/L7/neg/ack.re",
"chars": 324,
"preview": "/*@ val ack : m:int[v|0 <= v] => n:int[v|0 <= v] => int / m, n */\nlet rec ack = (m, n) => {\n let condm = m == 0;\n let "
},
{
"path": "test/L7/neg/list00.re",
"chars": 391,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) > 0] =\n | Nil => [v| len(v) = 0] \n "
},
{
"path": "test/L7/neg/listSet.re",
"chars": 574,
"preview": "/*@ measure len : list('a) => int */\n/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) [v|len(v) >= 0] =\n | "
},
{
"path": "test/L7/neg/range.re",
"chars": 375,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L7/neg/sum.re",
"chars": 200,
"preview": "/*@ val sum : n:int => int[v|0 <= v] / n */\nlet rec sum = (n) => {\n let cond = n == 0;\n if (cond) {\n 0\n "
},
{
"path": "test/L7/neg/sumAcc.re",
"chars": 216,
"preview": "/*@ val sumAcc : total:int => n:int => int / total */\nlet rec sumAcc = (total, n) => {\n let cond = n <= 0;\n if (cond) "
},
{
"path": "test/L7/pos/ack.re",
"chars": 334,
"preview": "/*@ val ack : m:int[v|0 <= v] => n:int[v|0 <= v] => int[v|0 <= v] / m, n */\nlet rec ack = (m, n) => {\n let condm = m =="
},
{
"path": "test/L7/pos/append.re",
"chars": 398,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| len(v) = 0]\n "
},
{
"path": "test/L7/pos/braid.re",
"chars": 409,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) [v| len(v) >= 0] =\n | Nil => [v| len(v) = 0] \n"
},
{
"path": "test/L7/pos/listSet.re",
"chars": 573,
"preview": "/*@ measure len : list('a) => int */\n/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) [v|len(v) >= 0] =\n | "
},
{
"path": "test/L7/pos/range.re",
"chars": 372,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs"
},
{
"path": "test/L7/pos/sum.re",
"chars": 200,
"preview": "/*@ val sum : n:int => int[v|0 <= v] / n */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n 0\n "
},
{
"path": "test/L7/pos/sumAcc.re",
"chars": 212,
"preview": "/*@ val sumAcc : total:int => n:int => int / n */\nlet rec sumAcc = (total, n) => {\n let cond = n <= 0;\n if (cond) {\n "
},
{
"path": "test/L7/pos/sumNat.re",
"chars": 210,
"preview": "/*@ val sum : n:int[v|0 <= v] => int[v|0 <= v] / n */\nlet rec sum = (n) => {\n let cond = n == 0;\n if (cond) {\n "
},
{
"path": "test/L8/neg/append.re",
"chars": 869,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len"
},
{
"path": "test/L8/neg/listSet.re",
"chars": 1495,
"preview": "/*@ measure len : list('a) => int */\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len("
},
{
"path": "test/L8/neg/sum.re",
"chars": 459,
"preview": "/*@ reflect sum : n:int => int / n */\nlet rec sum = (n) => { \n let base = n <= 0;\n if (base) {\n 0\n } else {\n l"
},
{
"path": "test/L8/pos/adttup00.re",
"chars": 217,
"preview": "type pair('a, 'b) =\n | MkPair(x:'a, y:'b) => [v|v = MkPair(x, y)]\n ;\n\n/*@ val myTuple: junk:int => pair(int, int)[v| v"
},
{
"path": "test/L8/pos/append.re",
"chars": 900,
"preview": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len"
},
{
"path": "test/L8/pos/listSet.re",
"chars": 1603,
"preview": "\n\n\n/*@ measure len : list('a) => int */\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && l"
},
{
"path": "test/L8/pos/poly.re",
"chars": 257,
"preview": "/*@ reflect cheq : 'a => 'a => bool / 0 */\nlet rec cheq = (x, y) => { \n x == y \n};\n\n/*@ val test_int : int => int[v| ch"
},
{
"path": "test/L8/pos/sum.re",
"chars": 459,
"preview": "/*@ reflect sum : n:int => int / n */\nlet rec sum = (n) => { \n let base = n <= 0;\n if (base) {\n 0\n } else {\n l"
},
{
"path": "test/Spec.hs",
"chars": 13253,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\nmodul"
},
{
"path": "test/logs/cur/summary.csv",
"chars": 11898,
"preview": " (HEAD -> bump, origin/bump) : 24d6e7c580595f45e9c53eb128f0e9377fc081b4\nTimestamp: 2024-03-08 23:02:23 -0800\nEpoch Times"
}
]
About this extraction
This page contains the full source code of the ranjitjhala/sprite-lang GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 179 files (395.9 KB), approximately 136.0k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.