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 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 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 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 strengthenTop t@(TAll {}) _ = t strengthenTop (TBase b r) r' = TBase b (r <> r') strengthenTop (TCon c ts r) r' = TCon c ts (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 (TCon _ ts _) = S.unions (go <$> ts) go (TBase b _) = goB b goB (TVar a) = S.singleton a goB _ = S.empty ------------------------------------------------------------------------------- -- | Types and Sorts ------------------------------------------------------------------------------- baseSort :: Base -> F.Sort baseSort TInt = F.intSort baseSort TBool = F.boolSort baseSort (TVar a) = F.FObj (F.symbol a) rTypeSort :: RType -> F.Sort rTypeSort (TBase b _) = baseSort b rTypeSort (TCon c ts _) = F.fAppTC (fTyCon c) (rTypeSort <$> ts) rTypeSort t@(TFun {}) = rTypeSortFun t rTypeSort t@(TAll {}) = rTypeSortAll t rTypeSortFun :: RType -> F.Sort rTypeSortFun = F.mkFFunc 0 . fmap rTypeSort . go [] where go ts (TFun _ t1 t2) = go (t1:ts) t2 go ts t = reverse (t:ts) rTypeSortAll :: RType -> F.Sort rTypeSortAll s = genSort (rTypeSort t) where genSort t = L.foldl' (flip F.FAbs) (F.sortSubst su t) [0..n-1] (as, t) = bkAll s su = F.mkSortSubst $ zip sas (F.FVar <$> [0..]) sas = F.symbol <$> as n = length as bkAll :: RType -> ([TVar], RType) bkAll (TAll a s) = (a:as, t) where (as, t) = bkAll s bkAll t = ([] , t) fTyCon :: TyCon -> F.FTycon fTyCon = F.symbolFTycon . F.dummyLoc ================================================ FILE: src/Language/Sprite/L5.hs ================================================ module Language.Sprite.L5 ( sprite ) where import System.Exit import qualified Language.Fixpoint.Types as F import Language.Sprite.L5.Check import Language.Sprite.L5.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/L6/Check.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use uncurry" #-} module Language.Sprite.L6.Check (vcgen) where import Control.Monad (void) import Control.Monad.Except (throwError, catchError) import qualified Data.HashMap.Strict as M -- 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 Language.Fixpoint.Misc (safeZip) import qualified Language.Sprite.Common.UX as UX import qualified Language.Sprite.Common.Misc as Misc import Language.Sprite.Common import Language.Sprite.L6.Types import Language.Sprite.L6.Prims import Language.Sprite.L6.Constraints import Language.Sprite.L6.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 let ps = [(pappSym n, pappSort n) | n <- [1..3]] let pqs = pappQual <$> [1..3] let syms = M.fromList (ps ++ ms) (c, ks) <- run (check env eL (bTrue TInt)) return $ H.Query (qs ++ pqs) ks c syms mempty mempty mempty mempty mempty ------------------------------------------------------------------------------- sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr ------------------------------------------------------------------------------- sub l s t = sub' l s t `catchError` (\es -> throwError (UX.mkError msg l : es)) where msg = text $ "Invalid Subtyping: " ++ show (s, t) {- | [Sub-Base] (v::t) => q[w := v] ------------------- b{v:p} <= b{w:q} -} sub' :: F.SrcSpan -> RType -> RType -> CG SrcCstr 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 p1s (Known v _)) (TCon c2 t2s p2s (Known w q)) | c1 == c2 = do let cTop = cAll l v s (cHead l (subst q w v)) cIns <- subs l t1s t2s cARefs <- subPs l p1s p2s return (cAnd cTop (cAnd cIns cARefs)) 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 subPs :: F.SrcSpan -> [RARef] -> [RARef] -> CG SrcCstr subPs l (p1:p1s) (p2:p2s) = cAnd (subP l p1 p2) <$> subPs l p1s p2s subPs l [] [] = pure cTrue subPs l _ _ = error "subPs: mismatch" {- | [Sub-ARef] G; x1:t... |- p1 => p2[x2 := x1] --------------------------------- G |- \x1:t. p1 <: \x2:t. p2 -} subP :: F.SrcSpan -> RARef -> RARef -> SrcCstr subP l (ARef xts1 (Known _ p1)) (ARef xts2 (Known _ p2)) = cImpl l xts1 p1 (substs p2 su) where su = Misc.traceShow "subP" $ safeZip "subP" (fst <$> xts2) (fst <$> xts1) ------------------------------------------------------------------------------- -- | '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-RAbs] ρ = κ:t -> Bool s' = s[κ := fκ] G; fκ : t → Bool ⊢ e <== s' ----------------------------------------------------------------[Chk-RAbs] G |- e <== all ρ. s -} check g e (TRAll r s) = do c <- check g' e s' return (cAllF l kf kt c) where l = label e g' = extEnv g kf kt s' = hvarPred kf <$> s (kf, kt) = predBind r {- [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) -------------------------------------------------------------------- -- | '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 ps (Known v p)) = TCon c ts ps (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 $ Misc.traceShow "synthImm" $ 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 <- Misc.traceShow "EANN-FRESH" <$> 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 {- [Syn-RApp] G |- e => forall r.s r = K:t... -> bool p = fresh(G, t...-> bool) ---------------------------------------------------------------------- G |- e[?] => s [ r := p ] -} synth g (ERApp e l) = do (c, s) <- synth g e s' <- Misc.traceShow ("SYN-RApp: " ++ show (void e, void s)) <$> rinst l s return (c, s') 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 ps _) = TCon c (go <$> ts) ps 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 ps r) = TCon c <$> mapM (fresh l g) ts <*> pure ps <*> freshR l g (rTypeSort t) r fresh l g (TAll a t) = TAll a <$> fresh l g t fresh l g (TRAll r t) = TRAll r <$> 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 rinst :: F.SrcSpan -> RType -> CG RType rinst l (TRAll (RVar p ts) s) = do ar <- freshKVarReft l ts return (subsAR p ar s) rinst _ s = return s freshKVarReft :: F.SrcSpan -> [RSort] -> CG RARef freshKVarReft l ts = do k <- freshKVar l (rSortToFSort <$> ts) return $ rVarARef (RVar k ts) -- | Abstract Refinement Substitutions (sec 7.2.1) ------------------------------------ {- rinst :: F.SrcSpan -> RType -> CG RType rinst l (TRAll (RVar p ts) s) = do s' <- rinst l s k <- freshKVar l (rSortToFSort <$> ts) return (substKVar p k <$> s') rinst _ s = return s -- | @substK f k@ replaces all occurences of `H.Var f xs` with `H.Var k xs` substKVar :: F.Symbol -> F.Symbol -> Reft -> Reft substKVar _ _ Unknown = Unknown substKVar f k (Known v p) = Known v (go p) where go pred = case pred of H.Var g xs | f == g -> H.Var k xs H.PAnd preds -> H.PAnd (go <$> preds) _ -> pred -} -- | @hvarPred f r@ converts all occurrences of `H.Var f xs` in `r` to `H.Reft (EApp f xs)` hvarPred :: F.Symbol -> Reft -> Reft hvarPred _ Unknown = Unknown hvarPred f (Known v p) = Known v (go p) where go (H.Var g xs) | f == g = H.Reft (predApp f xs) go (H.PAnd ps) = H.PAnd (go <$> ps) go r = r predBind :: RVar -> (F.Symbol, RType) predBind (RVar p ts) = (p, TCon "Pred" (rSortToRType <$> ts) mempty mempty) ================================================ FILE: src/Language/Sprite/L6/Constraints.hs ================================================ -- | This module has the kit needed to do constraint generation: -- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution. {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Eta reduce" #-} module Language.Sprite.L6.Constraints ( -- * Constraints cTrue, cAnd, cHead, cAll, cAllF, cImpl, 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, freshKVar ) 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.L6.Types import Language.Sprite.L6.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 {-@ ListNE a = {v:_ | len v > 0} @-} type ListNE a = [a] cImpl :: F.SrcSpan -> ListNE (F.Symbol, RSort) -> H.Pred -> H.Pred -> SrcCstr cImpl l xts p1 p2 = go [ (x, rSortToFSort t) | (x, t) <- xts] where go [(x,t)] = H.All (bind l x t p1) (cHead l p2) go ((x,t):xts) = H.All (bind l x t mempty) (go xts) 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 -- | @cAllF@ is a variant of @cAll@ used when the binder is a function, e.g. in [Chk-RAbs] cAllF :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr cAllF l f t c = H.All (bind l f (rTypeSort t) mempty) 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 (as, ps, t) <- bkAlls <$> getEnv g c ty@(TCon _ ts rs _) <- getEnv g y prs <- Misc.safeZip ps rs ats <- Misc.safeZip as ts return (ty, rsubsts prs . 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] -> CG F.Symbol freshKVar l ts = do k <- F.kv . F.intKvar <$> freshInt _ <- addSrcKVar (H.HVar k 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/L6/Elaborate.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Language.Sprite.L6.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.L6.Prims import Language.Sprite.L6.Types import Language.Sprite.L6.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 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) = bkAlls 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 extEnvTVs :: Env -> [TVar] -> Env extEnvTVs = foldr (flip extEnvTV) ------------------------------------------------------------------------------- elabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType) elabS g e@(EImm i _) = do (ts, n, t') <- Misc.traceShow ("elabS: " ++ show i) <$> immS g i return (mkTApp e ts n, t') elabS g (EAnn e s l) = do let (as, _, t) = bkAlls 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) ) =<< immS g y t' <- subsTyM t return (EApp e' y l, t') _ -> elabErr ("elabS: Application to non-function; caller type = " <+> UX.tshow te) 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], Int, RType) instantiate = go [] 0 where go ts n (TAll a s) = do v <- fresh let vt = TBase (TVar v) mempty go (vt:ts) n (tsubst a vt s) go ts n (TRAll _ s) = go ts (n+1) s go ts n s = return (reverse ts, n, s) 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 immS :: Env -> SrcImm -> ElabM ([RType], Int, RType) immS g i = instantiate =<< immTy g i where immTy :: Env -> SrcImm -> ElabM RType immTy g (EVar x l) | Just t <- getEnv g x = return 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] -> Int -> ElbExpr mkTApp e ts n = mkRApps n (mkTApps e ts) where mkRApps 0 e = e mkRApps k e = mkRApps (k-1) (ERApp e (label e)) mkTApps = 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 RARef where subsTy su (ARef xts p) = ARef xts' p where xts' = [(x, subsTy su t) | (x, t) <- xts ] 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 ps r) = TCon c (subsTy su <$> ts) (subsTy su <$> ps) 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 subsTy su (TRAll p t) = TRAll p' t' where t' = subsTy su t p' = subsTy su p instance SubsTy RVar where subsTy su (RVar p args) = RVar p (subsTy su <$> args) instance SubsTy RSort where subsTy su = asRType (subsTy 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 (ERApp e l) = ERApp (go e) 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/L6/Parse.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Language.Sprite.L6.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 qualified Language.Fixpoint.Horn.Types as H import Language.Sprite.Common import qualified Language.Sprite.Common.Misc as Misc import Language.Sprite.Common.Parse import Language.Sprite.L6.Types hiding (rVarARef, immExpr) -- import Language.Sprite.L6.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 FP.reserved "type" tc <- FP.lowerIdP tvars <- typArgs rvars <- commaList refVar (FP.reservedOp "=" >> FP.spaces) ctors <- ctorsP return (Data tc tvars rvars (mkCtor tc tvars rvars <$> 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 <$> (FP.spaces *> 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 "=>" *> FP.brackets concReftB) <|> return Nothing mkCtor :: Ident -> [Ident] -> [RVar] -> Ctor -> (SrcBind, RType) mkCtor tc tvs rvs c = (dc, closeType rvs xts dcRes) where -- dcType = foldr (\(x, t) s -> TFun x t s) dcRes xts dcRes = TCon tc (rVar <$> tvs) (rVarARef <$> rvs) dcReft Ctor dc xts r = c dcReft = Mb.fromMaybe mempty r closeType :: [RVar] -> [(F.Symbol, RType)] -> RType -> RType closeType rvs xts = tyParams . rvarParams . valParams where tyParams = generalize rvarParams t = foldr TRAll t rvs valParams ty = foldr (\(x, t) s -> TFun x t s) ty xts rVarARef :: RVar -> RARef rVarARef (RVar p ts) = ARef xts (predReft pred) where xts = zipWith (\t i -> (F.intSymbol "rvTmp" i, t)) ts [0..] pred = F.eApps (F.expr p) (F.expr . fst <$> xts) commaList :: FP.Parser a -> FP.Parser [a] commaList p = try (FP.parens (sepBy p FP.comma)) <|> return [] quals :: FP.Parser [F.Qualifier] quals = try ((:) <$> between annL annR qual <*> quals) <|> pure [] qual ::FP.Parser F.Qualifier qual = FP.reserved "qualif" >> FP.qualifierP (rTypeSort <$> rtype) expr :: FP.Parser SrcExpr expr = try funExpr <|> try letExpr <|> try ifExpr <|> try switchExpr <|> 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) switchExpr :: FP.Parser SrcExpr switchExpr = withSpan' $ do FP.reserved "switch" x <- FP.parens FP.lowerIdP alts <- FP.braces (many altP) return (ECase x alts) altP :: FP.Parser SrcAlt altP = withSpan' $ Alt <$> (FP.spaces *> 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 = (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 "=>" -- _ <- FP.reservedOp "{" body <- FP.braces (expr <* FP.spaces) -- _ <- 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 = FP.reservedOp "/*@" annR = FP.reservedOp "*/" tyBindP :: String -> FP.Parser (F.Symbol, RType) tyBindP kw = do FP.reserved kw 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 (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 = (FP.reserved "forall" >> rall) <|> try rfun <|> rtype0 rtype0 :: FP.Parser RType rtype0 = FP.parens rtype <|> rbase rfun :: FP.Parser RType rfun = mkTFun <$> funArgP <*> (FP.reservedOp "=>" *> rtype) rall :: FP.Parser RType rall = TRAll <$> FP.parens refVar <*> (FP.dot *> rtype) refVar :: FP.Parser RVar refVar = mkRVar <$> FP.lowerIdP <*> (FP.colon *> rtype) mkRVar :: F.Symbol -> RType -> RVar mkRVar p t | isBool out = RVar p [ const () <$> s | (_, s) <- xs ] | otherwise = error "Refinement variable must have `bool` as output type" where (xs, out) = bkFun t isBool :: RType -> Bool isBool t = rTypeSort t == F.boolSort funArgP :: FP.Parser FunArg funArgP = 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 = try (TBase <$> tbase <*> refTop) <|> TCon <$> identifier' <*> commaList rtype <*> tConARefs <*> refTop tbase :: FP.Parser Base tbase = (FP.reserved "int" >> pure TInt) <|> (FP.reserved "bool" >> pure TBool) <|> (tvarP >>= return . TVar. TV) tConARefs :: FP.Parser [RARef] tConARefs = try (commaList aRef) <|> pure [] tvarP :: FP.Parser F.Symbol tvarP = FP.reservedOp "'" >> FP.lowerIdP -- >>= return . TVar . TV refTop :: FP.Parser Reft refTop = FP.brackets reftB <|> pure mempty reftB :: FP.Parser Reft reftB = (question >> pure Unknown) <|> concReftB concReftB :: FP.Parser Reft concReftB = KReft <$> (FP.lowerIdP <* mid) <*> myPredP aRef :: FP.Parser (ARef Reft) aRef = ARef <$> commaList aRefArg <* FP.reservedOp "=>" <*> aRefBody where aRefArg :: FP.Parser (F.Symbol, RSort) aRefArg = (,) <$> FP.lowerIdP <* FP.colon <*> rSortP aRefBody :: FP.Parser Reft aRefBody = predReft <$> myPredP predReft :: F.Pred -> Reft predReft = Known F.dummySymbol . H.Reft rSortP :: FP.Parser RSort rSortP = rTypeToRSort <$> rtype0 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)) ================================================ FILE: src/Language/Sprite/L6/Prims.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Language.Sprite.L6.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.L6.Types import Language.Sprite.L6.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 (TRAll p t) = TRAll p (rebind t) rebind (TCon c ts ps r) = TCon c (rebind <$> ts) ps 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/L6/Types.hs ================================================ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Language.Sprite.L6.Types where import qualified Language.Fixpoint.Misc as Misc import qualified Language.Fixpoint.Horn.Types as H import qualified Language.Fixpoint.Horn.Transformations as H import qualified Language.Fixpoint.Types as F -- 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 -- | Refinement Variables ----------------------------------------------------- data RVar = RVar { rvName :: F.Symbol , rvArgs :: ![RSort] } deriving (Eq, Show) -- | Abstract Refinements ----------------------------------------------------- data ARef r = ARef { arArgs :: ![(F.Symbol, RSort)] , arPred :: r } deriving (Eq, Show, Functor) -- | 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] ![ARef r] r -- ^ C t1...tn p1...pm | TRAll !RVar !(Type r) -- ^ rall r. t deriving (Eq, Show, Functor) 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 -- | Proper refinement Types -------------------------------------------------- type RType = Type Reft type RARef = ARef Reft -- | Sorts: types decorated with unit refinements ----------------------------- type RSort = Type () -- | 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) | ERApp !(Expr a) a -- ^ e [?] (reft 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 (ERApp _ 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 , dcRVars :: ![RVar] -- ^ refinement 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 ARef where instance F.Subable r => F.Subable (ARef r) where syms (ARef _ p) = F.syms p substa f (ARef xts p) = ARef xts (F.substa f p) substf f (ARef xts p) = ARef xts (F.substf f p) subst f (ARef xts p) = ARef xts (F.subst f p) 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 (TRAll _ t) = F.syms t syms (TFun _ s t) = F.syms s ++ F.syms t syms (TCon _ ts ps r) = concatMap F.syms ts ++ concatMap F.syms ps ++ 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 (TRAll p t) = TRAll p (F.substa f t) substa f (TCon c ts ps r) = TCon c (F.substa f <$> ts) (F.substa f <$> ps) (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 (TRAll p t) = TRAll p (F.substf f t) substf f (TCon c ts ps r) = TCon c (F.substf f <$> ts) (F.substf f <$> ps) (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 (TRAll p t) = TRAll p (F.subst f t) subst f (TCon c ts ps r) = TCon c (F.subst f <$> ts) (F.subst f <$> ps) (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 ()) substs :: (F.Subable a) => a -> [(F.Symbol, F.Symbol)] -> a substs thing xys = L.foldl' (\t (x, y) -> subst t x y) thing xys 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" -------------------------------------------------------------------------------- -- | Normalizing types by generalizing tyvars, refactoring ref-var applications -------------------------------------------------------------------------------- generalize :: RType -> RType generalize = refactorApp . generalizeTVar -------------------------------------------------------------------------------- -- | Substituting 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 (TRAll p t) = TRAll (goP p) (go t) go (TFun x s1 s2) = TFun x (go s1) (go s2) go (TBase b r) = bsubst a t b r go (TCon c ts ps r) = TCon c (go <$> ts) (goA <$> ps) r goP p = p { rvArgs = [ asRType go t | t <- rvArgs p ] } goA a = a { arArgs = [ (x, asRType go t) | (x, t) <- arArgs a ] } 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 strengthenTop t@(TAll {}) _ = t strengthenTop t@(TRAll {}) _ = t strengthenTop (TBase b r) r' = TBase b (r <> r') strengthenTop (TCon c ts ps r) r' = TCon c ts ps (r <> r') generalizeTVar :: RType -> RType generalizeTVar t = foldr TAll t (freeTVars t) freeTVars :: Type a -> [TVar] freeTVars = Misc.sortNub . S.toList . go where goP = S.fromList . concatMap freeTVars . rvArgs go (TAll a t) = S.delete a (go t) go (TRAll p t) = S.union (goP p) (go t) go (TFun _ s t) = S.union (go s) (go t) go (TCon _ ts _ _) = S.unions ((go <$> ts)) go (TBase b _) = goB b goB (TVar a) = S.singleton a goB _ = S.empty ------------------------------------------------------------------------------- -- | Types and Sorts ------------------------------------------------------------------------------- baseSort :: Base -> F.Sort baseSort TInt = F.intSort baseSort TBool = F.boolSort baseSort (TVar a) = F.FObj (F.symbol a) rTypeSort :: RType -> F.Sort rTypeSort (TBase b _) = baseSort b rTypeSort (TCon c ts _ _) = F.fAppTC (fTyCon c) (rTypeSort <$> ts) rTypeSort t@(TFun {}) = rTypeSortFun t rTypeSort t@(TAll {}) = rTypeSortAll t rTypeSort (TRAll _ t) = rTypeSort t rTypeSortFun :: RType -> F.Sort rTypeSortFun = F.mkFFunc 0 . fmap rTypeSort . go [] where go ts (TFun _ t1 t2) = go (t1:ts) t2 go ts t = reverse (t:ts) rTypeSortAll :: RType -> F.Sort rTypeSortAll s = genSort (rTypeSort t) where genSort t = L.foldl' (flip F.FAbs) (F.sortSubst su t) [0..n-1] (as, t) = bkAll s su = F.mkSortSubst $ zip sas (F.FVar <$> [0..]) sas = F.symbol <$> as n = length as bkAll :: RType -> ([TVar], RType) bkAll (TAll a s) = (a:as, t) where (as, t) = bkAll s bkAll t = ([] , t) bkRAll :: RType -> ([RVar], RType) bkRAll (TRAll p s) = (p:ps, t) where (ps, t) = bkRAll s bkRAll t = ([] , t) fTyCon :: TyCon -> F.FTycon fTyCon = F.symbolFTycon . F.dummyLoc bkFun :: RType -> ([(F.Symbol, RType)], RType) bkFun (TFun x s t) = ((x, s) : ins, out) where (ins, out) = bkFun t bkFun out = ([] , out) -- | See [NOTE:RefactorApp] --------------------------------------------------- refactorApp :: RType -> RType refactorApp s = tAlls as ps (refactorAppR isRV <$> t) where (as,ps,t) = bkAlls s pvs = S.fromList (rvName <$> ps) isRV p = S.member p pvs tAlls :: [TVar] -> [RVar] -> RType -> RType tAlls as ps = tAll as . tRAll ps tAll :: [TVar] -> Type a -> Type a tAll as t = foldr TAll t as tRAll :: [RVar] -> Type a -> Type a tRAll ps t = foldr TRAll t ps bkAlls :: RType -> ([TVar], [RVar], RType) bkAlls s = (as, ps, t) where (as, s') = bkAll s (ps, t) = bkRAll s' refactorAppR :: (F.Symbol -> Bool) -> Reft -> Reft refactorAppR isRV (Known v p) = Known v (refactorAppP isRV p) refactorAppR _ r = r -- | See [NOTE:RefactorApp] --------------------------------------------------- refactorAppP :: (F.Symbol -> Bool) -> H.Pred -> H.Pred refactorAppP isRV p = H.PAnd (H.Reft (F.pAnd fs) : rs) where es = predExprs p (rs, fs) = Misc.mapEither (isRVarApp isRV) es isRVarApp :: (F.Symbol -> Bool) -> F.Expr -> Either H.Pred F.Expr isRVarApp isRV e@(F.EApp {}) | (F.EVar k, args) <- F.splitEApp e , isRV k = Left (H.Var k (rvarArgSymbol msg <$> args)) where msg = F.showpp e isRVarApp _ e = Right e rvarArgSymbol :: String -> F.Expr -> F.Symbol rvarArgSymbol _ (F.EVar x) = x rvarArgSymbol msg e = error $ "Unexpected argument in ref-variable: " ++ msg ++ " " ++ show e predExprs :: H.Pred -> [F.Expr] predExprs p = case H.flatten p of H.PAnd ps -> concatMap go ps q -> go q where go (H.Reft e) = F.conjuncts e go _ = error "unexpected H.Pred in predExprs" {- | [NOTE:RefactorApp] The parser cannot distinguish between * plain applications (f x y z) and * ref-var applications (p x y z) using `H.Var !F.Symbol ![F.Symbol] -- ^ $k(y1..yn)` So, post-parsing, we traverse the refinements with an `isRV` test to pull the ref-var applications out. -} asRType :: (RType -> RType) -> RSort -> RSort asRType f = rTypeToRSort . f . rSortToRType rTypeToRSort :: RType -> RSort rTypeToRSort = fmap (const ()) rSortToRType :: RSort -> RType rSortToRType = fmap (const mempty) rSortToFSort :: RSort -> F.Sort rSortToFSort = rTypeSort . rSortToRType rVarARef :: RVar -> RARef rVarARef (RVar p ts) = ARef xts (Known F.dummySymbol pred) where xts = zipWith (\t i -> (F.intSymbol "kvTmp" i, t)) ts [0..] pred = H.Var p (fst <$> xts) ------------------------------------------------------------------------------- -- | Substituting Refinement Variables ----------------------------------------------- ------------------------------------------------------------------------------- class SubsARef a where subsAR :: F.Symbol -> RARef -> a -> a instance SubsARef H.Pred where subsAR p (ARef yts (Known _ pr)) = go where go (H.Var k xs) | k == p = substs pr (zipWith (\(y,_) x -> (y, x)) yts xs) go (H.PAnd ps ) = H.PAnd (go <$> ps) go pred = pred instance SubsARef Reft where subsAR p ar (Known v pr) = Known v (subsAR p ar pr) subsAR p ar r = r instance SubsARef RType where subsAR p ar t = subsAR p ar <$> t rsubsts :: (SubsARef a) => [(RVar, RARef)] -> a -> a rsubsts rps z = L.foldl' (\x (p, ar) -> rsubst1 p ar x) z rps rsubst1 :: (SubsARef a) => RVar -> RARef -> a -> a rsubst1 (RVar p _) ar z = subsAR p ar z ================================================ FILE: src/Language/Sprite/L6.hs ================================================ module Language.Sprite.L6 ( sprite ) where import System.Exit import qualified Language.Fixpoint.Types as F import Language.Sprite.L6.Check import Language.Sprite.L6.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/L8/Check.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use uncurry" #-} {-# HLINT ignore "Eta reduce" #-} module Language.Sprite.L8.Check (vcgen) where import Data.Maybe (isJust) import Control.Monad (void) import Control.Monad.Except (throwError, catchError) import qualified Data.HashMap.Strict as M import Text.PrettyPrint.HughesPJ (Doc, (<+>), text ) import qualified Language.Fixpoint.Horn.Types as H import qualified Language.Fixpoint.Horn.Transformations 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 Language.Sprite.Common import Language.Sprite.L8.Types import Language.Sprite.L8.Reflect import Language.Sprite.L8.Prims ( bTrue, constTy ) import Language.Sprite.L8.Constraints import Language.Sprite.L8.Elaborate ( elaborate ) -- import Debug.Trace (trace) ------------------------------------------------------------------------------- vcgen:: SrcProg -> Either [UX.UserError] SrcQuery ------------------------------------------------------------------------------- vcgen (Prog qs ms e typs) = do let env = empEnv ms typs let eL = elaborate env e let ps = [(pappSym n, pappSort n) | n <- [1..3]] let pqs = pappQual <$> [1..3] (cI, _) <- run (H.CAnd <$> mapM (checkData env) typs) (c,cgi) <- run (check env eL (bTrue TInt)) let rfls = cgiConsts cgi let syms = M.fromList (ps ++ ms ++ rfls) let c' = strengthenInv env c let decs = reflectData <$> {- Misc.traceShow "data-typs" -} typs return $ mkQuery (qs ++ pqs) (cgiKVars cgi) (H.flatten (cAnd cI c')) syms (cgiDefs cgi) decs mkQuery :: [F.Qualifier] -> [H.Var a] -> H.Cstr a -> M.HashMap F.Symbol F.Sort -> [F.Equation] -> [F.DataDecl] -> H.Query a mkQuery qs ks c syms defs ddecls = H.Query { H.qQuals = qs , H.qVars = ks , H.qCstr = c , H.qCon = syms , H.qDis = mempty , H.qEqns = defs , H.qMats = mempty , H.qData = ddecls , H.qOpts = [] } ------------------------------------------------------------------------------- -- | Add Inv assumptions for all data-type binders in SrcCstr ------------------------------------------------------------------------------- simplCstr :: SrcCstr -> SrcCstr simplCstr = go where go (H.CAnd cs) = H.CAnd (go <$> cs) go (H.All b c) = H.All (goB b) (go c) go c = c goB (H.Bind x t p z) = H.Bind x t p z strengthenInv :: Env -> SrcCstr -> SrcCstr strengthenInv g = go where go (H.CAnd cs) = H.CAnd (go <$> cs) go (H.All b c) = H.All (strengthenBind g b) (go c) go c = c strengthenBind :: Env -> H.Bind a -> H.Bind a strengthenBind g b@(H.Bind x t p z) = case getInv g x t of Nothing -> b Just p' -> H.Bind x t (p <> p') z ------------------------------------------------------------------------------- sub :: F.SrcSpan -> RType -> RType -> CG SrcCstr ------------------------------------------------------------------------------- sub l s t = sub' l s t `catchError` (\es -> throwError (UX.mkError msg l : es)) where msg = text $ "Invalid Subtyping: " ++ show (s, t) {- | [Sub-Base] (v::t) => q[w := v] ------------------- b{v:p} <= b{w:q} -} sub' :: F.SrcSpan -> RType -> RType -> CG SrcCstr 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 p1s (Known v _)) (TCon c2 t2s p2s (Known w q)) | c1 == c2 = do let cTop = cAll l v s (cHead l (subst q w v)) cIns <- subs l t1s t2s cARefs <- subPs l p1s p2s return (cAnd cTop (cAnd cIns cARefs)) 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 subPs :: F.SrcSpan -> [RARef] -> [RARef] -> CG SrcCstr subPs l (p1:p1s) (p2:p2s) = cAnd (subP l p1 p2) <$> subPs l p1s p2s subPs l [] [] = pure cTrue subPs l _ _ = error "subPs: mismatch" {- | [Sub-ARef] G; x1:t... |- p1 => p2[x2 := x1] --------------------------------- G |- \x1:t. p1 <: \x2:t. p2 -} subP :: F.SrcSpan -> RARef -> RARef -> SrcCstr subP l (ARef xts1 (Known _ p1)) (ARef xts2 (Known _ p2)) = cImpl l xts1 p1 (substs p2 su) where su = Misc.safeZip "subP" (fst <$> xts2) (fst <$> xts1) ------------------------------------------------------------------------------- -- | Checking Invariants ------------------------------------------------------------------------------- checkData :: Env -> SrcData -> CG SrcCstr checkData g d = H.CAnd <$> mapM (checkCtor g (dcInv d)) (dcCtors d) checkCtor :: Env -> Reft -> (SrcBind, RType) -> CG SrcCstr checkCtor g inv (dc, t) = checkInv (label dc) g inv t checkInv :: F.SrcSpan -> Env -> Reft -> RType -> CG SrcCstr checkInv l g inv = go where go (TFun x s t) = cAll l x s' <$> go t where s' = getInv' g s go (TAll a t) = go t go (TRAll r t) = cAllF l kf kt <$> go t where (kf, kt) = predBind r go t = sub l t t' where t' = tTrue t `strengthenTop` inv tTrue :: RType -> RType tTrue = go where go (TBase b _) = TBase b mempty go (TFun b s t) = TFun b (go s) (go t) go (TCon c ts ps _) = TCon c (go <$> ts) (goP <$> ps) mempty go (TAll a t) = TAll a (go t) go (TRAll a t) = TRAll a (go t) goP (ARef xts _) = ARef xts mempty ------------------------------------------------------------------------------- -- | '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 (Let (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-Refl] t := fresh(G, s) == forall a*. (y:s)* -> tb e == \a*.\y*. eb G' = G,a*,(y:s)*, x:lim(G, m, t) |- eb <== tb G, x:reflect(e,t) |- e' <= t' ^^^^^^^^^^^^ ------------------------------------------------------------------------------- G |- def x = e:s/m in e' <= t' -} {- [Chk-Rec] t := fresh(G, s) == forall a*. (y:s)* -> tb e == \a*.\y*. eb G' = G,a*,(y:s)*, x:lim(G, m, t) |- eb <== tb G, x:t |- e' <= t' ------------------------------------------------------------------- G |- let rec x = (e : s / m) in e' <= t' -} check g (ELet (Rec (Bind x l) (EAnn e ann (_, s, mMb) _) sp) e' _) t' = do m <- fromMaybeM l "Missing termination metric!" mMb let (s', m') = renameTy e s m t <- fresh l g s' let (bs, tb, eb) = introEnv t e let g' = foldr (\(x, s) g -> extEnv g x s) g bs let tlim = limit sp g m' t c <- check (extEnv g' x tlim) eb tb tx <- case ann of Val -> pure t Refl -> reflect x e t c' <- check (extEnv g x tx) e' t' return $ cAnd (cAlls l bs 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-RAbs] ρ = κ:t -> Bool s' = s[κ := fκ] G; fκ : t → Bool ⊢ e <== s' ----------------------------------------------------------------[Chk-RAbs] G |- e <== all ρ. s -} check g e (TRAll r s) = do c <- check g' e s' return (cAllF l kf kt c) where l = label e g' = extEnv g kf kt s' = hvarPred kf <$> s (kf, kt) = predBind r {- [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) fromMaybeM :: F.SrcSpan -> Doc -> Maybe a -> CG a fromMaybeM l msg (Just x) = pure x fromMaybeM l msg Nothing = failWith msg l -------------------------------------------------------------------- -- | '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 ps (Known v p)) = TCon c ts ps (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 a (_,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 {- [Syn-RApp] G |- e => forall r.s r = K:t... -> bool p = fresh(G, t...-> bool) ---------------------------------------------------------------------- G |- e[?] => s [ r := p ] -} synth g (ERApp e l) = do (c, s) <- synth g e s' <- Misc.traceShow ("SYN-RApp: " ++ show (void e, void s)) <$> rinst l s return (c, s') 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 ps _) = TCon c (go <$> ts) ps 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 ps r) = TCon c <$> mapM (fresh l g) ts <*> pure ps <*> freshR l g (rTypeSort t) r fresh l g (TAll a t) = TAll a <$> fresh l g t fresh l g (TRAll r t) = TRAll r <$> 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 rinst :: F.SrcSpan -> RType -> CG RType rinst l (TRAll (RVar p ts) s) = do ar <- freshKVarReft l ts return (subsAR p ar s) rinst _ s = return s freshKVarReft :: F.SrcSpan -> [RSort] -> CG RARef freshKVarReft l ts = do k <- freshKVar l (rSortToFSort <$> ts) return $ rVarARef (RVar k ts) --------------------------------------------------------------------------------- -- | Termination: Limiting a Type with a Metric --------------------------------- --------------------------------------------------------------------------------- limit :: F.SrcSpan -> Env -> Metric -> RType -> RType limit sp g m t = lim sp g m m t lim :: F.SrcSpan -> Env -> Metric -> Metric -> RType -> RType lim sp g mO m (TFun x s t) | isBase s && wfMetric sp (extEnv g x s) mO = TFun x' s' t' where s' = subst s x x' `strengthenTop` Known x' (H.Reft (wfr mO m')) m' = subst m x x' t' = subst t x x' x' = F.suffixSymbol x "next" lim sp g mO m (TFun x s t) = TFun x' s' t'' where t'' = lim sp (extEnv g x s) mO m' t' m' = subst m x x' s' = subst s x x' t' = subst t x x' x' = F.suffixSymbol x "next" lim sp g mO m (TAll a t) = TAll a (lim sp g mO m t) lim sp g mO m (TRAll a t) = TRAll a (lim sp g mO m t) lim sp g mO _ t = error $ "Malformed Metric" ++ show (envSorts g, mO, t) -- Well-foundedness Refinement -------------------------------------------------- wfr :: Metric -> Metric -> F.Expr wfr [pO] [p] = F.pAnd [nat p, p `lt` pO ] wfr (pO:mO) (p:m) = F.pAnd [nat p, F.pOr [ p `lt` pO, r ]] where r = F.pAnd [p `eq` pO, wfr mO m ] -- | Replaces the types in a signature with those in the function definition renameTy :: SrcExpr -> RType -> Metric -> (RType, Metric) renameTy (ETLam _ e _) (TAll a t) m = (TAll a t', m') where (t', m') = renameTy e t m renameTy (EFun bx e l) (TFun y s t) m = (TFun x s' t'', m') where x = bindId bx s' = subst s y x t' = subst t y x (t'', m') = renameTy e t' m renameTy _ t m = (t, m) -- | Assumes that the binders in `RType` and `SrcExpr` have been unified introEnv :: RType -> SrcExpr -> ([(F.Symbol, RType)] , RType, SrcExpr) introEnv = go [] where go bs (TFun x s t) (EFun _ e l) = go ((x, s) : bs) t e go bs tb eb = (reverse bs, tb, eb) -- | Abstract Refinement Substitutions (sec 7.2.1) ------------------------------------ {- rinst :: F.SrcSpan -> RType -> CG RType rinst l (TRAll (RVar p ts) s) = do s' <- rinst l s k <- freshKVar l (rSortToFSort <$> ts) return (substKVar p k <$> s') rinst _ s = return s -- | @substK f k@ replaces all occurences of `H.Var f xs` with `H.Var k xs` substKVar :: F.Symbol -> F.Symbol -> Reft -> Reft substKVar _ _ Unknown = Unknown substKVar f k (Known v p) = Known v (go p) where go pred = case pred of H.Var g xs | f == g -> H.Var k xs H.PAnd preds -> H.PAnd (go <$> preds) _ -> pred -} -- | @hvarPred f r@ converts all occurrences of `H.Var f xs` in `r` to `H.Reft (EApp f xs)` hvarPred :: F.Symbol -> Reft -> Reft hvarPred _ Unknown = Unknown hvarPred f (Known v p) = Known v (go p) where go (H.Var g xs) | f == g = H.Reft (predApp f xs) go (H.PAnd ps) = H.PAnd (go <$> ps) go r = r predBind :: RVar -> (F.Symbol, RType) predBind (RVar p ts) = (p, TCon (tc "Pred") (rSortToRType <$> ts) mempty mempty) ================================================ FILE: src/Language/Sprite/L8/Constraints.hs ================================================ -- | This module has the kit needed to do constraint generation: -- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution. {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Eta reduce" #-} module Language.Sprite.L8.Constraints ( -- * Constraints cTrue, cAnd, cHead, cAll, cAllF, cImpl, pAnd -- * Substitutions , subst, substImm -- * Conversions , predRType, rTypeSort -- * Environments , Env, empEnv, getEnv, extEnv, extEnvs , extEnvTV, grdSym, envSorts , getInv, getInv' -- * Case-Related manipulation , unfoldEnv, unfoldEnv' -- * Constraint Generation Monad , CG, run, failWith, freshK, freshKVar, freshValueSym , addReflectVar , CGInfo (..) -- * well-formedness , wfMetric ) 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.Fixpoint.SortCheck as F import qualified Language.Sprite.Common.UX as UX import qualified Language.Sprite.Common.Misc as Misc import Language.Sprite.Common ( SrcCstr, SrcHVar, bind ) import Language.Sprite.L8.Types import Language.Sprite.L8.Prims ( prelude ) import qualified Data.HashMap.Internal.Strict as M -------------------------------------------------------------------------------- -- | 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 {-@ ListNE a = {v:_ | len v > 0} @-} type ListNE a = [a] cImpl :: F.SrcSpan -> ListNE (F.Symbol, RSort) -> H.Pred -> H.Pred -> SrcCstr cImpl l xts p1 p2 = go [ (x, rSortToFSort t) | (x, t) <- xts] where go [(x,t)] = H.All (bind l x t p1) (cHead l p2) go ((x,t):xts) = H.All (bind l x t mempty) (go xts) 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 sp x t c = case sortPred x t of Just (so, p) -> H.All (bind sp x so p) c _ -> c -- | @cAllF@ is a variant of @cAll@ used when the binder is a function, e.g. in [Chk-RAbs] cAllF :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr cAllF sp f t c = H.All (bind sp f (rTypeSort t) mempty) 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 , eSorts :: !(F.SEnv F.Sort) -- ^ sort-environment (for WF checks) , eInv :: !(F.SEnv Reft) -- ^ (partial) map from tycon to invariant } instance Show Env where show = show . F.toListSEnv . eBinds 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 , eSorts = F.insertSEnv x (rTypeSort t) (eSorts 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) getInv :: Env -> F.Symbol -> F.Sort -> Maybe H.Pred getInv env x t = case F.unFApp t of F.FTC tc : _ -> case F.lookupSEnv (F.symbol tc) (eInv env) of Just (Known v p) -> Just (subst p v x) _ -> Nothing _ -> Nothing getInv' :: Env -> RType -> RType getInv' env t@(TCon c _ _ _) = case F.lookupSEnv (F.symbol c) (eInv env) of Nothing -> t Just r -> strengthenTop t r getInv' _ t = t empEnv :: [(F.Symbol, F.Sort)] -> [SrcData] -> Env empEnv ms typs = foldr (\(x, t) g -> extEnv g x t) env0 prelSigs where env0 = Env mempty 0 mempty (F.fromListSEnv ms) (tcInvs typs) prelSigs = prelude ++ concatMap dataSigs typs tcInvs :: [SrcData] -> F.SEnv Reft tcInvs tcs = F.fromListSEnv [ (F.symbol (dcName d), inv) | d <- tcs, let inv@(Known v p) = dcInv d, p /= mempty ] dataSigs :: SrcData -> [(F.Symbol, RType)] dataSigs dc = [(F.symbol b, t) | (b, t) <- dcCtors dc] envSorts :: Env -> [(F.Symbol, F.Sort)] envSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env) , (t, _) <- Mb.maybeToList (sortPred x s) ] -------------------------------------------------------------------------------- -- | Well-formedness ------------------------------------------------------------ -------------------------------------------------------------------------------- wfExpr :: F.SrcSpan -> Env -> F.Expr -> F.Sort -> Bool wfExpr sp g e t = F.checkSortExpr sp (eSorts g) e == Just t wfMetric :: F.SrcSpan -> Env -> Metric -> Bool wfMetric sp g m = all (\e -> wfExpr sp g e F.FInt) m -------------------------------------------------------------------------------- -- | 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 (as, ps, t) <- bkAlls <$> getEnv g c ty@(TCon _ ts rs _) <- getEnv g y prs <- Misc.safeZip ps rs ats <- Misc.safeZip as ts return (ty, rsubsts prs . 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 ------------------------------------------------------------------------------- -- | CG Monad ----------------------------------------------------------------- ------------------------------------------------------------------------------- type CG a = StateT CGState (Either [UX.UserError]) a data CGState = CGState { cgCount :: !Integer -- ^ monotonic counter, to get fresh things , cgInfo :: !CGInfo -- ^ extra bits needed for constraints } data CGInfo = CGInfo { cgiKVars :: [SrcHVar] , cgiConsts :: [(F.Symbol, F.Sort)] , cgiDefs :: [F.Equation] } s0 :: CGState s0 = CGState 0 (CGInfo [] [] []) run :: CG a -> Either [UX.UserError] (a, CGInfo) run act = do (x, s) <- runStateT act s0 return (x, cgInfo 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] -> CG F.Symbol freshKVar l ts = do k <- F.kv . F.intKvar <$> freshInt _ <- addSrcKVar (H.HVar k ts (UX.mkError "fake" l)) return k addSrcKVar :: SrcHVar -> CG () addSrcKVar k = modify $ \s -> let cgi = cgInfo s kvs = cgiKVars cgi in s { cgInfo = cgi { cgiKVars = k : kvs } } 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 addReflectVar :: Ident -> RType -> [(F.Symbol, F.Sort)] -> F.Sort -> F.Expr -> CG () addReflectVar f t xts ot e = modify $ \s -> let cgi = cgInfo s fDef = {- Misc.traceShow "mkEquation" $ -} F.mkEquation f xts e ot in s { cgInfo = cgi { cgiConsts = (f, rTypeSort t) : cgiConsts cgi , cgiDefs = fDef : cgiDefs cgi } } ================================================ FILE: src/Language/Sprite/L8/Elaborate.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Language.Sprite.L8.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.L8.Prims import Language.Sprite.L8.Types import Language.Sprite.L8.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 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 (Rec (Bind x l) (EAnn e1 a (bx, s1, m) l1) ld) e2 l2) t2 = do let g' = extEnv g x s1 let (as, _, t1) = bkAlls s1 e1' <- elabC (extEnvTVs g' as) e1 t1 e2' <- elabC g' e2 t2 return $ ELet (Rec (Bind x l) (EAnn (mkTLam e1' as) a (bx, s1, m) l1) ld) e2' l2 -- let x = e in e' elabC g (ELet (Let (Bind x l) e1 l1) e2 l2) t2 = do (e1', s) <- elabS g e1 e2' <- elabC (extEnv g x s) e2 t2 return $ ELet (Let (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 extEnvTVs :: Env -> [TVar] -> Env extEnvTVs = foldr (flip extEnvTV) ------------------------------------------------------------------------------- elabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType) elabS g e@(EImm i _) = do (ts, n, t') <- {- Misc.traceShow ("elabS: " ++ show i) <$> -} immS g i return (mkTApp e ts n, t') elabS g (EAnn e a (x, s, m) l) = do let (as, _, t) = bkAlls s e' <- elabC (extEnvTVs g as) e t return (EAnn (mkTLam e' as) a (x, s, m) 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) ) =<< immS g y t' <- subsTyM t return (EApp e' y l, t') _ -> elabErr ("elabS: Application to non-function; caller type = " <+> UX.tshow te) 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], Int, RType) instantiate = go [] 0 where go ts n (TAll a s) = do v <- fresh let vt = TBase (TVar v) mempty go (vt:ts) n (tsubst a vt s) go ts n (TRAll _ s) = go ts (n+1) s go ts n s = return (reverse ts, n, s) 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 immS :: Env -> SrcImm -> ElabM ([RType], Int, RType) immS g i = instantiate =<< immTy g i where immTy :: Env -> SrcImm -> ElabM RType immTy g (EVar x l) | Just t <- getEnv g x = return 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] -> Int -> ElbExpr mkTApp e ts n = mkRApps n (mkTApps e ts) where mkRApps 0 e = e mkRApps k e = mkRApps (k-1) (ERApp e (label e)) mkTApps = 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 RARef where subsTy su (ARef xts p) = ARef xts' p where xts' = [(x, subsTy su t) | (x, t) <- xts ] 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 ps r) = TCon c (subsTy su <$> ts) (subsTy su <$> ps) 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 subsTy su (TRAll p t) = TRAll p' t' where t' = subsTy su t p' = subsTy su p instance SubsTy RVar where subsTy su (RVar p args) = RVar p (subsTy su <$> args) instance SubsTy RSort where subsTy su = asRType (subsTy 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 (Let b e l) = Let b (subsTy su e) l subsTy su (Rec b e l) = Rec 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 a s l) = EAnn (go e) a (goS s) 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 (ERApp e l) = ERApp (go e) l go (ECase x as l) = ECase x (goA <$> as) l go e@(EImm {}) = e goS (x, t, m) = (x, subsTy su t, m) goA alt = 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/L8/Parse.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Language.Sprite.L8.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 qualified Language.Fixpoint.Horn.Types as H import Language.Sprite.Common import qualified Language.Sprite.Common.Misc as Misc import Language.Sprite.Common.Parse import Language.Sprite.L8.Types hiding (rVarARef, immExpr) -- import Language.Sprite.L8.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 typs) measureP :: FP.Parser (F.Symbol, F.Sort) measureP = annL >> (Misc.mapSnd (rTypeSort . generalize) <$> tyBindP "measure") typP :: FP.Parser SrcData typP = do FP.reserved "type" tyc <- tc <$> FP.lowerIdP tvars <- typArgs rvars <- commaList refVar inv <- refTop FP.reservedOp "=" >> FP.spaces ctors <- fmap (mkCtor tyc tvars rvars) <$> ctorsP return (Data tyc tvars rvars ctors inv) 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 <$> (FP.spaces *> 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 "=>" *> FP.brackets concReftB) <|> return Nothing mkCtor :: TyCon -> [Ident] -> [RVar] -> Ctor -> (SrcBind, RType) mkCtor tyc tvs rvs c = (dc, closeType rvs xts dcRes) where dcRes = TCon tyc (rVar <$> tvs) (rVarARef <$> rvs) dcReft Ctor dc xts r = c dcReft = Mb.fromMaybe mempty r closeType :: [RVar] -> [(F.Symbol, RType)] -> RType -> RType closeType rvs xts = tyParams . rvarParams . valParams where tyParams = generalize rvarParams t = foldr TRAll t rvs valParams ty = foldr (\(x, t) s -> TFun x t s) ty xts rVarARef :: RVar -> RARef rVarARef (RVar p ts) = ARef xts (predReft pred) where xts = zipWith (\t i -> (F.intSymbol "rvTmp" i, t)) ts [0..] pred = F.eApps (F.expr p) (F.expr . fst <$> xts) commaList :: FP.Parser a -> FP.Parser [a] commaList p = try (FP.parens (sepBy p FP.comma)) <|> return [] quals :: FP.Parser [F.Qualifier] quals = try ((:) <$> between annL annR qual <*> quals) <|> pure [] qual ::FP.Parser F.Qualifier qual = FP.reserved "qualif" >> FP.qualifierP (rTypeSort <$> rtype) expr :: FP.Parser SrcExpr expr = try funExpr <|> try letExpr <|> try ifExpr <|> try switchExpr <|> 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) switchExpr :: FP.Parser SrcExpr switchExpr = withSpan' $ do FP.reserved "switch" x <- FP.parens FP.lowerIdP alts <- FP.braces (many altP) return (ECase x alts) altP :: FP.Parser SrcAlt altP = withSpan' $ Alt <$> (FP.spaces *> mid *> FP.upperIdP) <*> 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 = (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 "=>" -- _ <- FP.reservedOp "{" body <- FP.braces (expr <* FP.spaces) -- _ <- 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 = do sig <- try (Just <$> ann) <|> pure Nothing decl <- plainDecl case sig of Just (a, s) -> return (mkDecl a s decl) Nothing -> return decl ann :: FP.Parser (Ann, Sig) ann = annL >> (((Val,) <$> sigP "val") <|> ((Refl,) <$> sigP "reflect")) annL, annR :: FP.Parser () annL = FP.reservedOp "/*@" annR = FP.reservedOp "*/" sigP :: String -> FP.Parser Sig sigP kw = do FP.reserved kw x <- identifier FP.colon t <- rtype m <- try (Just <$> metricP) <|> pure Nothing annR return (x, t, m) metricP :: FP.Parser Metric metricP = reserved "/" *> sepBy myExprP FP.comma tyBindP :: String -> FP.Parser (F.Symbol, RType) tyBindP kw = do (x, t, _) <- sigP kw return (x, t) genSig :: Sig -> Sig genSig (x, t, y) = (x, generalize t, y) sigId :: Sig -> Ident sigId (x, _, _) = x mkDecl :: Ann -> Sig -> SrcDecl -> SrcDecl mkDecl a s (Let b e l) | sigId s == bindId b = Let b (EAnn e a (genSig s) (label e)) l mkDecl a s (Rec b e l) | sigId s == bindId b = Rec b (EAnn e a (genSig s) (label e)) l mkDecl _ s d | otherwise = error $ "bad annotation: " ++ show (sigId s, bindId (declBind d)) plainDecl :: FP.Parser SrcDecl plainDecl = withSpan' $ do ctor <- (FP.reserved "let rec" >> pure Rec) <|> (FP.reserved "let" >> pure Let) 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 = (FP.reserved "forall" >> rall) <|> try rfun <|> rtype0 rtype0 :: FP.Parser RType rtype0 = FP.parens rtype <|> rbase rfun :: FP.Parser RType rfun = mkTFun <$> funArgP <*> (FP.reservedOp "=>" *> rtype) rall :: FP.Parser RType rall = TRAll <$> FP.parens refVar <*> (FP.dot *> rtype) refVar :: FP.Parser RVar refVar = mkRVar <$> FP.lowerIdP <*> (FP.colon *> rtype) mkRVar :: F.Symbol -> RType -> RVar mkRVar p t | isBool out = RVar p [ const () <$> s | (_, s) <- xs ] | otherwise = error "Refinement variable must have `bool` as output type" where (xs, out) = bkFun t isBool :: RType -> Bool isBool t = rTypeSort t == F.boolSort funArgP :: FP.Parser FunArg funArgP = 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 = try (TBase <$> tbase <*> refTop) <|> (TCon . tc <$> identifier') <*> commaList rtype <*> tConARefs <*> refTop tbase :: FP.Parser Base tbase = (FP.reserved "int" >> pure TInt) <|> (FP.reserved "bool" >> pure TBool) <|> (tvarP >>= return . TVar. TV) tConARefs :: FP.Parser [RARef] tConARefs = try (commaList aRef) <|> pure [] tvarP :: FP.Parser F.Symbol tvarP = FP.reservedOp "'" >> FP.lowerIdP refTop :: FP.Parser Reft refTop = FP.brackets reftB <|> pure mempty reftB :: FP.Parser Reft reftB = (question >> pure Unknown) <|> concReftB concReftB :: FP.Parser Reft concReftB = KReft <$> (FP.lowerIdP <* mid) <*> myPredP aRef :: FP.Parser (ARef Reft) aRef = ARef <$> commaList aRefArg <* FP.reservedOp "=>" <*> aRefBody where aRefArg :: FP.Parser (F.Symbol, RSort) aRefArg = (,) <$> FP.lowerIdP <* FP.colon <*> rSortP aRefBody :: FP.Parser Reft aRefBody = predReft <$> myPredP predReft :: F.Pred -> Reft predReft = Known F.dummySymbol . H.Reft rSortP :: FP.Parser RSort rSortP = rTypeToRSort <$> rtype0 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)) ================================================ FILE: src/Language/Sprite/L8/Prims.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Language.Sprite.L8.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.L8.Types import Language.Sprite.L8.Parse -- | "Prelude" Environment -------------------------------------------- prelude :: [(F.Symbol, RType)] prelude = [ ("diverge" , mkTy "x:int => 'a") , ("impossible", mkTy "x:int[v|false] => 'a") , ("Set_empty" , mkTy "x:int => 'a") , ("Set_add" , mkTy "s:Set_Set('a) => x:'a => Set_Set('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 (TRAll p t) = TRAll p (rebind t) rebind (TCon c ts ps r) = TCon c (rebind <$> ts) ps 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/L8/Reflect.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Language.Sprite.L8.Reflect (reflectData, reflect) where import Control.Monad (void) import qualified Data.HashMap.Strict as M 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 Language.Sprite.Common (eq) import Language.Sprite.L8.Types import Language.Sprite.L8.Constraints -- import Debug.Trace (trace) --------------------------------------------------------------------------------- reflectData :: SrcData -> F.DataDecl --------------------------------------------------------------------------------- reflectData (Data tc as _ ctors _) = F.DDecl (fTyCon tc) (length as) fCtors where tvM = zipWith (\a i -> (a, F.FVar i)) as [0..] fCtors = reflectCtor tvM <$> ctors type TvSub = [(Ident, F.Sort)] reflectCtor :: TvSub -> (SrcBind, RType) -> F.DataCtor reflectCtor tvM (Bind dc sp, s) = F.DCtor fDc fFields where fDc = F.atLoc sp dc fFields = zipWith mkFld fldTs [0..] fldTs = fmap snd . fsParams . funSig $ s mkFld t i = F.DField (fldName i) (fldSort t) fldName i = F.atLoc sp (selDataCon dc i) fldSort = F.sortSubst tvSub . rTypeSort tvSub = F.mkSortSubst tvM --------------------------------------------------------------------------------- -- | Reflection ----------------------------------------------------------------- --------------------------------------------------------------------------------- reflect :: Ident -> SrcExpr -> RType -> CG RType reflect f e s = do v <- freshValueSym reflectTy f v e s reflectTy :: F.Symbol -> F.Symbol -> SrcExpr -> RType -> CG RType reflectTy f v e0 s0 = go [] e0 s0 where go xs (ETLam _ e _) (TAll a t) = do TAll a <$> go xs e t go xs (EFun b e _) (TFun x s t) = do let x' = bindId b let s' = subst s x x' let t' = subst t x x' TFun x' s' <$> go ((x', rTypeSort s') : xs) e t' go xs e t = do let body = embed e let rbody = Known v (H.Reft (eq v body)) addReflectVar f s0 (reverse xs) (rTypeSort t) body pure (strengthenTop t rbody) --------------------------------------------------------------------------------- embed :: SrcExpr -> F.Expr --------------------------------------------------------------------------------- embed = go where go (EImm i _) = embedImm i go e@(EApp {}) = embedApp e go (ELet d e _) = F.subst1 (go e) (goD d) go (EIf i e1 e2 _) = F.EIte (embedImm i) (go e1) (go e2) go (ETLam _ e _) = go e go (ETApp e t _) = go e -- F.ETApp (go e) (rTypeSort t) go (ECase x as _) = embedAlts x as go e = error ("embed: not handled" ++ show (void e)) goD (Let b e1 _) = (bindId b, go e1) ------------------------------------------------------------------------------- -- | Applications ------------------------------------------------------------- ------------------------------------------------------------------------------- embedApp :: SrcExpr -> F.Expr embedApp e = case f of EImm (ECon (PBin o) _) _ -> embedPrim o args' _ -> F.eApps (embed f) args' where ((f, _), args) = {- Misc.traceShow "bkApp" $ -} bkApp e args' = embedImm <$> args bkApp :: SrcExpr -> ((SrcExpr, [RType]), [SrcImm]) bkApp = go [] where go vArgs (EApp f e _) = go (e:vArgs) f go vArgs e = (goT [] e, vArgs) goT tArgs (ETApp f t _) = goT (t:tArgs) f goT tArgs e = (e, tArgs) ------------------------------------------------------------------------------- -- | Primitives --------------------------------------------------------------- ------------------------------------------------------------------------------- embedPrim :: PrimOp -> [F.Expr] -> F.Expr embedPrim BPlus [e1, e2] = F.EBin F.Plus e1 e2 embedPrim BMinus [e1, e2] = F.EBin F.Minus e1 e2 embedPrim BTimes [e1, e2] = F.EBin F.Times e1 e2 embedPrim BLt [e1, e2] = F.PAtom F.Lt e1 e2 embedPrim BLe [e1, e2] = F.PAtom F.Le e1 e2 embedPrim BEq [e1, e2] = F.PAtom F.Eq e1 e2 embedPrim BGt [e1, e2] = F.PAtom F.Gt e1 e2 embedPrim BGe [e1, e2] = F.PAtom F.Ge e1 e2 embedPrim BAnd es = F.PAnd es embedPrim BOr es = F.POr es embedPrim BNot [e] = F.PNot e embedPrim o es = error $ "embedPrim: cannot handle" ++ show (o, es) embedImm :: SrcImm -> F.Expr embedImm (EVar x _) = F.expr x embedImm (ECon (PInt n) _) = F.expr n embedImm (ECon (PBool b) _) = F.expr b embedImm i = error ("embedImm: " ++ show i) instance F.Expression Bool where expr True = F.PTrue expr False = F.PFalse ------------------------------------------------------------------------------- -- | Data types --------------------------------------------------------------- ------------------------------------------------------------------------------- embedAlts :: Ident -> [SrcAlt] -> F.Expr embedAlts x as = go as where go [a] = embedAlt x a go (a:as) = F.EIte (isAlt a x) (embedAlt x a) (go as) isAlt :: SrcAlt -> Ident -> F.Expr isAlt a x = mkEApp (isDataCon (altDaCon a)) x embedAlt :: Ident -> SrcAlt -> F.Expr embedAlt x a@(Alt d ys e _) = F.subst su (embed e) where su = F.mkSubst $ zipWith sub ys [0..] sub y i = (bindId y, mkEApp (selDataCon d i) x) yis = zipWith mkEApp :: F.Symbol -> F.Symbol -> F.Expr mkEApp f xs = F.eApps (F.expr f) [F.expr xs] isDataCon :: DaCon -> F.Symbol isDataCon = F.testSymbol selDataCon :: DaCon -> Int -> F.Symbol selDataCon d i = F.intSymbol d i ================================================ FILE: src/Language/Sprite/L8/Types.hs ================================================ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Language.Sprite.L8.Types where import qualified Language.Fixpoint.Misc as Misc import qualified Language.Fixpoint.Horn.Types as H import qualified Language.Fixpoint.Horn.Transformations as H import qualified Language.Fixpoint.Types as F import qualified Language.Sprite.Common.UX as UX import Language.Sprite.Common ( Label(..) ) import qualified Data.Set as S import qualified Data.List as L import qualified Data.Char as Char -- | 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 -- | Refinement Variables ----------------------------------------------------- data RVar = RVar { rvName :: F.Symbol , rvArgs :: ![RSort] } deriving (Eq, Show) -- | Abstract Refinements ----------------------------------------------------- data ARef r = ARef { arArgs :: ![(F.Symbol, RSort)] , arPred :: r } deriving (Eq, Show, Functor) -- | 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] ![ARef r] r -- ^ C t1...tn p1...pm | TRAll !RVar !(Type r) -- ^ rall r. t deriving (Eq, Show, Functor) 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 :: F.Symbol -> F.Expr -> Reft pattern KReft v p = Known v (H.Reft p) isBase :: RType -> Bool isBase (TBase {}) = True isBase (TCon {}) = True isBase _ = False 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 -- | Proper refinement Types -------------------------------------------------- type RType = Type Reft type RARef = ARef Reft -- | Sorts: types decorated with unit refinements ----------------------------- type RSort = Type () -- | 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 -- | Names of TyCon ------------------------------------------------------------- newtype TyCon = TC F.Symbol -- ^ Type constructors deriving (Eq, Ord, Show) instance F.Symbolic TyCon where symbol (TC s) = s tc :: F.Symbol -> TyCon tc = TC . upperSym where upperSym s | isUpperSym s = s | otherwise = F.mappendSym "T" s isUpperSym s = case F.symbolString s of [] -> False (c:_) -> Char.isUpper c -- | "Immediate" terms (can appear as function args & in refinements) ----------- data Imm a = EVar !Ident a | ECon !Prim a deriving (Show, Functor) -- | Termination Metric ---------------------------------------------------------- type Metric = [F.Expr] -- ^ lexic.sequence of int-refinements -- | Variable definition --------------------------------------------------------- data Decl a = Let (Bind a) (Expr a) a -- ^ plain "let" | Rec (Bind a) (Expr a) a -- ^ recursive "let rec" deriving (Show, Functor) declBind :: Decl a -> Bind a declBind (Let b _ _) = b declBind (Rec b _ _) = b -- | 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) -- | Signatures ------------------------------------------------------------------ type Sig = (F.Symbol, RType, Maybe Metric) data Ann = Val | Refl deriving (Show) -- | 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) !Ann !Sig 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) | ERApp !(Expr a) a -- ^ e [?] (reft 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 (ERApp _ l) = l label (ECase _ _ l) = l instance Label Decl where label (Let _ _ l) = l label (Rec _ _ 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 :: !TyCon -- ^ name of the datatype , dcVars :: ![Ident] -- ^ type variables , dcRVars :: ![RVar] -- ^ refinement variables , dcCtors :: ![(Bind a, RType)] -- ^ constructors , dcInv :: !Reft -- ^ data invariant } 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 ARef where instance F.Subable r => F.Subable (ARef r) where syms (ARef _ p) = F.syms p substa f (ARef xts p) = ARef xts (F.substa f p) substf f (ARef xts p) = ARef xts (F.substf f p) subst f (ARef xts p) = ARef xts (F.subst f p) 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 (TRAll _ t) = F.syms t syms (TFun _ s t) = F.syms s ++ F.syms t syms (TCon _ ts ps r) = concatMap F.syms ts ++ concatMap F.syms ps ++ 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 (TRAll p t) = TRAll p (F.substa f t) substa f (TCon c ts ps r) = TCon c (F.substa f <$> ts) (F.substa f <$> ps) (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 (TRAll p t) = TRAll p (F.substf f t) substf f (TCon c ts ps r) = TCon c (F.substf f <$> ts) (F.substf f <$> ps) (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 (TRAll p t) = TRAll p (F.subst f t) subst f (TCon c ts ps r) = TCon c (F.subst f <$> ts) (F.subst f <$> ps) (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 ()) substs :: (F.Subable a) => a -> [(F.Symbol, F.Symbol)] -> a substs thing xys = L.foldl' (\t (x, y) -> subst t x y) thing xys 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" -------------------------------------------------------------------------------- -- | Normalizing types by generalizing tyvars, refactoring ref-var applications -------------------------------------------------------------------------------- generalize :: RType -> RType generalize = refactorApp . generalizeTVar -------------------------------------------------------------------------------- -- | Substituting 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 (TRAll p t) = TRAll (goP p) (go t) go (TFun x s1 s2) = TFun x (go s1) (go s2) go (TBase b r) = bsubst a t b r go (TCon c ts ps r) = TCon c (go <$> ts) (goA <$> ps) r goP p = p { rvArgs = [ asRType go t | t <- rvArgs p ] } goA a = a { arArgs = [ (x, asRType go t) | (x, t) <- arArgs a ] } 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 strengthenTop t@(TAll {}) _ = t strengthenTop t@(TRAll {}) _ = t strengthenTop (TBase b r) r' = TBase b (r <> r') strengthenTop (TCon c ts ps r) r' = TCon c ts ps (r <> r') generalizeTVar :: RType -> RType generalizeTVar t = foldr TAll t (freeTVars t) freeTVars :: Type a -> [TVar] freeTVars = Misc.sortNub . S.toList . go where goP = S.fromList . concatMap freeTVars . rvArgs go (TAll a t) = S.delete a (go t) go (TRAll p t) = S.union (goP p) (go t) go (TFun _ s t) = S.union (go s) (go t) go (TCon _ ts _ _) = S.unions ((go <$> ts)) go (TBase b _) = goB b goB (TVar a) = S.singleton a goB _ = S.empty ------------------------------------------------------------------------------- -- | Types and Sorts ------------------------------------------------------------------------------- baseSort :: Base -> F.Sort baseSort TInt = F.intSort baseSort TBool = F.boolSort baseSort (TVar a) = F.FObj (F.symbol a) rTypeSort :: RType -> F.Sort rTypeSort (TBase b _) = baseSort b rTypeSort (TCon c ts _ _) = F.fAppTC (fTyCon c) (rTypeSort <$> ts) rTypeSort t@(TFun {}) = rTypeSortFun t rTypeSort t@(TAll {}) = rTypeSortAll t rTypeSort (TRAll _ t) = rTypeSort t rTypeSortFun :: RType -> F.Sort rTypeSortFun = F.mkFFunc 0 . fmap rTypeSort . go [] where go ts (TFun _ t1 t2) = go (t1:ts) t2 go ts t = reverse (t:ts) rTypeSortAll :: RType -> F.Sort rTypeSortAll s = genSort (rTypeSort t) where genSort t = L.foldl' (flip F.FAbs) (F.sortSubst su t) [0..n-1] (as, t) = bkAll s su = F.mkSortSubst $ zip sas (F.FVar <$> [0..]) sas = F.symbol <$> as n = length as bkAll :: RType -> ([TVar], RType) bkAll (TAll a s) = (a:as, t) where (as, t) = bkAll s bkAll t = ([] , t) bkRAll :: RType -> ([RVar], RType) bkRAll (TRAll p s) = (p:ps, t) where (ps, t) = bkRAll s bkRAll t = ([] , t) fTyCon :: TyCon -> F.FTycon fTyCon = F.symbolFTycon . F.dummyLoc . F.symbol data FunSig = FunSig { fsTVars :: [TVar] -- ^ type variables , fsRVars :: [RVar] -- ^ refinement variables , fsParams :: [(Ident, RType)] -- ^ input binders , fsOut :: RType -- ^ output type } funSig :: RType -> FunSig funSig t = FunSig as rs xts ot where (as, rs, t') = bkAlls t (xts, ot) = bkFun t' bkFun :: RType -> ([(F.Symbol, RType)], RType) bkFun (TFun x s t) = ((x, s) : ins, out) where (ins, out) = bkFun t bkFun out = ([] , out) -- | See [NOTE:RefactorApp] --------------------------------------------------- refactorApp :: RType -> RType refactorApp s = tAlls as ps (refactorAppR isRV <$> t) where (as,ps,t) = bkAlls s pvs = S.fromList (rvName <$> ps) isRV p = S.member p pvs tAlls :: [TVar] -> [RVar] -> RType -> RType tAlls as ps = tAll as . tRAll ps tAll :: [TVar] -> Type a -> Type a tAll as t = foldr TAll t as tRAll :: [RVar] -> Type a -> Type a tRAll ps t = foldr TRAll t ps bkAlls :: RType -> ([TVar], [RVar], RType) bkAlls s = (as, ps, t) where (as, s') = bkAll s (ps, t) = bkRAll s' refactorAppR :: (F.Symbol -> Bool) -> Reft -> Reft refactorAppR isRV (Known v p) = Known v (refactorAppP isRV p) refactorAppR _ r = r -- | See [NOTE:RefactorApp] --------------------------------------------------- refactorAppP :: (F.Symbol -> Bool) -> H.Pred -> H.Pred refactorAppP isRV p = H.PAnd (H.Reft (F.pAnd fs) : rs) where es = predExprs p (rs, fs) = Misc.mapEither (isRVarApp isRV) es isRVarApp :: (F.Symbol -> Bool) -> F.Expr -> Either H.Pred F.Expr isRVarApp isRV e@(F.EApp {}) | (F.EVar k, args) <- F.splitEApp e , isRV k = Left (H.Var k (rvarArgSymbol msg <$> args)) where msg = F.showpp e isRVarApp _ e = Right e rvarArgSymbol :: String -> F.Expr -> F.Symbol rvarArgSymbol _ (F.EVar x) = x rvarArgSymbol msg e = error $ "Unexpected argument in ref-variable: " ++ msg ++ " " ++ show e predExprs :: H.Pred -> [F.Expr] predExprs p = case H.flatten p of H.PAnd ps -> concatMap go ps q -> go q where go (H.Reft e) = F.conjuncts e go _ = error "unexpected H.Pred in predExprs" {- | [NOTE:RefactorApp] The parser cannot distinguish between * plain applications (f x y z) and * ref-var applications (p x y z) using `H.Var !F.Symbol ![F.Symbol] -- ^ $k(y1..yn)` So, post-parsing, we traverse the refinements with an `isRV` test to pull the ref-var applications out. -} asRType :: (RType -> RType) -> RSort -> RSort asRType f = rTypeToRSort . f . rSortToRType rTypeToRSort :: RType -> RSort rTypeToRSort = fmap (const ()) rSortToRType :: RSort -> RType rSortToRType = fmap (const mempty) rSortToFSort :: RSort -> F.Sort rSortToFSort = rTypeSort . rSortToRType rVarARef :: RVar -> RARef rVarARef (RVar p ts) = ARef xts (Known F.dummySymbol pred) where xts = zipWith (\t i -> (F.intSymbol "kvTmp" i, t)) ts [0..] pred = H.Var p (fst <$> xts) ------------------------------------------------------------------------------- -- | Substituting Refinement Variables ----------------------------------------------- ------------------------------------------------------------------------------- class SubsARef a where subsAR :: F.Symbol -> RARef -> a -> a instance SubsARef H.Pred where subsAR p (ARef yts (Known _ pr)) = go where go (H.Var k xs) | k == p = substs pr (zipWith (\(y,_) x -> (y, x)) yts xs) go (H.PAnd ps ) = H.PAnd (go <$> ps) go pred = pred instance SubsARef Reft where subsAR p ar (Known v pr) = Known v (subsAR p ar pr) subsAR p ar r = r instance SubsARef RType where subsAR p ar t = subsAR p ar <$> t rsubsts :: (SubsARef a) => [(RVar, RARef)] -> a -> a rsubsts rps z = L.foldl' (\x (p, ar) -> rsubst1 p ar x) z rps rsubst1 :: (SubsARef a) => RVar -> RARef -> a -> a rsubst1 (RVar p _) ar z = subsAR p ar z ================================================ FILE: src/Language/Sprite/L8.hs ================================================ module Language.Sprite.L8 ( sprite ) where import System.Exit import qualified Language.Fixpoint.Types as F import Language.Sprite.L8.Check import Language.Sprite.L8.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 -> checkValidPLE f vc ec <- resultExit res exitWith ec ================================================ FILE: stack.yaml ================================================ resolver: nightly-2024-01-26 packages: - '.' extra-deps: - store-0.7.18@sha256:af32079e0d31413b97a1759f8ad8555507857cd4ac4015e195fb5b0a27a3ce9f,8159 - store-core-0.4.4.7@sha256:a2ea427ff0dde30252474dcb0641cb6928cb8a93cd5ee27d4c22adba8e729683,1489 - rest-rewrite-0.4.3 - smtlib-backends-0.3@rev:2 - smtlib-backends-process-0.3@rev:2 - git: https://github.com/ucsd-progsys/liquid-fixpoint commit: 794aed1388442e64ced07a7f53c5aba14ce01a24 allow-newer: true ================================================ FILE: stack.yaml.github ================================================ # resolver: lts-13.20 resolver: lts-16.10 packages: - '.' extra-deps: - intern-0.9.2 - located-base-0.1.1.1 - text-format-0.3.2 - tasty-rerun-1.1.14 - git: https://github.com/ucsd-progsys/liquid-fixpoint commit: 5501659ccb6dbbd53a859cdda8e4a76d62fc31df compiler: ghc-8.10.2 allow-newer: true ================================================ FILE: test/L1/neg/inc00.re ================================================ /*@ val inc: x:int => int[v|v = x + 1] */ let inc = (x) => { x - 1 }; let bar = inc(10); ================================================ FILE: test/L1/neg/inc01.re ================================================ /*@ val inc: x:int[v|0<=v] => int[v|0<=v] */ let inc = (x) => { x + 1 }; /*@ val dec : x:int => int[v | v == x - 1] */ let dec = (x) => { x - 1 }; /*@ val inc2: x:int[v|0<=v] => int[v|0<=v] */ let inc2 = (x) => { let tmp = inc(x); dec(tmp) }; ================================================ FILE: test/L1/neg/inc02.re ================================================ /*@ val dec : x:int => int[v|v==x-1] */ let dec = (x) => { x - 1 }; /*@ val incf: x:int[v|0<=v] => int[v|0<=v] */ let incf = (x) => { /*@ val tmp : f:(int[v|0<=v] => int[v|0<=v]) => int[v|0<=v] */ let tmp = (f) => { f(x) }; tmp(dec) }; ================================================ FILE: test/L1/neg/int01.re ================================================ let v1 = 1; let v2 = 2; /*@ val top : int[v|v = 30] */ let top = v1 + v2; ================================================ FILE: test/L1/pos/inc00.re ================================================ /*@ val inc: x:int => int[v|v = x + 1] */ let inc = (x) => { x + 1 }; let bar = inc(10); ================================================ FILE: test/L1/pos/inc01.re ================================================ /*@ val inc: x:int => int[v | v == x + 1] */ let inc = (x) => { x + 1 }; /*@ val inc2: x:int[v|0<=v] => int[v|0<=v] */ let inc2 = (x) => { let tmp = inc(x); inc(tmp) }; ================================================ FILE: test/L1/pos/inc02.re ================================================ /*@ val inc: x:int => int[v|v=x+1] */ let inc = (x) => { x + 1 }; /*@ val incf: x:int[v|0<=v] => int[v|0<=v] */ let incf = (x) => { /*@ val tmp : f:(int[v|0<=v] => int[v|0<=v]) => int[v|0<=v] */ let tmp = (f) => { f(x) }; tmp(inc) }; ================================================ FILE: test/L1/pos/int00.re ================================================ let v1 = 1; let v2 = 2; let top = v1 + v2; ================================================ FILE: test/L1/pos/int01.re ================================================ let v1 = 1; let v2 = 2; /*@ val top : int[v|v = 3] */ let top = v1 + v2; ================================================ FILE: test/L2/neg/abs00.re ================================================ /*@ val abs : x:int => int[v|0<=v] */ let abs = (x) => { let pos = x >= 0; if (pos) { 0 - x } else { x } }; ================================================ FILE: test/L2/neg/abs01.re ================================================ /*@ val abs : x:int => int[v| 0<=v] */ let abs = (x) => { let pos = x >= 0; if (pos) { 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 }; ================================================ FILE: test/L2/neg/cmp00.re ================================================ /*@ val cmp : x:int => bool[b|b <=> (x < 0)] */ let cmp = (x) => { let cond = x < 10; if (cond) { true } else { false } }; ================================================ FILE: test/L2/neg/cmp01.re ================================================ /*@ val cmp : x:int => y:int => bool[b|b <=> (x < y)] */ let cmp = (x, y) => { let cond = x > y; if (cond) { true } else { false } }; ================================================ FILE: test/L2/neg/sum00.re ================================================ /*@ val sum : n:int => int[v|0 <= v && n <= v] */ let rec sum = (n) => { let cond = n <= 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); t1 } }; ================================================ FILE: test/L2/pos/abs00.re ================================================ /*@ val abs : x:int => int[v|0<=v] */ let abs = (x) => { let pos = x >= 0; if (pos) { x } else { 0 - x } }; ================================================ FILE: test/L2/pos/abs01.re ================================================ /*@ val abs : x:int => int[v| 0<=v && x <= v] */ let abs = (x) => { let pos = x >= 0; if (pos) { 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 }; ================================================ FILE: test/L2/pos/cmp00.re ================================================ /*@ val cmp : x:int => bool[b|b <=> (x < 10)] */ let cmp = (x) => { let cond = x < 10; if (cond) { true } else { false } }; ================================================ FILE: test/L2/pos/cmp01.re ================================================ /*@ val cmp : x:int => y:int => bool[b|b <=> (x < y)] */ let cmp = (x, y) => { let cond = x < y; if (cond) { true } else { false } }; ================================================ FILE: test/L2/pos/sum00.re ================================================ /*@ val sum : n:int => int[v|0 <= v && n <= v] */ let rec sum = (n) => { let cond = n <= 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); n + t1 } }; ================================================ FILE: test/L3/neg/abs01.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val abs : x:int => int[?] */ let abs = (x) => { let pos = x >= 0; if (pos) { x } else { 0 - x } }; /*@ val main : int => int */ let main = (y) => { let fails = 0 <= y; cassert(fails) }; ================================================ FILE: test/L3/neg/abs02-bad.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val abs : x:int => int[?] */ let abs = (x) => { let pos = x >= 0; if (pos) { x } else { 0 - x } }; /* SAFE : val wrap : (int => int[v|v>=0]) => int[?] */ /* UNSAFE : val wrap : (int => int[?]) => int[?] */ /*@ val incf: int => int */ let incf = (z) => { /*@ val wrap : (int => int[v|v>=0]) => int[?] */ let wrap = (f) => { let r = f(z); r + 1 }; let res = wrap(abs); let ok = 6660 <= res; cassert (ok) }; ================================================ FILE: test/L3/neg/abs02.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val abs : x:int => int[?] */ let abs = (x) => { let pos = 0 <= x; if (pos) { x } else { 0 - x } }; /*@ val incf: int => int */ let incf = (x) => { /*@ val wrap : (int => int[?]) => int[?] */ let wrap = (f) => { let r = f(x); r }; let res = wrap(abs); let ok = 0 < res; cassert (ok) }; ================================================ FILE: test/L3/neg/assert00.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val main : int => int */ let main = (x) => { let x1 = x - 1; let cond = x < x1; cassert(cond) }; ================================================ FILE: test/L3/neg/rebind.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val check : int => int */ let check = (y) => { let y1 = y-1; let ok = y <= y1; cassert(ok) }; ================================================ FILE: test/L3/neg/sum01.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val sum : n:int => int[?] */ let rec sum = (n) => { let cond = n <= 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); n + t1 } }; /*@ val check2 : int => int */ let check2 = (y) => { let y1 = y-1; let res = sum(y1); let ok = y <= res; cassert(ok) }; ================================================ FILE: test/L3/pos/abs01.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val abs : x:int => int[?] */ let abs = (x) => { let pos = x >= 0; if (pos) { x } else { 0 - x } }; /*@ val main : int => int */ let main = (y) => { let ya = abs(y); let ok = 0 <= ya; cassert(ok) }; ================================================ FILE: test/L3/pos/abs02-debug.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val abs : x:int => int[v1|v1>=0] */ let abs = (x) => { 10 }; /*@ val incf: int => int */ let incf = (z) => { /*@ val wrap : (y:int => int[?]) => int[v2|v2>=0] */ let wrap = (f) => { let r = f(z); r }; wrap(abs) }; ================================================ FILE: test/L3/pos/abs02.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val abs : x:int => int[?] */ let abs = (x) => { let pos = x >= 0; if (pos) { x } else { 0 - x } }; /*@ val incf: int => int */ let incf = (z) => { /*@ val wrap : (int => int[?]) => int[?] */ let wrap = (f) => { let r = f(z); r + 1 }; let res = wrap(abs); let ok = 0 <= res; cassert (ok) }; ================================================ FILE: test/L3/pos/assert00.re ================================================ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val main : int => int */ let main = (x) => { let x1 = x + 1; let cond = x < x1; cassert(cond) }; ================================================ FILE: test/L3/pos/sum01.re ================================================ /*@ qualif Pos(v:int): (0 <= v) */ /*@ qualif Geq(v:int, n:int): (n <= v) */ /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val sum : n:int => int[?] */ let rec sum = (n) => { let cond = n <= 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); n + t1 } }; /*@ val check1 : int => int */ let check1 = (y) => { let res = sum(y); let ok = 0 <= res; cassert(ok) }; /*@ val check2 : int => int */ let check2 = (y) => { let res = sum(y); let ok = y <= res; cassert(ok) }; ================================================ FILE: test/L4/neg/choose00.re ================================================ /*@ val choose : 'a => 'b => 'a */ let choose = (x, y) => { x }; /*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */ let check = (a, b) => { let aM = a - 1; let res = choose(aM, a); res }; ================================================ FILE: test/L4/neg/choose01.re ================================================ /*@ val choose : 'a => 'b => 'b */ let choose = (x, y) => { y }; /*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */ let check = (a, b) => { let aM = a - 1; let res = choose(a, aM); res }; ================================================ FILE: test/L4/neg/foldn00.re ================================================ /*@ val foldn : ('a => int => 'a) => 'a => int => int => 'a */ let rec foldn = (f, acc, i, n) => { let leq = i < n; if (leq) { let ip = i + 1; let accp = f (acc, i); foldn(f, accp, ip, n) } else { acc } }; /*@ val add : x:int => y:int => int[v|v = x + y] */ let add = (x, y) => { x + y }; /*@ val main : m:int[v|0<=v] => int[v|0<=v] */ let main = (m) => { foldn(add, 0, 0, m) }; ================================================ FILE: test/L4/neg/foldn01.re ================================================ // No quals! /*@ val foldn : ('a => int[?] => 'a) => 'a => i:int[?] => n:int[?] => 'a */ let rec foldn = (f, acc, i, n) => { let leq = i < n; if (leq) { let ip = i + 1; let accp = f (acc, i); foldn(f, accp, ip, n) } else { acc } }; /*@ val add : x:int => y:int => int[v|v = x + y] */ let add = (x, y) => { x + y }; /*@ val main : m:int[v|0<=v] => int[v|0<=v] */ let main = (m) => { foldn(add, 0, 0, m) }; ================================================ FILE: test/L4/neg/id00.re ================================================ /*@ val id : 'a => 'a */ let id = (x) => { x }; /*@ val check1 : x:int[v|0<=v] => int[v|0<=v] */ let check1 = (y) => { let y1 = y - 1; let res = id(y1); res }; ================================================ FILE: test/L4/pos/choose00.re ================================================ /*@ val choose : 'a => 'b => 'a */ let choose = (x, y) => { x }; /*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */ let check = (a, b) => { let aP = a + 1; let aM = a - 1; let res = choose(aP, aM); res }; ================================================ FILE: test/L4/pos/choose01.re ================================================ /*@ val choose : 'a => 'b => 'b */ let choose = (x, y) => { y }; /*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */ let check = (a, b) => { let aM = a - 1; let res = choose(aM, a); res }; ================================================ FILE: test/L4/pos/foldn00.re ================================================ /*@ qualif Pos(v:int): (0 <= v) */ /*@ val foldn : ('a => int[v|0<=v] => 'a) => 'a => i:int[v|0 <= v] => n:int[v|i<=v] => 'a */ let rec foldn = (f, acc, i, n) => { let leq = i < n; if (leq) { let ip = i + 1; let accp = f(acc, i); foldn(f, accp, ip, n) } else { acc } }; /*@ val add : x:int => y:int => int[v|v = x + y] */ let add = (x, y) => { x + y }; /*@ val main : m:int[v|0<=v] => int[v|0<=v] */ let main = (m) => { foldn(add, 0, 0, m) }; ================================================ FILE: test/L4/pos/foldn01.re ================================================ /*@ qualif Pos(v:int): (0 <= v) */ /*@ qualif Geq(v:int, n:int): (n <= v) */ /*@ val foldn : ('a => int[?] => 'a) => 'a => i:int[?] => n:int[?] => 'a */ let rec foldn = (f, acc, i, n) => { let leq = i < n; if (leq) { let ip = i + 1; let accp = f(acc, i); foldn(f, accp, ip, n) } else { acc } }; /*@ val add : x:int => y:int => int[v|v = x + y] */ let add = (x, y) => { x + y }; /* the zero is an ANF thing as fixpoint kvetches about non-symbol args for kvars sigh */ /*@ val main : m:int[v|0<=v] => int[v|0<=v] */ let main = (m) => { let zero = 0; foldn(add, zero, zero, m) }; ================================================ FILE: test/L4/pos/id00.re ================================================ /*@ val id : 'a => 'a */ let id = (x) => { x }; /*@ val check1 : x:int[v|0<=v] => int[v|0<=v] */ let check1 = (y) => { let res = id(y); res }; ================================================ FILE: test/L5/neg/append00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val append : xs:list('a) => ys:list('a) => list('a)[v|len v = len(xs) + len(ys)] */ let rec append = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => append(t, ys) } }; ================================================ FILE: test/L5/neg/cons00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val singleton : 'a => list('a)[v|len v = 10] */ let singleton = (x) => { let t = Nil; Cons(x, t) }; ================================================ FILE: test/L5/neg/head00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val singleton : 'a => list('a) */ let singleton = (x) => { let t = Nil; Cons(x, t) }; /*@ val head : list('a) => 'a */ let head = (xs) => { switch(xs){ | Cons(h,t) => h | Nil => diverge(0) } }; /*@ val check : x:int[v|0 <= v] => int[v|10 <= v] */ let check = (z) => { let l = singleton(z); head(l) }; ================================================ FILE: test/L5/neg/head01.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val head : list('a)[v|len v > 0] => 'a */ let head = (xs) => { switch(xs){ | Cons(h, t) => h | Nil => impossible(0) } }; /*@ val singleton : 'a => list('a)[v|len v = 1] */ let singleton = (x) => { let t = Nil; Cons(x, t) }; /*@ val check : x:int => int */ let check = (z) => { let l = Nil; head(l) }; ================================================ FILE: test/L5/neg/isort00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val insert : x:'a => ys:list('a) => list('a) */ let rec insert = (x, ys) => { switch (ys) { | Nil => let t = Nil; Cons(x, t) | Cons(y0, ys') => let cmp = x <= y0; if (cmp){ let tl = Cons(y0, ys'); Cons(x, tl) } else { let tl = insert(x, ys'); Cons(y0, tl) } } }; /*@ val isort : xs:list('a) => list('a)[v|len(v) = len(xs)] */ let rec isort = (xs) => { switch (xs){ | Nil => Nil | Cons (h, t) => let ot = isort(t); insert(h, ot) } }; ================================================ FILE: test/L5/neg/isort01.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x <= v])) ; /*@ val insert : x:'a => ys:olist('a) => olist('a) */ let rec insert = (x, ys) => { switch (ys) { | ONil => let t = ONil; OCons(x, t) | OCons(y0, ys') => let cmp = x > y0; if (cmp){ let tl = OCons(y0, ys'); OCons(x, tl) } else { let tl = insert(x, ys'); OCons(y0, tl) } } }; /*@ val isort : list('a) => olist('a) */ let rec isort = (xs) => { switch (xs){ | Nil => ONil | Cons (h, t) => let ot = isort(t); insert(h, ot) } }; ================================================ FILE: test/L5/neg/listSet.re ================================================ /*@ measure elts : list('a) => Set_Set('a) */ type list('a) = | Nil => [v| elts(v) = Set_empty(0)] | Cons (x:'a, xs:list('a)) => [v| elts(v) = Set_add(elts(xs), x)] ; /*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(xs))] */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L5/neg/nil00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val singleton : 'a => list('a)[v|len v = 1] */ let singleton = (x) => { let t = Nil; t }; ================================================ FILE: test/L5/neg/olist00.re ================================================ type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x < v])) ; /*@ val bar : apple:int => horse: olist(int) => olist(int) */ let bar = (apple, horse) => { OCons (apple, horse) }; ================================================ FILE: test/L5/neg/olist01.re ================================================ type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x < v])) ; /*@ val foo : n:int => olist(int) */ let foo = (n) => { let n0 = n + 1; let n1 = n; let l2 = ONil; let l1 = OCons(n1, l2); let l0 = OCons(n0, l1); l0 }; ================================================ FILE: test/L5/neg/olist02.re ================================================ type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x < v])) ; /*@ val mkOList : lo:int => hi:int => olist(int[v|lo <= v && v < hi]) */ let rec mkOList = (lo, hi) => { let leq = lo < hi; if (leq) { let lo' = lo + 1; let tl = mkOList(lo', hi); OCons(lo', tl) } else { ONil } }; ================================================ FILE: test/L5/neg/single00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val singleton : int => list(int[v|0 <= v]) */ let singleton = (x) => { let t = Nil; Cons(x, t) }; ================================================ FILE: test/L5/neg/tail01.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val tail: zs:list('a)[v|len v > 0] => list('a)[v|len v = len(zs) - 2] */ let tail = (zs) => { switch(zs){ | Cons(h, t) => t | Nil => impossible(0) } }; ================================================ FILE: test/L5/neg/tuple00.re ================================================ type coord = | C (x:int, y:int[v|x < v]) ; /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val mk : n:int => coord */ let mk = (n) => { let n1 = n + 1; C(n1, n1) }; /*@ val check : m:int => int */ let check = (m) => { let p = mk(m); switch (p){ | C(px, py) => let ok = px < py; cassert(ok) } }; ================================================ FILE: test/L5/pos/append00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val append : xs:list('a) => ys:list('a) => list('a)[v|len v = len(xs) + len(ys)] */ let rec append = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = append(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L5/pos/cons00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val singleton : 'a => list('a)[v|len v = 1] */ let singleton = (x) => { let t = Nil; Cons(x, t) }; ================================================ FILE: test/L5/pos/fold_right00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val fold_right : ('alice => 'bob => 'bob) => 'bob => list('alice) => 'bob */ let rec fold_right = (f, b, xs) => { switch (xs) { | Nil => b | Cons(h, t) => let res = fold_right(f, b, t); f(h, res) } }; ================================================ FILE: test/L5/pos/head00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val singleton : 'a => list('a) */ let singleton = (x) => { let t = Nil; Cons(x, t) }; /*@ val head : list('a) => 'a */ let head = (xs) => { switch(xs){ | Cons(h,t) => h | Nil => diverge(0) } }; /*@ val check : x:int[v|0 <= v] => int[v|0 <= v] */ let check = (z) => { let l = singleton(z); head(l) }; ================================================ FILE: test/L5/pos/head01.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val head : list('a)[v|len v > 0] => 'a */ let head = (xs) => { switch(xs){ | Cons(h, t) => h | Nil => impossible(0) } }; /*@ val singleton : 'a => list('a)[v|len v = 1] */ let singleton = (x) => { let t = Nil; Cons(x, t) }; /*@ val check : x:int => int */ let check = (z) => { let l = singleton(z); head(l) }; ================================================ FILE: test/L5/pos/isort00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val insert : x:'a => ys:list('a) => list('a)[v|len v = 1 + len(ys)] */ let rec insert = (x, ys) => { switch (ys) { | Nil => let t = Nil; Cons(x, t) | Cons(y0, ys') => let cmp = x <= y0; if (cmp){ let tl = Cons(y0, ys'); Cons(x, tl) } else { let tl = insert(x, ys'); Cons(y0, tl) } } }; /*@ val isort : xs:list('a) => list('a)[v|len(v) = len(xs)] */ let rec isort = (xs) => { switch (xs){ | Nil => Nil | Cons (h, t) => let ot = isort(t); insert(h, ot) } }; ================================================ FILE: test/L5/pos/isort01.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x <= v])) ; /*@ val insert : x:'a => ys:olist('a) => olist('a) */ let rec insert = (x, ys) => { switch (ys) { | ONil => let t = ONil; OCons(x, t) | OCons(y0, ys') => let cmp = x <= y0; if (cmp){ let tl = OCons(y0, ys'); OCons(x, tl) } else { let tl = insert(x, ys'); OCons(y0, tl) } } }; /*@ val isort : list('a) => olist('a) */ let rec isort = (xs) => { switch (xs){ | Nil => ONil | Cons (h, t) => let ot = isort(t); insert(h, ot) } }; ================================================ FILE: test/L5/pos/listSet.re ================================================ /*@ measure elts : list('a) => Set_Set('a) */ type list('a) = | Nil => [v| elts(v) = Set_empty(0)] | Cons (x:'a, xs:list('a)) => [v| elts(v) = Set_add(elts(xs), x)] ; /*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(ys))] */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L5/pos/nil00.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val emptylist : 'a => list('a)[v|len v = 0] */ let emptylist = (x) => { let t = Nil; t }; ================================================ FILE: test/L5/pos/olist00.re ================================================ type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x < v])) ; /*@ val bar : apple:int => horse: olist(int[v|apple < v]) => olist(int) */ let bar = (apple, horse) => { OCons(apple, horse) }; ================================================ FILE: test/L5/pos/olist01.re ================================================ type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x < v])) ; /*@ val foo : n:int => olist(int) */ let foo = (n) => { let n0 = n; let n1 = n0 + 1; let l2 = ONil; let l1 = OCons(n1, l2); let l0 = OCons(n0, l1); l0 }; ================================================ FILE: test/L5/pos/olist02.re ================================================ type olist('a) = | ONil | OCons (x:'a, xs:olist('a[v| x < v])) ; /*@ val mkOList : lo:int => hi:int => olist(int[v|lo <= v && v < hi]) */ let rec mkOList = (lo, hi) => { let leq = lo < hi; if (leq) { let lo' = lo + 1; let tl = mkOList(lo', hi); OCons(lo, tl) } else { ONil } }; ================================================ FILE: test/L5/pos/single00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val singleton : int[v|0 <= v] => list(int[v|0 <= v]) */ let singleton = (x) => { let t = Nil; Cons(x, t) }; ================================================ FILE: test/L5/pos/tail01.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val tail: zs:list('a)[v|len v > 0] => list('a)[v|len v = len(zs) - 1] */ let tail = (zs) => { switch(zs){ | Cons(h, t) => t | Nil => impossible(0) } }; ================================================ FILE: test/L5/pos/tuple00.re ================================================ type coord = | C (x:int, y:int[v|x < v]) ; /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val mk : n:int => coord */ let mk = (n) => { let n1 = n + 1; C(n, n1) }; /*@ val check : m:int => int */ let check = (m) => { let p = mk(m); switch (p){ | C(px, py) => let ok = px < py; cassert(ok) } }; ================================================ FILE: test/L6/neg/deptup00.re ================================================ type pair('a, 'b)(p : 'a => 'b => bool) = | MkPair(x:'a, y:'b[v|p x v]) ; /*@ val check2 : x:int => pair(int, int)((x1:int, x2:int) => x1 > x2) */ let check2 = (x) => { let y = x + 1; MkPair(x, y) }; ================================================ FILE: test/L6/neg/isort02.re ================================================ type list('a)(p : 'a => 'a => bool) = | Nil | Cons(x:'a, list('a[v|p x v])((x1:'a, x2:'a) => p x1 x2)) ; /*@ val insert : x:'a => ys:list('a)((u1:'a, u2:'a) => u1 <= u2) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ let rec insert = (x, ys) => { switch (ys) { | Nil => let t = Nil; Cons(x, t) | Cons(y0, ys') => let cmp = y0 <= x; if (cmp){ let tl = Cons(y0, ys'); Cons(x, tl) } else { let tl = insert(x, ys'); Cons(y0, tl) } } }; /*@ val isort : list('a)((u1:'a, u2:'a) => true) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ let rec isort = (xs) => { switch (xs){ | Nil => Nil | Cons (h, t) => let ot = isort(t); insert(h, ot) } }; ================================================ FILE: test/L6/neg/maxint1.re ================================================ /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val test1 : a:int[v|0 < v] => b:int[v|0 <= v] => int[v|0 < v] */ let test1 = (a, b) => { maxInt(a, b) }; ================================================ FILE: test/L6/neg/maxint2.re ================================================ /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val test2 : a:int[v|v < 0] => b:int[v|v <= 0] => int[v|v < 0] */ let test2 = (a, b) => { maxInt(a, b) }; ================================================ FILE: test/L6/neg/maxlist.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */ let rec fold_right = (f, b, xs) => { switch (xs) { | Nil => b | Cons(h, t) => let res = fold_right(f, b, t); f(h, res) } }; /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val maxInts : forall (quxx: int => bool). list(int[v| quxx v]) => int[v| quxx v] */ let maxInts = (xs) => { switch (xs){ | Cons(h, t) => let maxInt_inst = maxInt; fold_right(maxInt_inst, h, t) | Nil => diverge(0) } }; /*@ val maxPoss : list(int[v|0 <= v]) => int[v|0 < v] */ let maxPoss = (xs) => { maxInts(xs) }; /*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ let maxNegs = (xs) => { maxInts(xs) }; ================================================ FILE: test/L6/neg/maxlist00_1.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /* val maxInts : forall (p : int => bool). int[v| p v] => list(int[v| p v]) => int[v| p v] */ /*@ val maxInts : int => list(int) => int */ let rec maxInts = (cur, xs) => { switch (xs) { | Cons(h, t) => let newCur = maxInt(cur, h); maxInts(newCur, t) | Nil => (cur) } }; /*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ let maxPoss = (xs) => { maxInts(0, xs) }; ================================================ FILE: test/L6/neg/maxlist00_2.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /* val maxInts : forall (p : int => bool). int[v| p v] => list(int[v| p v]) => int[v| p v] */ /*@ val maxInts : int => list(int) => int */ let rec maxInts = (cur, xs) => { switch (xs) { | Cons(h, t) => let newCur = maxInt(cur, h); maxInts(newCur, t) | Nil => (cur) } }; /*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ let maxNegs = (xs) => { maxInts(0, xs) }; ================================================ FILE: test/L6/neg/maxlist01.re ================================================ /*@ qualif Geq(v:int, n:int): (n <= v) */ /*@ qualif AbsPred(v:int, f:int => bool): (f v) */ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */ let rec fold_right = (f, b, xs) => { switch (xs) { | Nil => b | Cons(h, t) => let res = fold_right(f, b, t); f(h, res) } }; /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val maxInts : forall (quxx: int => bool). list(int[v| quxx v]) => int[v| quxx v] */ let maxInts = (xs) => { switch (xs){ | Cons(h, t) => let maxInt_inst = maxInt; fold_right(maxInt_inst, h, t) | Nil => diverge(0) } }; /*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ let maxPoss = (xs) => { maxInts(xs) }; /*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ let maxNegs = (xs) => { maxInts(xs) }; ================================================ FILE: test/L6/pos/apply00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */ let rec fold_right = (f, b, xs) => { switch (xs) { | Nil => b | Cons(h, t) => let res = fold_right(f, b, t); f(h, res) } }; ================================================ FILE: test/L6/pos/deptup00.re ================================================ type pair('a, 'b)(p : 'a => 'b => bool) = | MkPair(x:'a, y:'b[v|p x v]) ; /*@ val check1 : x:int => pair(int, int)((x1:int, x2:int) => x1 < x2) */ let check1 = (x) => { let y = x + 1; MkPair(x, y) }; /*@ val check2 : x:int => pair(int, int)((x1:int, x2:int) => x1 > x2) */ let check2 = (x) => { let y = x + 1; MkPair(y, x) }; ================================================ FILE: test/L6/pos/deptup000.re ================================================ type pair()(pp : int => int => bool) = | MkPair(x:int, y:int[v|pp x v]) ; /*@ val check1 : x:int => pair()((el1:int, el2:int) => el1 < el2) */ let check1 = (x) => { let y = x + 1; MkPair(x, y) }; ================================================ FILE: test/L6/pos/deptup001.re ================================================ type pair('a, 'b)(p : 'a => 'b => bool) = | MkPair(x:'a, y:'b[v|p x v]) ; /*@ val check1 : x:int => pair(int, int)((x1:int, x2:int) => x1 < x2) */ let check1 = (x) => { let y = x + 1; MkPair(x, y) }; ================================================ FILE: test/L6/pos/deptup002.re ================================================ type pair() = | MkPair(x:int, y:int[v|x < v]) ; /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val check1 : pair() => int */ let check1 = (p) => { switch (p){ | MkPair(z1, z2) => let cond = z1 < z2; cassert(cond) } }; ================================================ FILE: test/L6/pos/deptup002a.re ================================================ type pair()(zog : int => int => bool) = | MkPair(x:int, y:int[v|zog x v]) ; /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val check1 : pair()((x1:int, x2:int) => x1 < x2) => int */ let check1 = (p) => { switch (p){ | MkPair(z1, z2) => let cond = z1 < z2; cassert(cond) } }; ================================================ FILE: test/L6/pos/deptup003.re ================================================ type pair('a, 'b)(zog : 'a => 'b => bool) = | MkPair(x:'a, y:'b[v|zog x v]) ; /*@ val cassert : bool[b|b] => int */ let cassert = (b) => { 0 }; /*@ val check1 : pair(int, int)((x1:int, x2:int) => x1 < x2) => int */ let check1 = (p) => { switch (p){ | MkPair(z1, z2) => let cond = z1 < z2; cassert(cond) } }; ================================================ FILE: test/L6/pos/deptup01.re ================================================ type pair('a, 'b)(p : 'a => 'b => bool) = | MkPair(x:'a, y:'b[v|p x v]) ; /*@ val myTuple: junk:int => pair(int[v|0 < v], int[v|v < 0])((u:int, v:int) => u + v == 0) */ let myTuple = (junk) => { let x0 = 5; let y0 = 0-5; MkPair(x0, y0) }; ================================================ FILE: test/L6/pos/isort02.re ================================================ type list('a)(p : 'a => 'a => bool) = | Nil | Cons(x:'a, list('a[v|p x v])((x1:'a, x2:'a) => p x1 x2)) ; /*@ val insert : x:'a => ys:list('a)((u1:'a, u2:'a) => u1 <= u2) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ let rec insert = (x, ys) => { switch (ys) { | Nil => let t = Nil; Cons(x, t) | Cons(y0, ys') => let cmp = x <= y0; if (cmp){ let tl = Cons(y0, ys'); Cons(x, tl) } else { let tl = insert(x, ys'); Cons(y0, tl) } } }; /*@ val isort : list('a)((u1:'a, u2:'a) => true) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ let rec isort = (xs) => { switch (xs){ | Nil => Nil | Cons (h, t) => let ot = isort(t); insert(h, ot) } }; ================================================ FILE: test/L6/pos/maxint.re ================================================ /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val test1 : a:int[v|0 < v] => b:int[v|0 < v] => int[v|0 < v] */ let test1 = (a, b) => { maxInt(a, b) }; /*@ val test2 : a:int[v|v < 0] => b:int[v|v < 0] => int[v|v < 0] */ let test2 = (a, b) => { maxInt(a, b) }; ================================================ FILE: test/L6/pos/maxlist00.re ================================================ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val maxInts : forall (p : int => bool). int[v| p v] => list(int[v| p v]) => int[v| p v] */ let rec maxInts = (cur, xs) => { switch (xs) { | Cons(h, t) => let newCur = maxInt(cur, h); maxInts(newCur, t) | Nil => (cur) } }; /*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ let maxPoss = (xs) => { maxInts(0, xs) }; /*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ let maxNegs = (xs) => { maxInts(0, xs) }; ================================================ FILE: test/L6/pos/maxlist01.re ================================================ /*@ qualif Geq(v:int, n:int): (n <= v) */ /*@ qualif AbsPred(v:int, f:int => bool): (f v) */ type list('a) = | Nil | Cons('a, list('a)) ; /*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */ let rec fold_right = (f, b, xs) => { switch (xs) { | Nil => b | Cons(h, t) => let res = fold_right(f, b, t); f(h, res) } }; /*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */ let maxInt = (x, y) => { let b = x < y; if (b){ y } else { x } }; /*@ val maxInts : forall (quxx: int => bool). list(int[v| quxx v]) => int[v| quxx v] */ let maxInts = (xs) => { switch (xs){ | Cons(h, t) => let maxInt_inst = maxInt; fold_right(maxInt_inst, h, t) | Nil => diverge(0) } }; /*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ let maxPoss = (xs) => { maxInts(xs) }; /*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ let maxNegs = (xs) => { maxInts(xs) }; ================================================ FILE: test/L6/pos/maxpoly.re ================================================ /*@ val silly : forall (p : 'a => bool). x:'a[v|p v] => 'a[v|p v] */ let silly = (x) => { x }; /*@ val test1 : a:int[v|0 < v] => int[v|0 < v] */ let test1 = (apple) => { silly(apple) }; ================================================ FILE: test/L6/pos/plaintup00.re ================================================ type pair('a, 'b) = | MkPair(x:'a, y:'b) ; /*@ val myTuple: junk:int => pair(int[v|0 < v], int[v|v < 0]) */ let myTuple = (junk) => { let x0 = 5; let y0 = 0-5; MkPair(x0, y0) }; ================================================ FILE: test/L7/neg/ack.re ================================================ /*@ val ack : m:int[v|0 <= v] => n:int[v|0 <= v] => int / m, n */ let rec ack = (m, n) => { let condm = m == 0; let condn = n == 0; if (condm) { n + 1 } else { let m1 = m - 1; if (condn) { ack (m1, 1) } else { let n1 = n - 1; let r = ack(m, n1); ack (m1, r) } } }; ================================================ FILE: test/L7/neg/list00.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v|len(v) > 0] = | Nil => [v| len(v) = 0] | Cons (x:'a, xs:list('a)) => [v| len(v) = 1 + len(xs)] ; /*@ val app : xs:list('a) => list('a) => list('a) / len(xs) */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L7/neg/listSet.re ================================================ /*@ measure len : list('a) => int */ /*@ measure elts : list('a) => Set_Set('a) */ type list('a) [v|len(v) >= 0] = | Nil => [v| v = Nil && len(v) = 0 && elts(v) = Set_empty(0)] | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs) && elts(v) = Set_add(elts(xs), x)] ; /*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(ys))] / len(ys) */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L7/neg/range.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val range : i:int => j:int => list(int) / (j - i) */ let rec range = (i, j) => { let cond = (i == j); if (cond) { let i1 = i + 1; let tl = range(i1, j); Cons(i, tl) } else { Nil } }; ================================================ FILE: test/L7/neg/sum.re ================================================ /*@ val sum : n:int => int[v|0 <= v] / n */ let rec sum = (n) => { let cond = n == 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); n + t1 } }; ================================================ FILE: test/L7/neg/sumAcc.re ================================================ /*@ val sumAcc : total:int => n:int => int / total */ let rec sumAcc = (total, n) => { let cond = n <= 0; if (cond) { total } else { let n1 = n - 1; let tot1 = total + n; sumAcc(tot1, n1) } }; ================================================ FILE: test/L7/pos/ack.re ================================================ /*@ val ack : m:int[v|0 <= v] => n:int[v|0 <= v] => int[v|0 <= v] / m, n */ let rec ack = (m, n) => { let condm = m == 0; let condn = n == 0; if (condm) { n + 1 } else { let m1 = m - 1; if (condn) { ack (m1, 1) } else { let n1 = n - 1; let r = ack(m, n1); ack (m1, r) } } }; ================================================ FILE: test/L7/pos/append.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v|len(v) >= 0] = | Nil => [v| len(v) = 0] | Cons (x:'a, xs:list('a)) => [v| len(v) = 1 + len(xs)] ; /*@ val append : xs:list('a) => list('a) => list('a) / len(xs) */ let rec append = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = append(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L7/pos/braid.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v| len(v) >= 0] = | Nil => [v| len(v) = 0] | Cons (x:'a, xs:list('a)) => [v| len(v) = 1 + len(xs) ] ; /*@ val braid : xs:list('a) => ys:list('a) => list('a) / len(xs) + len(ys) */ let rec braid = (xs, ys) => { switch (xs) { | Nil => ys | Cons (x, xs') => { let tl = braid(ys, xs'); Cons(x, tl) } } }; ================================================ FILE: test/L7/pos/listSet.re ================================================ /*@ measure len : list('a) => int */ /*@ measure elts : list('a) => Set_Set('a) */ type list('a) [v|len(v) >= 0] = | Nil => [v| v = Nil && len(v) = 0 && elts(v) = Set_empty(0)] | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs) && elts(v) = Set_add(elts(xs), x)] ; /*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(ys))] / len(xs) */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; ================================================ FILE: test/L7/pos/range.re ================================================ /*@ measure len : list('a) => int */ type list('a) = | Nil => [v| len v = 0] | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)] ; /*@ val range : i:int => j:int => list(int) / (j - i) */ let rec range = (i, j) => { let cond = i < j; if (cond) { let i1 = i + 1; let tl = range(i1, j); Cons(i, tl) } else { Nil } }; ================================================ FILE: test/L7/pos/sum.re ================================================ /*@ val sum : n:int => int[v|0 <= v] / n */ let rec sum = (n) => { let cond = n <= 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); n + t1 } }; ================================================ FILE: test/L7/pos/sumAcc.re ================================================ /*@ val sumAcc : total:int => n:int => int / n */ let rec sumAcc = (total, n) => { let cond = n <= 0; if (cond) { total } else { let n1 = n - 1; let tot1 = total + n; sumAcc(tot1, n1) } }; ================================================ FILE: test/L7/pos/sumNat.re ================================================ /*@ val sum : n:int[v|0 <= v] => int[v|0 <= v] / n */ let rec sum = (n) => { let cond = n == 0; if (cond) { 0 } else { let n1 = n-1; let t1 = sum(n1); n + t1 } }; ================================================ FILE: test/L8/neg/append.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v|len(v) >= 0] = | Nil => [v| v = Nil && len v = 0] | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len v = 1 + len(xs)] ; /*@ reflect app : xs:list('a) => list('a) => list('a) / len(xs) */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; /*@ val app_12_34 : int => int[v|app(Cons(1, Cons(2, Nil)), Cons(3, Cons(4000, Nil))) = Cons(1, Cons(2, Cons(3, Cons(4, Nil))))] */ let app_12_34 = (x) => { 0 }; /*@ val app_assoc : xs:list('a) => ys:list('a) => zs:list('a) => int[v|app(app(xs, ys), zs) = app(xs, app(ys, zs))] / len(xs) */ let rec app_assoc = (xs, ys, zs) => { switch (xs) { | Nil => 0 | Cons(x, xs') => app_assoc(xs', ys, zs) } }; ================================================ FILE: test/L8/neg/listSet.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v|len(v) >= 0] = | Nil => [v| v = Nil && len(v) = 0] | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs)] ; /*@ reflect app : xs:list('a) => list('a) => list('a) / len(xs) */ let rec app = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = app(t, ys); Cons(h, rest) } }; /*@ reflect rev : xs:list('a) => list('a) / len(xs) */ let rec rev = (xs) => { switch (xs) { | Nil => Nil | Cons(h, t) => let rest = rev(t); let n0 = Nil; let hl = Cons(h, n0); app(rest, hl) } }; /*@ reflect elts : l:list('a) => Set_Set('a) / len(l) */ let rec elts = (l) => { switch (l) { | Nil => Set_empty(0) | Cons(h, t) => let rest = elts(t); Set_add(rest, h) } }; /*@ val app_elts : xs:list('a) => ys:list('a) => int[v|elts(app(xs, ys)) = Set_cup(elts(xs), elts(ys))] / len(xs) */ let rec app_elts = (xs, ys) => { switch (xs) { | Nil => 0 | Cons(x, xs') => app_elts(xs', ys) } }; /*@ val rev_elts : xs:list('a) => int[v|elts(rev(xs)) = elts(xs)] / len(xs) */ let rec rev_elts = (xs) => { switch (xs) { | Nil => 0 | Cons(h, t) => let rest = rev(t); let n0 = Nil; let hl = Cons(h, n0); let pf1 = rev_elts(t); 0 } }; ================================================ FILE: test/L8/neg/sum.re ================================================ /*@ reflect sum : n:int => int / n */ let rec sum = (n) => { let base = n <= 0; if (base) { 0 } else { let n1 = n - 1; let t1 = sum(n1); n + t1 } }; /*@ val sum_3_eq_6 : int => int[v| sum(2) = 6] */ let sum_3_eq_6 = (x) => { 0 }; /*@ val thm_sum : n:int[v| 0 <= v] => int[v| 2 * sum(n) = n * (n+1)] / n */ let rec thm_sum = (n) => { let base = n <= 0; if (base) { 0 } else { let n1 = n - 1; thm_sum(n1) } }; ================================================ FILE: test/L8/pos/adttup00.re ================================================ type pair('a, 'b) = | MkPair(x:'a, y:'b) => [v|v = MkPair(x, y)] ; /*@ val myTuple: junk:int => pair(int, int)[v| v = MkPair(5, -5)] */ let myTuple = (junk) => { let x0 = 5; let y0 = 0-5; MkPair(x0, y0) }; ================================================ FILE: test/L8/pos/append.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v|len(v) >= 0] = | Nil => [v| v = Nil && len v = 0] | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len v = 1 + len(xs)] ; /*@ reflect append : xs:list('a) => list('a) => list('a) / len(xs) */ let rec append = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = append(t, ys); Cons(h, rest) } }; /*@ val append_12_34 : int => int[v|append(Cons(1, Cons(2, Nil)), Cons(3, Cons(4, Nil))) = Cons(1, Cons(2, Cons(3, Cons(4, Nil))))] */ let append_12_34 = (x) => { 0 }; /*@ val append_assoc : xs:list('a) => ys:list('a) => zs:list('a) => int[v|append(append(xs, ys), zs) = append(xs, append(ys, zs))] / len(xs) */ let rec append_assoc = (xs, ys, zs) => { switch (xs) { | Nil => 0 | Cons(x, xs') => append_assoc(xs', ys, zs) } }; ================================================ FILE: test/L8/pos/listSet.re ================================================ /*@ measure len : list('a) => int */ type list('a) [v|len(v) >= 0] = | Nil => [v| v = Nil && len(v) = 0] | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs)] ; /*@ reflect append : xs:list('a) => list('a) => list('a) / len(xs) */ let rec append = (xs, ys) => { switch (xs) { | Nil => ys | Cons(h, t) => let rest = append(t, ys); Cons(h, rest) } }; /*@ reflect rev : xs:list('a) => list('a) / len(xs) */ let rec rev = (xs) => { switch (xs) { | Nil => Nil | Cons(h, t) => let rest = rev(t); let n0 = Nil; let hl = Cons(h, n0); append(rest, hl) } }; /*@ reflect elts : l:list('a) => Set_Set('a) / len(l) */ let rec elts = (l) => { switch (l) { | Nil => Set_empty(0) | Cons(h, t) => let rest = elts(t); Set_add(rest, h) } }; /*@ val append_elts : xs:list('a) => ys:list('a) => int[v|elts(append(xs, ys)) = Set_cup(elts(xs), elts(ys))] / len(xs) */ let rec append_elts = (xs, ys) => { switch (xs) { | Nil => 0 | Cons(x, xs') => append_elts(xs', ys) } }; // /*@ val rev_elts : xs:list('a) => int[v|elts(rev(xs)) = elts(xs)] / len(xs) // */ // let rec rev_elts = (xs) => { // switch (xs) { // | Nil => 0 // | Cons(h, t) => let rest = rev(t); // let n0 = Nil; // let hl = Cons(h, n0); // let pf1 = rev_elts(t); // let pf2 = append_elts(rest, hl); // 0 // } // }; ================================================ FILE: test/L8/pos/poly.re ================================================ /*@ reflect cheq : 'a => 'a => bool / 0 */ let rec cheq = (x, y) => { x == y }; /*@ val test_int : int => int[v| cheq(2, 2) ] */ let test_int = (x) => { 0 }; /*@ val test_bool : int => int[v| cheq(true, true) ] */ let test_bool = (x) => { 0 }; ================================================ FILE: test/L8/pos/sum.re ================================================ /*@ reflect sum : n:int => int / n */ let rec sum = (n) => { let base = n <= 0; if (base) { 0 } else { let n1 = n - 1; let t1 = sum(n1); n + t1 } }; /*@ val sum_3_eq_6 : int => int[v| sum(3) = 6] */ let sum_3_eq_6 = (x) => { 0 }; /*@ val thm_sum : n:int[v| 0 <= v] => int[v| 2 * sum(n) = n * (n+1)] / n */ let rec thm_sum = (n) => { let base = n <= 0; if (base) { 0 } else { let n1 = n - 1; thm_sum(n1) } }; ================================================ FILE: test/Spec.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where import qualified Control.Concurrent.STM as STM import qualified Data.Functor.Compose as Functor import qualified Data.IntMap as IntMap -- import qualified Data.Map as Map import qualified Control.Monad.State as State import Control.Monad.Trans.Class (lift) import Data.Char import Data.Maybe (fromMaybe) import Data.Monoid (Sum(..), (<>)) import Control.Applicative import System.Directory import System.Exit import System.FilePath -- import System.Environment import System.IO import System.IO.Error import System.Process import Text.Printf import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun -- import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.Runners.AntXML import Paths_sprite main :: IO () main = defaultMainWithIngredients [testRunner] =<< allTests allTests = group "Tests" [ l1Tests , l2Tests , l3Tests , l4Tests , l5Tests , l6Tests , l8Tests ] l1Tests :: IO TestTree l1Tests = group "L1" $ langTests "L1" 1 l2Tests :: IO TestTree l2Tests = group "L2" $ langTests "L1" 2 ++ langTests "L2" 2 l3Tests :: IO TestTree l3Tests = group "L3" $ langTests "L1" 3 ++ langTests "L2" 3 ++ langTests "L3" 3 l4Tests :: IO TestTree l4Tests = group "L4" $ langTests "L1" 4 ++ langTests "L2" 4 ++ langTests "L3" 4 ++ langTests "L4" 4 l5Tests :: IO TestTree l5Tests = group "L5" $ langTests "L1" 5 ++ langTests "L2" 5 ++ langTests "L3" 5 ++ langTests "L4" 5 ++ langTests "L5" 5 l6Tests :: IO TestTree l6Tests = group "L6" $ langTests "L1" 6 ++ langTests "L2" 6 ++ langTests "L3" 6 ++ langTests "L4" 6 ++ langTests "L5" 6 ++ langTests "L6" 6 l8Tests :: IO TestTree l8Tests = group "L8" $ langTests "L7" 8 ++ langTests "L8" 8 langTests :: String -> Int -> [IO TestTree] langTests lang n = [ testGroup (name "pos") <$> dirTests (spriteCmd n) (dir "pos") [] ExitSuccess , testGroup (name "neg") <$> dirTests (spriteCmd n) (dir "neg") [] (ExitFailure 1) ] where name :: String -> String name k = printf "%s-%s-%d" k lang n dir k = "test" lang k testRunner :: Ingredient testRunner = rerunningTests [ listingTests , combineReporters myConsoleReporter antXMLRunner , myConsoleReporter ] myConsoleReporter :: Ingredient myConsoleReporter = combineReporters consoleTestReporter loggingTestReporter -- | Combine two @TestReporter@s into one. -- -- Runs the reporters in sequence, so it's best to start with the one -- that will produce incremental output, e.g. 'consoleTestReporter'. combineReporters :: Ingredient -> Ingredient -> Ingredient combineReporters (TestReporter opts1 run1) (TestReporter opts2 run2) = TestReporter (opts1 ++ opts2) $ \opts tree -> do f1 <- run1 opts tree f2 <- run2 opts tree return $ \smap -> f1 smap >> f2 smap combineReporters _ _ = error "combineReporters needs TestReporters" --------------------------------------------------------------------------- dirTests :: TestCmd -> FilePath -> [FilePath] -> ExitCode -> IO [TestTree] --------------------------------------------------------------------------- dirTests testCmd root ignored code = do files <- walkDirectory root let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ] return $ mkTest testCmd code root <$> tests isTest :: FilePath -> Bool isTest f = takeExtension f `elem` [".re"] --------------------------------------------------------------------------- mkTest :: TestCmd -> ExitCode -> FilePath -> FilePath -> TestTree --------------------------------------------------------------------------- mkTest testCmd code dir file = testCase file $ if test `elem` knownToFail then do printf "%s is known to fail: SKIPPING" test assertEqual "" True True else do createDirectoryIfMissing True $ takeDirectory log bin <- binPath execName withFile log WriteMode $ \h -> do let cmd = testCmd bin dir file (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h} c <- waitForProcess ph assertEqual ("Wrong exit code: " ++ cmd) code c where test = dir file log = let (d,f) = splitFileName file in dir d ".liquid" f <.> "log" binPath :: FilePath -> IO FilePath binPath pkgName = ( pkgName) <$> getBinDir knownToFail = [] --------------------------------------------------------------------------- -- | Project specific configuration --------------------------------------- --------------------------------------------------------------------------- type TestCmd = FilePath -> FilePath -> FilePath -> String execName :: FilePath execName = "sprite" spriteCmd :: Int -> TestCmd spriteCmd n bin dir file = printf "cd %s && %s %d %s" dir bin n file ---------------------------------------------------------------------------------------- -- Generic Helpers ---------------------------------------------------------------------------------------- group n xs = testGroup n <$> sequence xs ---------------------------------------------------------------------------------------- walkDirectory :: FilePath -> IO [FilePath] ---------------------------------------------------------------------------------------- walkDirectory root = do (ds,fs) <- partitionM doesDirectoryExist . candidates =<< (getDirectoryContents root `catchIOError` const (return [])) (fs++) <$> concatMapM walkDirectory ds where candidates fs = [root f | f <- fs, not (isExtSeparator (head f))] partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a]) partitionM f = go [] [] where go ls rs [] = return (ls,rs) go ls rs (x:xs) = do b <- f x if b then go (x:ls) rs xs else go ls (x:rs) xs -- isDirectory :: FilePath -> IO Bool -- isDirectory = fmap Posix.isDirectory . Posix.getFileStatus concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b] concatMapM _ [] = pure [] concatMapM f (x:xs) = (++) <$> f x <*> concatMapM f xs -- -- this is largely based on ocharles' test runner at -- -- https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs#L65 -- loggingTestReporter :: Ingredient -- loggingTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do -- let -- runTest _ testName _ = Traversal $ Functor.Compose $ do -- i <- State.get -- summary <- lift $ STM.atomically $ do -- status <- STM.readTVar $ -- fromMaybe (error "Attempted to lookup test by index outside bounds") $ -- IntMap.lookup i smap -- let mkSuccess time = [(testName, time, True)] -- mkFailure time = [(testName, time, False)] -- case status of -- -- If the test is done, generate a summary for it -- Done result -- | resultSuccessful result -- -> pure (mkSuccess (resultTime result)) -- | otherwise -- -> pure (mkFailure (resultTime result)) -- -- Otherwise the test has either not been started or is currently -- -- executing -- _ -> STM.retry -- Const summary <$ State.modify (+ 1) -- runGroup group children = Traversal $ Functor.Compose $ do -- Const soFar <- Functor.getCompose $ getTraversal children -- pure $ Const $ map (\(n,t,s) -> (groupn,t,s)) soFar -- computeFailures :: StatusMap -> IO Int -- computeFailures = fmap getSum . getApp . foldMap (\var -> Ap $ -- (\r -> Sum $ if resultSuccessful r then 0 else 1) <$> getResultFromTVar var) -- getResultFromTVar :: STM.TVar Status -> IO Result -- getResultFromTVar var = -- STM.atomically $ do -- status <- STM.readTVar var -- case status of -- Done r -> return r -- _ -> STM.retry -- (Const summary, _tests) <- -- flip State.runStateT 0 $ Functor.getCompose $ getTraversal $ -- foldTestTree -- trivialFold { foldSingle = runTest, foldGroup = runGroup } -- opts -- tree -- return $ \_elapsedTime -> do -- -- get some semblance of a hostname -- host <- takeWhile (/='.') . takeWhile (not . isSpace) <$> readProcess "hostname" [] [] -- -- don't use the `time` package, major api differences between ghc 708 and 710 -- time <- head . lines <$> readProcess "date" ["+%Y-%m-%dT%H-%M-%S"] [] -- -- build header -- ref <- gitRef -- timestamp <- gitTimestamp -- epochTime <- gitEpochTimestamp -- hash <- gitHash -- let hdr = unlines [ref ++ " : " ++ hash, -- "Timestamp: " ++ timestamp, -- "Epoch Timestamp: " ++ epochTime, -- headerDelim, -- "test, time(s), result"] -- let dir = "test" "logs" host ++ "-" ++ time -- let smry = "test" "logs" "cur" "summary.csv" -- writeFile smry $ unlines -- $ hdr -- : map (\(n, t, r) -> printf "%s, %0.4f, %s" n t (show r)) summary -- -- system $ "cp -r tests/logs/cur " ++ dir -- (==0) <$> computeFailures smap -- this is largely based on ocharles' test runner at -- https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs#L65 loggingTestReporter :: Ingredient loggingTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do let runTest _ testName _ = Traversal $ Functor.Compose $ do i <- State.get summary <- lift $ STM.atomically $ do status <- STM.readTVar $ fromMaybe (error "Attempted to lookup test by index outside bounds") $ IntMap.lookup i smap let mkSuccess time = [(testName, time, True)] mkFailure time = [(testName, time, False)] case status of -- If the test is done, generate a summary for it Done result | resultSuccessful result -> pure (mkSuccess (resultTime result)) | otherwise -> pure (mkFailure (resultTime result)) -- Otherwise the test has either not been started or is currently -- executing _ -> STM.retry Const summary <$ State.modify (+ 1) runGroup _ group' children = Traversal $ Functor.Compose $ do Const soFar <- Functor.getCompose $ getTraversal $ mconcat children pure $ Const $ map (\(n,t,s) -> (group' n,t,s)) soFar computeFailures :: StatusMap -> IO Int computeFailures = fmap getSum . getApp . foldMap (\var -> Ap $ (\r -> Sum $ if resultSuccessful r then 0 else 1) <$> getResultFromTVar var) getResultFromTVar :: STM.TVar Status -> IO Result getResultFromTVar var = STM.atomically $ do status <- STM.readTVar var case status of Done r -> return r _ -> STM.retry (Const summary, _tests) <- flip State.runStateT 0 $ Functor.getCompose $ getTraversal $ foldTestTree trivialFold { foldSingle = runTest, foldGroup = runGroup } opts tree return $ \_elapsedTime -> do -- don't use the `time` package, major api differences between ghc 708 and 710 -- build header ref <- gitRef timestamp <- gitTimestamp epochTime <- gitEpochTimestamp hash <- gitHash let hdr = unlines [ref ++ " : " ++ hash, "Timestamp: " ++ timestamp, "Epoch Timestamp: " ++ epochTime, headerDelim, "test, time(s), result"] let smry = "test" "logs" "cur" "summary.csv" writeFile smry $ unlines $ hdr : map (\(n, t, r) -> printf "%s, %0.4f, %s" n t (show r)) summary (==0) <$> computeFailures smap gitTimestamp :: IO String gitTimestamp = do res <- gitProcess ["show", "--format=\"%ci\"", "--quiet"] return $ filter notNoise res gitEpochTimestamp :: IO String gitEpochTimestamp = do res <- gitProcess ["show", "--format=\"%ct\"", "--quiet"] return $ filter notNoise res gitHash :: IO String gitHash = do res <- gitProcess ["show", "--format=\"%H\"", "--quiet"] return $ filter notNoise res gitRef :: IO String gitRef = do res <- gitProcess ["show", "--format=\"%d\"", "--quiet"] return $ filter notNoise res -- | Calls `git` for info; returns `"plain"` if we are not in a git directory. gitProcess :: [String] -> IO String gitProcess args = (readProcess "git" args []) `catchIOError` const (return "plain") notNoise :: Char -> Bool notNoise a = a /= '\"' && a /= '\n' && a /= '\r' headerDelim :: String headerDelim = replicate 80 '-' ================================================ FILE: test/logs/cur/summary.csv ================================================ (HEAD -> bump, origin/bump) : 24d6e7c580595f45e9c53eb128f0e9377fc081b4 Timestamp: 2024-03-08 23:02:23 -0800 Epoch Timestamp: 1709967743 -------------------------------------------------------------------------------- test, time(s), result Tests/L1/pos-L1-1/int01.re, 0.5696, True Tests/L1/pos-L1-1/int00.re, 0.5485, True Tests/L1/pos-L1-1/inc02.re, 0.5768, True Tests/L1/pos-L1-1/inc01.re, 0.5684, True Tests/L1/pos-L1-1/inc00.re, 0.5686, True Tests/L1/neg-L1-1/int01.re, 0.5739, True Tests/L1/neg-L1-1/inc02.re, 0.5735, True Tests/L1/neg-L1-1/inc01.re, 0.5721, True Tests/L1/neg-L1-1/inc00.re, 0.0389, True Tests/L2/pos-L1-2/int01.re, 0.0355, True Tests/L2/pos-L1-2/int00.re, 0.0346, True Tests/L2/pos-L1-2/inc02.re, 0.0451, True Tests/L2/pos-L1-2/inc01.re, 0.0457, True Tests/L2/pos-L1-2/inc00.re, 0.0395, True Tests/L2/neg-L1-2/int01.re, 0.0341, True Tests/L2/neg-L1-2/inc02.re, 0.0460, True Tests/L2/neg-L1-2/inc01.re, 0.0383, True Tests/L2/neg-L1-2/inc00.re, 0.0445, True Tests/L2/pos-L2-2/sum00.re, 0.0330, True Tests/L2/pos-L2-2/abs00.re, 0.0441, True Tests/L2/pos-L2-2/abs01.re, 0.0482, True Tests/L2/pos-L2-2/cmp01.re, 0.0327, True Tests/L2/pos-L2-2/cmp00.re, 0.0339, True Tests/L2/neg-L2-2/sum00.re, 0.0368, True Tests/L2/neg-L2-2/abs00.re, 0.0354, True Tests/L2/neg-L2-2/abs01.re, 0.0471, True Tests/L2/neg-L2-2/cmp01.re, 0.0433, True Tests/L2/neg-L2-2/cmp00.re, 0.0458, True Tests/L3/pos-L1-3/int01.re, 0.0453, True Tests/L3/pos-L1-3/int00.re, 0.0247, True Tests/L3/pos-L1-3/inc02.re, 0.0328, True Tests/L3/pos-L1-3/inc01.re, 0.0346, True Tests/L3/pos-L1-3/inc00.re, 0.0385, True Tests/L3/neg-L1-3/int01.re, 0.0347, True Tests/L3/neg-L1-3/inc02.re, 0.0467, True Tests/L3/neg-L1-3/inc01.re, 0.0445, True Tests/L3/neg-L1-3/inc00.re, 0.0339, True Tests/L3/pos-L2-3/sum00.re, 0.0420, True Tests/L3/pos-L2-3/abs00.re, 0.0485, True Tests/L3/pos-L2-3/abs01.re, 0.0481, True Tests/L3/pos-L2-3/cmp01.re, 0.0456, True Tests/L3/pos-L2-3/cmp00.re, 0.0333, True Tests/L3/neg-L2-3/sum00.re, 0.0342, True Tests/L3/neg-L2-3/abs00.re, 0.0430, True Tests/L3/neg-L2-3/abs01.re, 0.0449, True Tests/L3/neg-L2-3/cmp01.re, 0.0444, True Tests/L3/neg-L2-3/cmp00.re, 0.0357, True Tests/L3/pos-L3-3/abs02.re, 0.0462, True Tests/L3/pos-L3-3/abs02-debug.re, 0.0347, True Tests/L3/pos-L3-3/assert00.re, 0.0349, True Tests/L3/pos-L3-3/sum01.re, 0.0484, True Tests/L3/pos-L3-3/abs01.re, 0.0422, True Tests/L3/neg-L3-3/abs02.re, 0.0485, True Tests/L3/neg-L3-3/assert00.re, 0.0364, True Tests/L3/neg-L3-3/sum01.re, 0.0354, True Tests/L3/neg-L3-3/rebind.re, 0.0355, True Tests/L3/neg-L3-3/abs02-bad.re, 0.0485, True Tests/L3/neg-L3-3/abs01.re, 0.0376, True Tests/L4/pos-L1-4/int01.re, 0.0435, True Tests/L4/pos-L1-4/int00.re, 0.0257, True Tests/L4/pos-L1-4/inc02.re, 0.0457, True Tests/L4/pos-L1-4/inc01.re, 0.0332, True Tests/L4/pos-L1-4/inc00.re, 0.0331, True Tests/L4/neg-L1-4/int01.re, 0.0373, True Tests/L4/neg-L1-4/inc02.re, 0.0357, True Tests/L4/neg-L1-4/inc01.re, 0.0371, True Tests/L4/neg-L1-4/inc00.re, 0.0386, True Tests/L4/pos-L2-4/sum00.re, 0.0461, True Tests/L4/pos-L2-4/abs00.re, 0.0376, True Tests/L4/pos-L2-4/abs01.re, 0.0469, True Tests/L4/pos-L2-4/cmp01.re, 0.0384, True Tests/L4/pos-L2-4/cmp00.re, 0.0351, True Tests/L4/neg-L2-4/sum00.re, 0.0336, True Tests/L4/neg-L2-4/abs00.re, 0.0352, True Tests/L4/neg-L2-4/abs01.re, 0.0482, True Tests/L4/neg-L2-4/cmp01.re, 0.0453, True Tests/L4/neg-L2-4/cmp00.re, 0.0473, True Tests/L4/pos-L3-4/abs02.re, 0.0488, True Tests/L4/pos-L3-4/abs02-debug.re, 0.0378, True Tests/L4/pos-L3-4/assert00.re, 0.0387, True Tests/L4/pos-L3-4/sum01.re, 0.0469, True Tests/L4/pos-L3-4/abs01.re, 0.0342, True Tests/L4/neg-L3-4/abs02.re, 0.0462, True Tests/L4/neg-L3-4/assert00.re, 0.0409, True Tests/L4/neg-L3-4/sum01.re, 0.0468, True Tests/L4/neg-L3-4/rebind.re, 0.0336, True Tests/L4/neg-L3-4/abs02-bad.re, 0.0445, True Tests/L4/neg-L3-4/abs01.re, 0.0385, True Tests/L4/pos-L4-4/id00.re, 0.0354, True Tests/L4/pos-L4-4/foldn01.re, 0.0501, True Tests/L4/pos-L4-4/foldn00.re, 0.0436, True Tests/L4/pos-L4-4/choose01.re, 0.0446, True Tests/L4/pos-L4-4/choose00.re, 0.0401, True Tests/L4/neg-L4-4/id00.re, 0.0345, True Tests/L4/neg-L4-4/foldn01.re, 0.0229, True Tests/L4/neg-L4-4/foldn00.re, 0.0357, True Tests/L4/neg-L4-4/choose01.re, 0.0367, True Tests/L4/neg-L4-4/choose00.re, 0.0484, True Tests/L5/pos-L1-5/int01.re, 0.0501, True Tests/L5/pos-L1-5/int00.re, 0.0350, True Tests/L5/pos-L1-5/inc02.re, 0.0468, True Tests/L5/pos-L1-5/inc01.re, 0.0327, True Tests/L5/pos-L1-5/inc00.re, 0.0338, True Tests/L5/neg-L1-5/int01.re, 0.0371, True Tests/L5/neg-L1-5/inc02.re, 0.0360, True Tests/L5/neg-L1-5/inc01.re, 0.0459, True Tests/L5/neg-L1-5/inc00.re, 0.0413, True Tests/L5/pos-L2-5/sum00.re, 0.0404, True Tests/L5/pos-L2-5/abs00.re, 0.0452, True Tests/L5/pos-L2-5/abs01.re, 0.0463, True Tests/L5/pos-L2-5/cmp01.re, 0.0461, True Tests/L5/pos-L2-5/cmp00.re, 0.0460, True Tests/L5/neg-L2-5/sum00.re, 0.0353, True Tests/L5/neg-L2-5/abs00.re, 0.0426, True Tests/L5/neg-L2-5/abs01.re, 0.0433, True Tests/L5/neg-L2-5/cmp01.re, 0.0368, True Tests/L5/neg-L2-5/cmp00.re, 0.0468, True Tests/L5/pos-L3-5/abs02.re, 0.0467, True Tests/L5/pos-L3-5/abs02-debug.re, 0.0336, True Tests/L5/pos-L3-5/assert00.re, 0.0421, True Tests/L5/pos-L3-5/sum01.re, 0.0449, True Tests/L5/pos-L3-5/abs01.re, 0.0464, True Tests/L5/neg-L3-5/abs02.re, 0.0419, True Tests/L5/neg-L3-5/assert00.re, 0.0444, True Tests/L5/neg-L3-5/sum01.re, 0.0431, True Tests/L5/neg-L3-5/rebind.re, 0.0489, True Tests/L5/neg-L3-5/abs02-bad.re, 0.0491, True Tests/L5/neg-L3-5/abs01.re, 0.0343, True Tests/L5/pos-L4-5/id00.re, 0.0351, True Tests/L5/pos-L4-5/foldn01.re, 0.0617, True Tests/L5/pos-L4-5/foldn00.re, 0.0587, True Tests/L5/pos-L4-5/choose01.re, 0.0442, True Tests/L5/pos-L4-5/choose00.re, 0.0479, True Tests/L5/neg-L4-5/id00.re, 0.0429, True Tests/L5/neg-L4-5/foldn01.re, 0.0529, True Tests/L5/neg-L4-5/foldn00.re, 0.0436, True Tests/L5/neg-L4-5/choose01.re, 0.0319, True Tests/L5/neg-L4-5/choose00.re, 0.0617, True Tests/L5/pos-L5-5/tuple00.re, 0.0606, True Tests/L5/pos-L5-5/olist01.re, 0.0582, True Tests/L5/pos-L5-5/isort00.re, 0.0723, True Tests/L5/pos-L5-5/isort01.re, 0.0623, True Tests/L5/pos-L5-5/listSet.re, 0.0480, True Tests/L5/pos-L5-5/single00.re, 0.0480, True Tests/L5/pos-L5-5/olist00.re, 0.0468, True Tests/L5/pos-L5-5/append00.re, 0.0424, True Tests/L5/pos-L5-5/head00.re, 0.0476, True Tests/L5/pos-L5-5/tail01.re, 0.0478, True Tests/L5/pos-L5-5/head01.re, 0.0479, True Tests/L5/pos-L5-5/cons00.re, 0.0355, True Tests/L5/pos-L5-5/olist02.re, 0.0471, True Tests/L5/pos-L5-5/nil00.re, 0.0343, True Tests/L5/pos-L5-5/fold_right00.re, 0.0332, True Tests/L5/neg-L5-5/tuple00.re, 0.0437, True Tests/L5/neg-L5-5/olist01.re, 0.0468, True Tests/L5/neg-L5-5/isort00.re, 0.0449, True Tests/L5/neg-L5-5/isort01.re, 0.0444, True Tests/L5/neg-L5-5/listSet.re, 0.0495, True Tests/L5/neg-L5-5/single00.re, 0.0368, True Tests/L5/neg-L5-5/olist00.re, 0.0354, True Tests/L5/neg-L5-5/append00.re, 0.0467, True Tests/L5/neg-L5-5/head00.re, 0.0460, True Tests/L5/neg-L5-5/tail01.re, 0.0425, True Tests/L5/neg-L5-5/head01.re, 0.0441, True Tests/L5/neg-L5-5/cons00.re, 0.0344, True Tests/L5/neg-L5-5/olist02.re, 0.0490, True Tests/L5/neg-L5-5/nil00.re, 0.0340, True Tests/L6/pos-L1-6/int01.re, 0.0320, True Tests/L6/pos-L1-6/int00.re, 0.0225, True Tests/L6/pos-L1-6/inc02.re, 0.0449, True Tests/L6/pos-L1-6/inc01.re, 0.0449, True Tests/L6/pos-L1-6/inc00.re, 0.0358, True Tests/L6/neg-L1-6/int01.re, 0.0354, True Tests/L6/neg-L1-6/inc02.re, 0.0522, True Tests/L6/neg-L1-6/inc01.re, 0.0512, True Tests/L6/neg-L1-6/inc00.re, 0.0348, True Tests/L6/pos-L2-6/sum00.re, 0.0371, True Tests/L6/pos-L2-6/abs00.re, 0.0433, True Tests/L6/pos-L2-6/abs01.re, 0.0472, True Tests/L6/pos-L2-6/cmp01.re, 0.0420, True Tests/L6/pos-L2-6/cmp00.re, 0.0399, True Tests/L6/neg-L2-6/sum00.re, 0.0434, True Tests/L6/neg-L2-6/abs00.re, 0.0407, True Tests/L6/neg-L2-6/abs01.re, 0.0342, True Tests/L6/neg-L2-6/cmp01.re, 0.0341, True Tests/L6/neg-L2-6/cmp00.re, 0.0360, True Tests/L6/pos-L3-6/abs02.re, 0.0461, True Tests/L6/pos-L3-6/abs02-debug.re, 0.0456, True Tests/L6/pos-L3-6/assert00.re, 0.0430, True Tests/L6/pos-L3-6/sum01.re, 0.0509, True Tests/L6/pos-L3-6/abs01.re, 0.0501, True Tests/L6/neg-L3-6/abs02.re, 0.0496, True Tests/L6/neg-L3-6/assert00.re, 0.0357, True Tests/L6/neg-L3-6/sum01.re, 0.0496, True Tests/L6/neg-L3-6/rebind.re, 0.0453, True Tests/L6/neg-L3-6/abs02-bad.re, 0.0443, True Tests/L6/neg-L3-6/abs01.re, 0.0445, True Tests/L6/pos-L4-6/id00.re, 0.0353, True Tests/L6/pos-L4-6/foldn01.re, 0.0471, True Tests/L6/pos-L4-6/foldn00.re, 0.0475, True Tests/L6/pos-L4-6/choose01.re, 0.0364, True Tests/L6/pos-L4-6/choose00.re, 0.0419, True Tests/L6/neg-L4-6/id00.re, 0.0435, True Tests/L6/neg-L4-6/foldn01.re, 0.0362, True Tests/L6/neg-L4-6/foldn00.re, 0.0440, True Tests/L6/neg-L4-6/choose01.re, 0.0449, True Tests/L6/neg-L4-6/choose00.re, 0.0453, True Tests/L6/pos-L5-6/tuple00.re, 0.0338, True Tests/L6/pos-L5-6/olist01.re, 0.0493, True Tests/L6/pos-L5-6/isort00.re, 0.0441, True Tests/L6/pos-L5-6/isort01.re, 0.0450, True Tests/L6/pos-L5-6/listSet.re, 0.0453, True Tests/L6/pos-L5-6/single00.re, 0.0488, True Tests/L6/pos-L5-6/olist00.re, 0.0363, True Tests/L6/pos-L5-6/append00.re, 0.0458, True Tests/L6/pos-L5-6/head00.re, 0.0466, True Tests/L6/pos-L5-6/tail01.re, 0.0365, True Tests/L6/pos-L5-6/head01.re, 0.0456, True Tests/L6/pos-L5-6/cons00.re, 0.0327, True Tests/L6/pos-L5-6/olist02.re, 0.0454, True Tests/L6/pos-L5-6/nil00.re, 0.0476, True Tests/L6/pos-L5-6/fold_right00.re, 0.0359, True Tests/L6/neg-L5-6/tuple00.re, 0.0362, True Tests/L6/neg-L5-6/olist01.re, 0.0384, True Tests/L6/neg-L5-6/isort00.re, 0.0492, True Tests/L6/neg-L5-6/isort01.re, 0.0488, True Tests/L6/neg-L5-6/listSet.re, 0.0468, True Tests/L6/neg-L5-6/single00.re, 0.0445, True Tests/L6/neg-L5-6/olist00.re, 0.0458, True Tests/L6/neg-L5-6/append00.re, 0.0473, True Tests/L6/neg-L5-6/head00.re, 0.0378, True Tests/L6/neg-L5-6/tail01.re, 0.0398, True Tests/L6/neg-L5-6/head01.re, 0.0358, True Tests/L6/neg-L5-6/cons00.re, 0.0430, True Tests/L6/neg-L5-6/olist02.re, 0.0449, True Tests/L6/neg-L5-6/nil00.re, 0.0365, True Tests/L6/pos-L6-6/maxpoly.re, 0.0487, True Tests/L6/pos-L6-6/deptup003.re, 0.0474, True Tests/L6/pos-L6-6/deptup00.re, 0.0464, True Tests/L6/pos-L6-6/deptup002.re, 0.0462, True Tests/L6/pos-L6-6/apply00.re, 0.0266, True Tests/L6/pos-L6-6/maxlist00.re, 0.0440, True Tests/L6/pos-L6-6/deptup001.re, 0.0454, True Tests/L6/pos-L6-6/maxint.re, 0.0453, True Tests/L6/pos-L6-6/deptup002a.re, 0.0456, True Tests/L6/pos-L6-6/maxlist01.re, 0.0619, True Tests/L6/pos-L6-6/deptup000.re, 0.0339, True Tests/L6/pos-L6-6/isort02.re, 0.0551, True Tests/L6/neg-L6-6/maxint1.re, 0.0407, True Tests/L6/neg-L6-6/maxlist00_1.re, 0.0476, True Tests/L6/neg-L6-6/deptup00.re, 0.0450, True Tests/L6/neg-L6-6/maxlist.re, 0.0515, True Tests/L6/neg-L6-6/maxlist00_2.re, 0.0476, True Tests/L6/neg-L6-6/maxlist01.re, 0.0458, True Tests/L6/neg-L6-6/isort02.re, 0.0586, True Tests/L6/neg-L6-6/maxint2.re, 0.0368, True Tests/L8/pos-L7-8/sumAcc.re, 0.0554, True Tests/L8/pos-L7-8/listSet.re, 0.0595, True Tests/L8/pos-L7-8/range.re, 0.0469, True Tests/L8/pos-L7-8/ack.re, 0.0591, True Tests/L8/pos-L7-8/sumNat.re, 0.0440, True Tests/L8/pos-L7-8/append.re, 0.0469, True Tests/L8/pos-L7-8/sum.re, 0.0504, True Tests/L8/pos-L7-8/braid.re, 0.0479, True Tests/L8/neg-L7-8/sumAcc.re, 0.0598, True Tests/L8/neg-L7-8/listSet.re, 0.0668, True Tests/L8/neg-L7-8/range.re, 0.0657, True Tests/L8/neg-L7-8/ack.re, 0.0743, True Tests/L8/neg-L7-8/list00.re, 0.0663, True Tests/L8/neg-L7-8/sum.re, 0.0692, True Tests/L8/pos-L8-8/listSet.re, 0.0954, True Tests/L8/pos-L8-8/poly.re, 0.0578, True Tests/L8/pos-L8-8/append.re, 0.0715, True Tests/L8/pos-L8-8/sum.re, 0.0533, True Tests/L8/neg-L8-8/listSet.re, 0.0319, True Tests/L8/neg-L8-8/append.re, 0.0312, True Tests/L8/neg-L8-8/sum.re, 0.0464, True