[ { "path": ".gitignore", "content": "dist\ndist-*\ncabal-dev\n*.o\n*.hi\n*.hie\n*.chi\n*.chs.h\n*.dyn_o\n*.dyn_hi\n.hpc\n.hsenv\n.cabal-sandbox/\ncabal.sandbox.config\n*.prof\n*.aux\n.liquid/\n*.hp\n*.eventlog\n.stack-work/\ncabal.project.local\ncabal.project.local~\n.HTF/\n.ghc.environment.*\n" }, { "path": "ChangeLog.md", "content": "# Changelog for liquid-tutorial\n\n## Unreleased changes\n" }, { "path": "LICENSE", "content": "Copyright Author name here (c) 2019\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of Author name here nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "NOTES.md", "content": "# SPRITE\n\nAn tutorial-style implementation of liquid/refinement types for a subset of Ocaml/Reason.\n\n## TODO: Paper\n\n- [*] Lang1 : STLC + Annot (refinements 101)\n- [*] Lang2 : \"\" + Branches (path-sensitivity)\n- [*] Lang3 : \"\" + *-refinements (inference + qual-fixpoint)\n- [*] Lang4 : \"\" + T-Poly (type-polymorphism)\n- [*] Lang5 : \"\" + Data (datatypes & measures)\n- [*] Lang6 : \"\" + R-Poly (refinement-polymorphism)\n- [*] Lang7 : \"\" + Termination (metrics + invariants)\n- [-] Lang8 : \"\" + Reflection (proofs)\n- [ ] well-formedness\n- [ ] L7 Invariant & Validity \n- [ ] intro\n- [ ] outro\n\n## TODO: Code \n\n- [*] Save Horn QUERY\n- [ ] ANF\n\n## L7 Invariant & Validity \n\n```\nI, G, f_k |- t\n---------------------- [Inv-RAbs]\nI, G |- rall r. t\n\nI, G, a |- t\n---------------------- [Inv-TAbs]\nI, G |- all a. t\n\nI, G, x:s |- x:s -> t\n---------------------- [Inv-Fun]\nI, G |- x:s -> t\n\nG |- t <: I(t)\n---------------------- [Inv-Base]\nI, G |- t\n```\n\n\n## Dependencies\n\n```txt\n L1 --> L2 --> L3 --> L4 --> L6\n `--> L5 --> L7 --> L8\n```\n\n## Horn Constraints\n\n- Syntax\n- Semantics\n- Solution\n - Houdini\n - Fusion\n - [McMillan, Bjorner, Rybalchenko]\n\n\n### Types and Terms\n\n```txt\np :== x -- PREDICATES\n | c\n | (op p1 ... pn) -- interpreted ops\n | (f p1 ... pn) -- uninterpreted ops\n | (bop p1 ... pn) -- boolean ops\n\nc :== p -- FORMULAS\n | c /\\ c\n | all x. (p => c)\n\nr ::= [v|p] -- known refinements\n\nt ::= Int[r] -- refined int\n | x:t -> t -- dependent arrow\n\ne ::= x -- variables [synth]\n | c -- constants [synth]\n | \\x. e -- functions [check]\n | e x -- anf-application [synth]\n | let x = e in e -- let-binding [check]\n | e : t -- annotation [check]\n```\n\n### Declarative Checking\n\nEnvironments\n\n```txt\nG ::= 0 | G, x:t -- environment\n```\n\nJudgments\n\n```txt\nG |- e <== t -- checking judgment\nG |- e ==> t -- synthesis judgment\n```\n\nRules\n\n- *Check-_* deals with `let`, `\\x.e`\n- *Synth-_* deals with `x`, `c`, `e x`, `e:t`\n\n#### Subtyping Rules\n\n```txt\nValid(G,p)\n----------[Sub-Valid]\nG |- p\n\nG,v:int{p} |- q[w:=v]\n-------------------------[Sub-Base]\nG |- int{v:p} <: int{w:q}\n\n\nG |- s2 <: s1 G,x2:s2 |- t1[x1:=x2] <: t2\n------------------------------------------------[Sub-Fun]\nG |- x1:s1 -> t1 <: x2:s2 -> t2\n```\n\nAlternate \"Hybrid\" Presentation\n\n```txt\nValid(c)\n--------\n0 => c\n\nG => (all x. (p => c))\n----------------------\nG, x:{p} => c\n\nG => sub(s, t)\n---------------\nG |- s <: t\n```\n\n#### Checking Rules\n\n```txt\nG, x:t1 |- e <== t2\n--------------------------[Chk-Lam]\nG |- \\x.e <== x:t1 -> t2\n\n\nG |- e1 ==> t1 G, x:t1 |- e2 <== t2\n--------------------------------------------[Chk-Let]\n G |- let x = e1 in e2 <== t2\n\n\nG |- e ==> s G |- s <: t\n----------------------------------[Chk-Syn]\n G |- e <== t\n```\n\n#### Synthesis Rules\n\n```txt\n----------------- [Syn-Var]\nG |- x ==> G(x)\n\n----------------- [Syn-Con]\nG |- x ==> ty(c)\n\n\nG |- e <== t\n----------------- [Syn-Ann]\nG |- e:t ==> t\n\n\nG |- e ==> x:s -> t\nG |- y <== s\n-----------------------[Syn-App]\nG |- e y ==> t[x := y]\n\n\n\nG |- e ==> s -> t G |- (s -> t) * x ==> t\n-------------------------------------------\nG |- e x ==> t\n\nG |- e ==> forall as. x1:s1 -> ... xn:sn -> t\n\n\nG |- (forall as.S * y1 ... yn) <== T\nG |- (e y1 ... yn) ==> t\n```\n\n### Algorithmic Constraints\n\n```haskell\n--------------------------------------------------------------------\nsub :: (Type, Type) -> Cstr\n--------------------------------------------------------------------\nsub(B{v:p}, B{w:q}) = (v::p) => q[w:=v]\nsub(x1:s1 -> t1, x2:s2 -> t2) = sub (s2, s1) /\\ (x2 :: t2) => sub(t1[x1:=x2], t2)\n\n--------------------------------------------------------------------\nimp :: (Env, Cstr) -> Cstr\n--------------------------------------------------------------------\nimp (0, c) = c\nimp (G;x:t, c) = imp(G, all x t c)\n```\n\n```haskell\n-------------------------------------------------------\ncheck :: (Env, Expr, Type) -> C\n-------------------------------------------------------\ncheck (g, \\x.e, x:s -> t) = (x :: s) => c\n where\n c = check(g;x:s, e, t)\n\ncheck (g, let x e e', t') = c /\\ ((x::s) => c')\n where\n (c, s) = synth(g, e)\n c' = check(g;x:s, e', t')\n\ncheck (g, e, t) = sub(s, t)\n where\n (c, s) = synth(g, e)\n\n-----------------------------------------------------\nsynth :: (Env, Expr) -> (C, Type)\n-----------------------------------------------------\nsynth (g, x) = (TT, lookupEnv g x )\n\nsynth (g, c) = (TT, ty c )\n\nsynth (g, e y) = (ce /\\ cy, t[x := y])\n where\n (ce, x:s->t) = synth (g, e)\n cy = check (g, y)\n\nsynth (g, e:t) = (c, t )\n where\n c = check g e t\n```\n\n## Lang2\n\n### Examples\n\nBooleans\n\n```reason\n/*@ val cmp : (x:int, y:int) => bool{b| b <=> (x < y)} */\nlet cmp = (x, y) => {\n if (x < y) {\n true\n } else {\n false\n }\n}\n```\n\nPath Sensitivity\n\n```reason\n/*@ val abs : x:int => int[v| 0<=v && x <= v] */\nlet abs = (x) => {\n if x >= 0 {\n x\n } else {\n 0 - x\n };\n};\n\n/*@ val test : (a:int, b:int) => int[v|0<=v && a + b <= v] */\nlet test = (a, b) => {\n let t1 = abs(a);\n let t2 = abs(b);\n t1 + t2\n}\n```\n\nRecursion\n\n```reason\n/*@ val sum : n:int => int[v|0 <= v && n <= v] */\nlet rec sum = (n) => {\n if (n <= 0) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n}\n```\n\n### Types and Terms\n\n```txt\nt ::=\n | Bool{r} -- refined bool\n\ne ::= ...\n | if v e1 e2 -- branches\n | letrec f = (e:t) -- recursive binder with annot\n```\n\n### Declarative Checking\n\nEnvironments\n\n```\nG ::= ... | G, _:t -- extend with \"fresh\"/\"distinct\" binder\n```\n\nJudgments, Rules (as before)\n\n#### Subtyping\n\nSubtyping (as before)\n\n#### Checking\n\nRec binders must have type-sig\n\n```\n\n\n\n G |- v <== bool\n G, _:int{v} |- e1 <== t\nG, _:int{not v} |- e2 <== t\n--------------------------------[Chk-If]\nG |- if v e1 e2 <== t\n\nG; f:t1 |- e1 <== t1 G; f:t1 |- e2 <== t2\n------------------------------------------------[Chk-Rec]\nG |- letrec f = (e1:t1) in e2 <== t2\n```\n\n#### Synthesis\n\n**Note** Only when you add branches do you need\nthe singleton rule for variable lookup: without it \n`abs00.re` doesn't check!\n\n\n```\n--------------------------- [Syn-Var]\nG |- x ==> singleton(G, x)\n```\n\nwhere\n\n```\nsingleton(G, x) = v:b{p /\\ v = x} if G(x) = b[v|p]\n G(x) otherwise\n```\n\n### Algorithmic Constraints\n\n#### Check\n\n```haskell\ncheck g (EIf v e1 e2) t = ((x :: v) => c1) /\\ ((x :: ~v) => c2)\n where\n c1 = check g e1 t \n c2 = check g e2 t\n x = fresh\n\ncheck g (ERec f e1 t1 e2) t2 = c1 /\\ c2\n where\n c1 = check g' e1 t1\n c2 = check g' e2 t2\n g' = g; f:t1\n```\n\n#### Synth\n\nas before\n\n## Lang 3\n\n### Examples\n\n```reason\n/*@ val assert : bool[b|b] => int */\nlet assert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n if x >= 0 {\n x\n } else {\n 0 - x\n };\n};\n\n/*@ val main : int -> int */\nlet main = (y) => {\n let ya = abs(y); // neg: omit 'abs'\n let ok = 0 <= ya;\n assert(ok) // never fails\n}\n```\n\n```reason\n/*@ val assert : bool[b|b] => int */\nlet assert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n if x >= 0 {\n x\n } else {\n 0 - x\n };\n};\n\n/*@ val incf: int => int */\nlet incf = (x:nat) : nat => {\n /*@ val wrap : (int -> int[?]) -> int[?] */\n let wrap = (f) => {\n let r = f(x);\n r + 1\n };\n let res = wrap(abs);\n let ok = 0 < res;\n assert (ok)\n};\n```\n\n### Types and Terms\n\n```txt\np ::= ...\n | K(x1,...,xn) -- horn-variable\n\nr ::= ...\n | [?] -- unknown\n```\n\n### Declarative Checking\n\n\"fresh\" each annotation\n\n#### Subtyping\n\n(as before)\n\n#### Checking\n\n```txt\n t1 := fresh(s1)\nG; f:t1 |- e1 <== t1\nG; f:t1 |- e2 <== t2\n------------------------------------- [Chk-Rec]\nG |- letrec f = (e1:s1) in e2 <== t2\n```\n\n#### Synthesis\n\n```\nG |- e <== t t := fresh(s)\n--------------------------- [Syn-Ann]\nG |- e:s => t\n```\n\n### Algorithmic Constraints\n\n\n\"fresh\" each annotation\n\n```haskell\nfresh :: Env -> Type -> Type\nfresh g (B[r]) = B[freshR g B r]\n where\n r' = freshR g r\n\nfresh g (x:s -> t) = x:s' -> t'\n where\n s' = fresh g s\n t' = fresh (g; x:s') t\n\nfreshR :: Env -> Base -> Reft -> Reft\nfreshR _ _ [v|p] = [v|p]\nfreshR g B [?] = [v|k(v, x1...)]\n where\n v = freshV\n k = freshK [B, s1...]\n (x1:s1...) = g\n```\n\nRest is swept under the horn solving rug?\n\n#### Check\n\n```haskell\ncheck g (ERec f e1 s1 e2) t2 = c1 /\\ c2\n where\n c1 = check g' e1 t1\n c2 = check g' e2 t2\n g' = g; f:t1\n t1 = fresh s1\n```\n\n#### Synth\n\n```haskell\nsynth (g, e:s) = (c, t)\n where\n c = check g e t\n t = fresh s\n```\n\n## Lang 4\n\n### Examples\n\nsee `tests/L4/{pos, neg}`\n\n### Types and Terms\n\n```txt\nG ::= ...\n | G, a -- ^ type variables\n\nt :== ...\n | a[r] -- ^ refined base type\n | all a. t -- ^ forall types (quantifiers at the top)\n\ne :== ...\n | Λ a. e -- ^ type abstraction\n | e [t] -- ^ type application\n```\n\n### Declarative Checking\n\nThe real hassle here is the *elaboration* step that adds the explicit\ntype abstraction and application.\n\n#### Subtyping\n\n```txt\nG, v:int{p} |- q[w:=v]\n-------------------------[Sub-Base]\nG |- b[v|p] <: b[w|q]\n\nG |- t1 <: t2 [a2 := a1]\n------------------------------[Sub-All]\nG |- all a1. t1 <: all a2. t2\n```\n\n#### Checking\n\n```txt\nG, a |- e <== s\n------------------------ [Chk-TLam]\nG |- Λ a. e <== all a. s\n```\n\n#### Synthesis \n\n```txt\nG |- e ==> all a. s\n------------------------- [Syn-TApp]\nG |- e[t] ==> s [ a := t]\n```\n\n### Algorithmic Constraints\n\n#### Check\n\n```haskell\ncheck g (ETLam a e _) (TAll b t) | a == b = do\n check g e t\n```\n\n#### Synth\n\n```haskell\nsynth g (ETApp e t l) = do\n (ce, te) <- synth g e\n case te of\n TAll a s -> do tt <- Misc.traceShow \"REFRESH\" <$> refresh l g t\n return (ce, tsubst a tt s)\n _ -> failWith \"Type Application to non-forall\" l\n```\n\n## Lang 5\n\n### Examples\n\ncontainers\n\n- head00\n\ndata-refinement\n\n- tuple00\n- olist00\n\nmeasures\n\n- head01\n- tail01\n- append\n\n### Types and Terms\n\n```txt\nd ::= [C1:t1,...] -- ^ data-definition\n\nG ::= ...\n | G, d -- ^ data-definitions\n\na := C(x1...) => e -- ^ switch-alternative\n\ne :== ...\n | C(x1...) -- ^ constructor\n | switch(x){ a1...} -- ^ destructor\n```\n\n### Declarative Checking\n\n#### Subtyping\n\n```txt\nG,v:int{p} |- q[w:=v] G |- si <: ti\n-----------------------------------------[Sub-TCon]\nG |- (C s1...)[v|p] <: (C t1...)[w|q]\n```\n\n#### Checking\n\nEnvironment Extension\n\n```txt\nG(y) = s\n-----------------------------[G-Scr]\nG | y + 0 * t ~~> G, y:s/\\t\n\nG, z:s | y + zs * t[z/x] ~~> G'\n---------------------------------[G-Ext]\nG | y + z;zs * (x:s -> t) ~~> G'\n```\n\n```txt\nG | y |- a_i <== t\n----------------------------[Chk-Switch]\nG |- switch y {a_1...} <== t\n\n\nunfold(G, c, y) === s G | y + z... * s ~~> G' G' |- e <== t\n----------------------------------------------------------------- [Chk-Alt]\nG | y |- C z... -> e <== t\n\n\nG(y) === tc[ts] G(c) === all as. t\n------------------------------------- [Unfold]\nunfold(g, c, y) === t [as := ts]\n```\n\n\n#### Synthesis\n\n```\nsingleton(G, x) = v:b [p /\\ v = x] if G(x) = b[v|p]\n v:(c ts)[p /\\ v = x] if G(x) = c ts\n G(x) otherwise\n```\n\n### Algorithmic Constraints\n\n#### Check\n\n#### Synth\n" }, { "path": "README.md", "content": "# SPRITE\n\nA tutorial-style implementation of liquid/refinement types for a subset of Ocaml/Reason.\n\n## Install\n\n**1. Get Z3** \n\n[Download from here](https://github.com/Z3Prover/z3/releases) and make sure `z3` is on your `$PATH`\n\n**2. Clone the repository**\n\n```\n$ git clone git@github.com:ranjitjhala/sprite-lang.git\n$ cd sprite-lang\n```\n\n**3. Build** \n\nUsing `stack` \n\n```\n$ stack build\n```\n\nor \n\n```\n$ cabal v2-build\n```\n\n## Run on a single file\n\n```\n$ stack exec -- sprite 8 test/L8/pos/listSet.re\n```\n\nThe `8` indicates the *language-level* -- see below.\n\n## Horn VC\n\nWhen you run `sprite N path/to/file.re` \nthe generated Horn-VC is saved in `path/to/.liquid/file.re.smt2`.\n\nSo for example \n\n```\n$ stack exec -- sprite 8 test/L8/pos/listSet.re\n```\n\nwill generate a VC in \n\n```\ntest/L8/pos/.liquid/listSet.re.smt2\n``` \n\n## Languages\n\n- Lang1 : STLC + Annot (refinements 101)\n- Lang2 : \"\" + Branches (path-sensitivity)\n- Lang3 : \"\" + ?-refinements (inference + qual-fixpoint)\n- Lang4 : \"\" + T-Poly (type-polymorphism)\n- Lang5 : \"\" + Data (datatypes & measures)\n- Lang6 : \"\" + R-Poly (refinement-polymorphism)\n- Lang7 : \"\" + Termination (metrics + invariants)\n- Lang8 : \"\" + Reflection (proofs)\n" }, { "path": "Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "app/Main.hs", "content": "\n{-# LANGUAGE ScopedTypeVariables#-}\nmodule Main where\n\nimport System.Environment ( getArgs ) \nimport System.Exit ()\nimport Control.Monad (void)\nimport qualified Language.Fixpoint.Types as F \nimport Language.Sprite.Common (crashUserError, doOrDie)\nimport Language.Sprite.Common.UX ()\nimport qualified Language.Sprite.L1 as L1\nimport qualified Language.Sprite.L2 as L2\nimport qualified Language.Sprite.L3 as L3\nimport qualified Language.Sprite.L4 as L4\nimport qualified Language.Sprite.L5 as L5\nimport qualified Language.Sprite.L6 as L6\nimport qualified Language.Sprite.L8 as L8\n\n---------------------------------------------------------------------------\nmain :: IO ()\n---------------------------------------------------------------------------\nmain = do \n args <- parseArgs\n case args of \n Just (i, f) -> doOrDie (sprite i f)\n Nothing -> crashUserError \"Invalid options!\" []\n\nparseArgs :: IO (Maybe (Int, FilePath))\nparseArgs = do\n args <- getArgs\n case args of \n [f] -> return $ Just (0, f)\n n:f:_ -> return $ Just (read n :: Int, f)\n _ -> return Nothing \n\nsprite :: Int -> FilePath -> IO ()\nsprite 1 = L1.sprite\nsprite 2 = L2.sprite\nsprite 3 = L3.sprite\nsprite 4 = L4.sprite\nsprite 5 = L5.sprite\nsprite 6 = L6.sprite\nsprite _ = L8.sprite\n\n\n\n" }, { "path": "cabal.project", "content": "packages: .\n\nsource-repository-package\n type: git\n location: https://github.com/ucsd-progsys/liquid-fixpoint\n tag: 794aed1388442e64ced07a7f53c5aba14ce01a24\n\n\n" }, { "path": "package.yaml", "content": "name: sprite\nversion: 0.2.0.0\ngithub: \"ranjitjhala/sprite\"\nlicense: MIT\nauthor: \"Ranjit Jhala\"\nmaintainer: \"jhala@cs.ucsd.edu\"\ncopyright: \"2019 Ranjit Jhala\"\n\nextra-source-files:\n- README.md\n- ChangeLog.md\n\n# Metadata used when publishing your package\n# synopsis: Short description of your package\n# category: Web\n\n# To avoid duplicated efforts in documentation and dealing with the\n# complications of embedding Haddock markup inside cabal files, it is\n# common to point users to the README.md file.\ndescription: Please see the README on GitHub at \n\ndependencies:\n- base >= 4.9.1.0 && < 5\n- liquid-fixpoint >= 0.9\n- cmdargs\n- process\n- directory\n- filepath\n- containers\n- unordered-containers\n- deepseq\n- pretty\n- parsec\n- parser-combinators\n- megaparsec >= 7.0.0 && < 10\n- mtl\n\nlibrary:\n source-dirs: src\n\nexecutables:\n sprite:\n main: Main.hs\n source-dirs: app\n ghc-options:\n - -threaded\n - -rtsopts\n - -with-rtsopts=-N\n dependencies:\n - sprite\n\ntests:\n liquid-tutorial-test:\n main: Spec.hs\n source-dirs: test\n ghc-options:\n - -threaded\n - -rtsopts\n - -with-rtsopts=-N\n dependencies:\n - sprite\n - tasty-rerun\n - mtl\n - stm\n - tasty\n - tasty-ant-xml\n - tasty-hunit\n - tasty-rerun\n - transformers\n" }, { "path": "sprite.cabal", "content": "cabal-version: 1.12\n\n-- This file has been generated from package.yaml by hpack version 0.36.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: sprite\nversion: 0.2.0.0\ndescription: Please see the README on GitHub at \nhomepage: https://github.com/ranjitjhala/sprite#readme\nbug-reports: https://github.com/ranjitjhala/sprite/issues\nauthor: Ranjit Jhala\nmaintainer: jhala@cs.ucsd.edu\ncopyright: 2019 Ranjit Jhala\nlicense: MIT\nlicense-file: LICENSE\nbuild-type: Simple\nextra-source-files:\n README.md\n ChangeLog.md\n\nsource-repository head\n type: git\n location: https://github.com/ranjitjhala/sprite\n\nlibrary\n exposed-modules:\n Language.Sprite.Common\n Language.Sprite.Common.Misc\n Language.Sprite.Common.Parse\n Language.Sprite.Common.UX\n Language.Sprite.L1\n Language.Sprite.L1.Check\n Language.Sprite.L1.Constraints\n Language.Sprite.L1.Parse\n Language.Sprite.L1.Prims\n Language.Sprite.L1.Types\n Language.Sprite.L2\n Language.Sprite.L2.Check\n Language.Sprite.L2.Constraints\n Language.Sprite.L2.Parse\n Language.Sprite.L2.Prims\n Language.Sprite.L2.Types\n Language.Sprite.L3\n Language.Sprite.L3.Check\n Language.Sprite.L3.Constraints\n Language.Sprite.L3.Parse\n Language.Sprite.L3.Prims\n Language.Sprite.L3.Types\n Language.Sprite.L4\n Language.Sprite.L4.Check\n Language.Sprite.L4.Constraints\n Language.Sprite.L4.Elaborate\n Language.Sprite.L4.Parse\n Language.Sprite.L4.Prims\n Language.Sprite.L4.Types\n Language.Sprite.L5\n Language.Sprite.L5.Check\n Language.Sprite.L5.Constraints\n Language.Sprite.L5.Elaborate\n Language.Sprite.L5.Parse\n Language.Sprite.L5.Prims\n Language.Sprite.L5.Types\n Language.Sprite.L6\n Language.Sprite.L6.Check\n Language.Sprite.L6.Constraints\n Language.Sprite.L6.Elaborate\n Language.Sprite.L6.Parse\n Language.Sprite.L6.Prims\n Language.Sprite.L6.Types\n Language.Sprite.L8\n Language.Sprite.L8.Check\n Language.Sprite.L8.Constraints\n Language.Sprite.L8.Elaborate\n Language.Sprite.L8.Parse\n Language.Sprite.L8.Prims\n Language.Sprite.L8.Reflect\n Language.Sprite.L8.Types\n other-modules:\n Paths_sprite\n hs-source-dirs:\n src\n build-depends:\n base >=4.9.1.0 && <5\n , cmdargs\n , containers\n , deepseq\n , directory\n , filepath\n , liquid-fixpoint >=0.9\n , megaparsec >=7.0.0 && <10\n , mtl\n , parsec\n , parser-combinators\n , pretty\n , process\n , unordered-containers\n default-language: Haskell2010\n\nexecutable sprite\n main-is: Main.hs\n other-modules:\n Paths_sprite\n hs-source-dirs:\n app\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends:\n base >=4.9.1.0 && <5\n , cmdargs\n , containers\n , deepseq\n , directory\n , filepath\n , liquid-fixpoint >=0.9\n , megaparsec >=7.0.0 && <10\n , mtl\n , parsec\n , parser-combinators\n , pretty\n , process\n , sprite\n , unordered-containers\n default-language: Haskell2010\n\ntest-suite liquid-tutorial-test\n type: exitcode-stdio-1.0\n main-is: Spec.hs\n other-modules:\n Paths_sprite\n hs-source-dirs:\n test\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends:\n base >=4.9.1.0 && <5\n , cmdargs\n , containers\n , deepseq\n , directory\n , filepath\n , liquid-fixpoint >=0.9\n , megaparsec >=7.0.0 && <10\n , mtl\n , parsec\n , parser-combinators\n , pretty\n , process\n , sprite\n , stm\n , tasty\n , tasty-ant-xml\n , tasty-hunit\n , tasty-rerun\n , transformers\n , unordered-containers\n default-language: Haskell2010\n" }, { "path": "sprite.cabal.orig", "content": "cabal-version: 1.12\n\n-- This file has been generated from package.yaml by hpack version 0.33.0.\n--\n-- see: https://github.com/sol/hpack\n--\n-- hash: d386618d61376de83f983dcbccf020e50d0bbac3bde98b667b01117472310880\n\nname: sprite\nversion: 0.1.0.0\ndescription: Please see the README on GitHub at \nhomepage: https://github.com/ranjitjhala/sprite#readme\nbug-reports: https://github.com/ranjitjhala/sprite/issues\nauthor: Ranjit Jhala\nmaintainer: jhala@cs.ucsd.edu\ncopyright: 2019 Ranjit Jhala\nlicense: MIT\nlicense-file: LICENSE\nbuild-type: Simple\nextra-source-files:\n README.md\n ChangeLog.md\n\nsource-repository head\n type: git\n location: https://github.com/ranjitjhala/sprite\n\nlibrary\n exposed-modules:\n Language.Sprite.Common\n Language.Sprite.Common.Misc\n Language.Sprite.Common.Parse\n Language.Sprite.Common.UX\n Language.Sprite.L1\n Language.Sprite.L1.Check\n Language.Sprite.L1.Constraints\n Language.Sprite.L1.Parse\n Language.Sprite.L1.Prims\n Language.Sprite.L1.Types\n Language.Sprite.L2\n Language.Sprite.L2.Check\n Language.Sprite.L2.Constraints\n Language.Sprite.L2.Parse\n Language.Sprite.L2.Prims\n Language.Sprite.L2.Types\n Language.Sprite.L3\n Language.Sprite.L3.Check\n Language.Sprite.L3.Constraints\n Language.Sprite.L3.Parse\n Language.Sprite.L3.Prims\n Language.Sprite.L3.Types\n Language.Sprite.L4\n Language.Sprite.L4.Check\n Language.Sprite.L4.Constraints\n Language.Sprite.L4.Elaborate\n Language.Sprite.L4.Parse\n Language.Sprite.L4.Prims\n Language.Sprite.L4.Types\n Language.Sprite.L5\n Language.Sprite.L5.Check\n Language.Sprite.L5.Constraints\n Language.Sprite.L5.Elaborate\n Language.Sprite.L5.Parse\n Language.Sprite.L5.Prims\n Language.Sprite.L5.Types\n Language.Sprite.L6\n Language.Sprite.L6.Check\n Language.Sprite.L6.Constraints\n Language.Sprite.L6.Elaborate\n Language.Sprite.L6.Parse\n Language.Sprite.L6.Prims\n Language.Sprite.L6.Types\n Language.Sprite.L8\n Language.Sprite.L8.Check\n Language.Sprite.L8.Constraints\n Language.Sprite.L8.Elaborate\n Language.Sprite.L8.Parse\n Language.Sprite.L8.Prims\n Language.Sprite.L8.Reflect\n Language.Sprite.L8.Types\n other-modules:\n Paths_sprite\n hs-source-dirs:\n src\n build-depends:\n base >= 4.9.1.0 && < 5\n , cmdargs\n , containers\n , deepseq\n , directory\n , filepath\n , liquid-fixpoint >=0.8.10.7.0\n , megaparsec >= 7.0.0 && < 10\n , mtl\n , parsec\n , parser-combinators\n , pretty\n , process\n , unordered-containers\n default-language: Haskell2010\n\nexecutable sprite\n main-is: Main.hs\n other-modules:\n Paths_sprite\n hs-source-dirs:\n app\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends:\n base >=4.7 && <5\n , cmdargs\n , containers >= 0.5\n , deepseq\n , directory\n , filepath\n , liquid-fixpoint >=0.8\n , megaparsec >=7.0.0 && < 10\n , mtl\n , parsec\n , parser-combinators\n , pretty\n , process\n , sprite\n , unordered-containers\n default-language: Haskell2010\n\ntest-suite liquid-tutorial-test\n type: exitcode-stdio-1.0\n main-is: Spec.hs\n other-modules:\n Paths_sprite\n hs-source-dirs:\n test\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends:\n base >=4.7 && <5\n , cmdargs\n , containers >= 0.5\n , deepseq\n , directory\n , filepath\n , liquid-fixpoint >=0.8\n , megaparsec >=7.0.0 && < 10\n , mtl\n , parsec\n , parser-combinators\n , pretty\n , process\n , sprite\n , stm\n , tasty\n , tasty-ant-xml\n , tasty-hunit\n , tasty-rerun\n , transformers\n , unordered-containers\n default-language: Haskell2010\n" }, { "path": "src/Language/Sprite/Common/Misc.hs", "content": "module Language.Sprite.Common.Misc where\n\nimport qualified Data.Map as M\nimport qualified Data.List as L\n-- import Data.Monoid\nimport Data.Maybe (fromMaybe)\nimport Data.Char (isSpace)\nimport Control.Exception\nimport Control.Monad\nimport Text.Printf\nimport System.Directory\nimport System.Exit\nimport System.FilePath\nimport System.IO\nimport System.Process\nimport System.Timeout\nimport System.Console.CmdArgs.Verbosity (whenLoud)\nimport Debug.Trace (trace)\n\nsafeZip :: [a] -> [b] -> Maybe [(a, b)]\nsafeZip xs ys\n | length xs == length ys = Just (zip xs ys)\n | otherwise = Nothing\n\n--------------------------------------------------------------------------------\n(>->) :: (a -> Either e b) -> (b -> c) -> a -> Either e c\n--------------------------------------------------------------------------------\nf >-> g = f >=> safe g\n where\n safe :: (a -> b) -> a -> Either c b\n safe h x = Right (h x)\n\ngroupBy :: (Ord k) => (a -> k) -> [a] -> [(k, [a])]\ngroupBy f = M.toList . L.foldl' (\\m x -> inserts (f x) x m) M.empty\n\ninserts :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v]\ninserts k v m = M.insert k (v : M.findWithDefault [] k m) m\n\nmapSnd :: (b -> c) -> (a, b) -> (a, c)\nmapSnd f (x, y) = (x, f y)\n\n-- >>> dupBy fst [(1, \"one\"), (2, \"two\"), (3, \"three\"), (1, \"uno\")]\n-- [[(1,\"uno\"),(1,\"one\")]]\n--\n-- >>> dupBy fst [(1, \"one\"), (2, \"two\"), (3, \"three\")]\n-- []\n\ndupBy :: (Ord k) => (a -> k) -> [a] -> [[a]]\ndupBy f xs = [ xs' | (_, xs') <- groupBy f xs, 2 <= length xs' ]\n\ntrim :: String -> String\ntrim = f . f where f = reverse . dropWhile isSpace\n\ntrimEnd :: String -> String\ntrimEnd = reverse . dropWhile isSpace . reverse\n\nexecuteShellCommand :: FilePath -> String -> Int -> IO ExitCode\nexecuteShellCommand logF cmd n = fromMaybe (ExitFailure 100) <$> body\n where\n body = timeout n . withFile logF AppendMode $ \\h -> do\n let p = (shell cmd) {std_out = UseHandle h, std_err = UseHandle h}\n (_,_,_,ph) <- createProcess p\n waitForProcess ph\n\ndata Phase = Start | Stop deriving (Show)\n\nphase :: Phase -> String -> IO ()\nphase p msg = putStrLn $ printf \"**** %s : %s **************************************\" (show p) msg\n\nwriteLoud :: String -> IO ()\nwriteLoud s = whenLoud $ putStrLn s >> hFlush stdout\n\nensurePath :: FilePath -> IO ()\nensurePath = createDirectoryIfMissing True . takeDirectory\n\nsafeReadFile :: FilePath -> IO (Either String String)\nsafeReadFile f = (Right <$> readFile f) `catch` handleIO f\n\nhandleIO :: FilePath -> IOException -> IO (Either String a)\nhandleIO f e = return . Left $ \"Warning: Couldn't open \" <> f <> \": \" <> show e\n\ntraceShow :: (Show a) => String -> a -> a\ntraceShow msg x = x -- trace (printf \"TRACE: %s = %s\" msg (show x)) x\n\nsafeHead :: a -> [a] -> a\nsafeHead def [] = def\nsafeHead _ (x:_) = x\n\ngetRange :: Int -> Int -> [a] -> [a]\ngetRange i1 i2\n = take (i2 - i1 + 1)\n . drop (i1 - 1)" }, { "path": "src/Language/Sprite/Common/Parse.hs", "content": "module Language.Sprite.Common.Parse where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Set as S\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport qualified Language.Fixpoint.Types.Visitor as FV\nimport Text.Megaparsec ( (<|>) )\n\nwithSpan' :: FP.Parser (F.SrcSpan -> a) -> FP.Parser a\nwithSpan' p = do\n F.Loc l1 l2 f <- FP.located p\n pure (f (F.SS l1 l2))\n\n-- | `identifier` parses identifiers: lower-case alphabets followed by alphas or digits\nidentifier :: FP.Parser F.Symbol\nidentifier = FP.lowerIdP\n\nidentifier' :: FP.Parser F.Symbol\nidentifier' = FP.lowerIdP <|> FP.upperIdP\n\nparens = FP.parens\ncolon = FP.colon\ncomma = FP.comma\nbraces = FP.braces\nreserved = FP.reserved\nbrackets = FP.brackets\nwhiteSpace = FP.spaces\nreservedOp = FP.reservedOp\n\n-- | list of reserved words\nkeywords :: S.Set String \nkeywords = S.fromList\n [ \"if\" , \"else\"\n , \"true\" , \"false\"\n , \"let\" , \"in\"\n , \"int\"\n ]\n\nisKey :: String -> Bool\nisKey x = S.member x keywords\n\n\n---------------------------------------------------------------------------------------------------------\n-- | Pesky hack to work around FP.exprP parsing \"foo(x, y, z)\" as \"foo ((,,) x y z)\"\n---------------------------------------------------------------------------------------------------------\nmyPredP :: FP.Parser F.Expr\nmyPredP = unTupleApp <$> FP.predP\n\nmyExprP :: FP.Parser F.Expr\nmyExprP = unTupleApp <$> FP.exprP \n\nunTupleApp :: F.Expr -> F.Expr\nunTupleApp = FV.mapExpr go\n where\n go e@(F.EApp {}) = Mb.fromMaybe e (unTuple e)\n go e = e \n\nunTuple :: F.Expr -> Maybe F.Expr\nunTuple e = \n case F.splitEApp e of\n (f, [arg]) -> \n case F.splitEApp arg of\n (t, args) -> if isTupleCon (length args) t \n then Just (F.eApps f args)\n else Nothing\n _ -> Nothing\n\nisTupleCon :: Int -> F.Expr -> Bool\nisTupleCon n (F.EVar x) = x == tupleSym n\nisTupleCon _ _ = False \n\ntupleSym :: Int -> F.Symbol\ntupleSym n = F.symbol $ \"(\" ++ replicate (n-1) ',' ++ \")\" \n---------------------------------------------------------------------------------------------------------\n" }, { "path": "src/Language/Sprite/Common/UX.hs", "content": "-- | This module contains the code for all the user (programmer) facing\n-- aspects, i.e. error messages, source-positions, overall results.\n\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE DeriveGeneric #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Eta reduce\" #-}\n\nmodule Language.Sprite.Common.UX\n (\n -- * Extraction from Source file\n readFileSpan\n\n -- * Constructing spans\n , posSpan\n , junkSpan\n\n -- * Success and Failure\n , UserError\n , eMsg\n , eSpan\n , Result\n\n -- * Throwing & Handling Errors\n , mkError\n , spanError\n , abort\n , panic\n , panicS\n , renderErrors\n , fpUserError\n\n -- * Pretty Printing\n , Text\n , PPrint (..)\n , tshow\n ) where\n\nimport Control.Exception\nimport Control.DeepSeq\nimport Data.Typeable\n-- import qualified Data.List as L\nimport GHC.Generics\nimport Text.Printf (printf)\nimport qualified Text.PrettyPrint.HughesPJ as PJ\nimport qualified Language.Fixpoint.Misc as Misc\nimport qualified Language.Fixpoint.Types as F\nimport Language.Fixpoint.Types (PPrint (..))\nimport Language.Sprite.Common.Misc\n\ntype Text = PJ.Doc\n\ntshow :: (Show a) => a -> PJ.Doc\ntshow = PJ.text . show\n\n--------------------------------------------------------------------------------\n-- | Source Span Representation\n--------------------------------------------------------------------------------\n\n-- instance NFData F.SrcSpan\n\ninstance Semigroup F.SrcSpan where\n (<>) = mappendSpan\n\ninstance Monoid F.SrcSpan where\n mempty = junkSpan\n\nmappendSpan :: F.SrcSpan -> F.SrcSpan -> F.SrcSpan\nmappendSpan s1 s2\n | s1 == junkSpan = s2\n | s2 == junkSpan = s1\n | otherwise = F.SS (F.sp_start s1) (F.sp_stop s2)\n\nspanInfo :: F.SrcSpan -> (FilePath, Int, Int, Int, Int)\nspanInfo s = (f, F.unPos l1, F.unPos c1, F.unPos l2, F.unPos c2)\n where\n (f,l1,c1) = F.sourcePosElts (F.sp_start s)\n (_,l2,c2) = F.sourcePosElts (F.sp_stop s)\n\n--------------------------------------------------------------------------------\n-- | Source Span Extraction\n--------------------------------------------------------------------------------\nreadFileSpan :: F.SrcSpan -> IO String\n--------------------------------------------------------------------------------\nreadFileSpan sp = getSpan sp <$> readFile (spanFile sp)\n\nspanFile :: F.SrcSpan -> FilePath\nspanFile = Misc.fst3 . F.sourcePosElts . F.sp_start\n\ngetSpan :: F.SrcSpan -> String -> String\ngetSpan sp\n | l1 == l2 = getSpanSingle l1 c1 c2\n | otherwise = getSpanMulti l1 l2\n where\n (_, l1, c1, l2, c2) = spanInfo sp\n\ngetSpanSingle :: Int -> Int -> Int -> String -> String\ngetSpanSingle l c1 c2\n = highlight l c1 c2\n . safeHead \"\"\n . getRange l l\n . lines\n\ngetSpanMulti :: Int -> Int -> String -> String\ngetSpanMulti l1 l2\n = highlights l1\n . getRange l1 l2\n . lines\n\nhighlight :: Int -> Int -> Int -> String -> String\nhighlight l c1 c2 s = unlines\n [ cursorLine l s\n , replicate (12 + c1) ' ' ++ replicate (1 + c2 - c1) '^'\n ]\n\nhighlights :: Int -> [String] -> String\nhighlights i ls = unlines $ zipWith cursorLine [i..] ls\n\ncursorLine :: Int -> String -> String\ncursorLine l s = printf \"%s| %s\" (lineString l) s\n\nlineString :: Int -> String\nlineString n = replicate (10 - nD) ' ' ++ nS\n where\n nS = show n\n nD = length nS\n\n--------------------------------------------------------------------------------\n-- | Source Span Construction\n--------------------------------------------------------------------------------\nposSpan :: F.SourcePos -> F.SrcSpan\n--------------------------------------------------------------------------------\nposSpan p = F.SS p p\n\njunkSpan :: F.SrcSpan\njunkSpan = F.dummySpan -- posSpan (initialPos \"unknown\")\n\n--------------------------------------------------------------------------------\n-- | Representing overall failure / success\n--------------------------------------------------------------------------------\ntype Result a = Either [UserError] a\n\n--------------------------------------------------------------------------------\n-- | Representing (unrecoverable) failures\n--------------------------------------------------------------------------------\ndata UserError = Error\n { eMsg :: !Text\n , eSpan :: !F.SrcSpan\n }\n deriving (Show, Typeable, Generic)\n\ninstance F.PPrint UserError where\n pprintTidy k = F.pprintTidy k . userErrorFP\n\ninstance F.Fixpoint UserError where\n toFix = eMsg\n\ninstance F.Loc UserError where\n srcSpan = eSpan\n\ninstance NFData UserError\ninstance Exception [UserError]\n\nfpUserError :: F.Error1 -> UserError\nfpUserError e = mkError (F.errMsg e) (F.errLoc e)\n\nuserErrorFP :: UserError -> F.Error\nuserErrorFP (Error d sp) = F.err sp d\n\n--------------------------------------------------------------------------------\npanic :: PJ.Doc -> F.SrcSpan -> a\n--------------------------------------------------------------------------------\npanic msg sp = throw [Error msg sp]\n\npanicS :: String -> F.SrcSpan -> a\npanicS = panic . PJ.text\n\n--------------------------------------------------------------------------------\nabort :: UserError -> b\n--------------------------------------------------------------------------------\nabort e = throw [e]\n\n--------------------------------------------------------------------------------\nmkError :: Text -> F.SrcSpan -> UserError\n--------------------------------------------------------------------------------\nmkError = Error\n\n--------------------------------------------------------------------------------\nspanError :: F.SrcSpan -> UserError\n--------------------------------------------------------------------------------\nspanError = mkError mempty\n\nrenderErrors :: [UserError] -> IO Text\nrenderErrors es = do\n errs <- mapM renderError es\n return $ PJ.vcat (\"Errors found!\" : \"\" : errs)\n-- return $ L.intercalate \"\\n\" (\"Errors found!\" : errs)\n\nrenderError :: UserError -> IO Text\nrenderError e = do\n let sp = F.srcSpan e\n snippet <- readFileSpan sp\n return $ PJ.vcat [ F.pprint sp PJ.<> \":\" PJ.<+> eMsg e\n , \" \"\n , \" \"\n , PJ.text snippet ]\n" }, { "path": "src/Language/Sprite/Common.hs", "content": "\n{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Eta reduce\" #-}\n\n-- | Some types that are common to all languages -------------------------------\n\nmodule Language.Sprite.Common where\n\nimport System.Exit ( ExitCode, exitWith )\nimport Control.Exception ( catch )\nimport Control.Monad (when)\nimport qualified Data.Maybe as Mb\nimport qualified Text.PrettyPrint.HughesPJ as PJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Horn.Solve as H\nimport qualified Language.Fixpoint.Types.Config as FC\nimport qualified Language.Fixpoint.Types.Errors as F\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Misc as F\nimport qualified Language.Fixpoint.Utils.Files as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Fixpoint.Solver.Interpreter (Simplifiable(simplify))\n\ntype SrcCstr = H.Cstr UX.UserError\ntype SrcQuery = H.Query UX.UserError\ntype SrcResult = F.FixResult UX.UserError\ntype SrcHVar = H.Var UX.UserError\n\n---------------------------------------------------------------------------\nquery :: [F.Qualifier] -> [H.Var a] -> H.Cstr a -> H.Query a\n---------------------------------------------------------------------------\nquery qs ks c = H.Query qs ks c mempty mempty mempty mempty mempty mempty\n\n---------------------------------------------------------------------------\nbind :: F.SrcSpan -> F.Symbol -> F.Sort -> H.Pred -> H.Bind UX.UserError\n---------------------------------------------------------------------------\nbind sp x t p = H.Bind x t p (UX.mkError mempty sp)\n\n---------------------------------------------------------------------------\ncrash :: [UX.UserError] -> String -> SrcResult\n---------------------------------------------------------------------------\ncrash errs = F.Crash [(e, Nothing) | e <- errs]\n\n\n\nclass Label t where\n label :: t a -> a\n\n\n---------------------------------------------------------------------------\ndoOrDie :: IO a -> IO a\n---------------------------------------------------------------------------\ndoOrDie act = act `catch` crashFPError \"Parse error\"\n `catch` crashUserError \"Unexpected error\"\n\ncrashFPError :: String -> F.Error -> IO a\ncrashFPError msg ferr = crashUserError msg (UX.fpUserError <$> F.errs (F.traceShow \"WTF\" ferr))\n\ncrashUserError :: String -> [UX.UserError] -> IO a\ncrashUserError msg es = exitWith =<< resultExit (F.Crash [(e, Nothing) | e <- es] msg)\n\n---------------------------------------------------------------------------\ncheckValid :: FilePath -> SrcQuery -> IO SrcResult\n---------------------------------------------------------------------------\ncheckValid f = checkValidWithCfg f fpConfig\n\n---------------------------------------------------------------------------\ncheckValidPLE :: FilePath -> SrcQuery -> IO SrcResult\n---------------------------------------------------------------------------\ncheckValidPLE f q = do\n pleCfg <- FC.withPragmas fpConfig [\"--rewrite\"]\n checkValidWithCfg f pleCfg q\n\ncheckValidWithCfg :: FilePath -> FC.Config -> SrcQuery -> IO SrcResult\ncheckValidWithCfg f cfg q0 = do\n let q = simplifyQuery q0\n dumpQuery f q\n fmap snd . F.resStatus <$> H.solve cfg q\n\nfpConfig :: FC.Config\nfpConfig = FC.defConfig\n { FC.eliminate = FC.Some }\n\ndumpQuery :: FilePath -> SrcQuery -> IO ()\ndumpQuery f q = when True $ do\n putStrLn (F.wrapStars \"BEGIN: Horn VC\")\n let smtFile = F.extFileName F.Smt2 f\n F.ensurePath smtFile\n writeFile smtFile (PJ.render . F.pprint $ q)\n putStrLn (F.wrapStars \"END: Horn VC\")\n\nsimplifyQuery :: H.Query a -> H.Query a\nsimplifyQuery q = q { H.qCstr = simplifyConstraint (H.qCstr q) }\n\nsimplifyConstraint :: H.Cstr a -> H.Cstr a\nsimplifyConstraint c = Mb.fromMaybe trivial (go c)\n where\n trivial = H.CAnd []\n go :: H.Cstr a -> Maybe (H.Cstr a)\n go (H.CAnd cs) = case Mb.mapMaybe go cs of\n [] -> Nothing\n [c] -> Just c\n cs' -> Just (H.CAnd cs')\n go (H.All b c) = H.All b <$> go c\n go (H.Head (H.Reft p) _)\n | F.isTautoPred p = Nothing\n go c = Just c\n\n---------------------------------------------------------------------------\nresultExit :: SrcResult -> IO ExitCode\n---------------------------------------------------------------------------\nresultExit r = do\n F.colorStrLn (F.colorResult r) (resultStr r)\n case resultErrs r of\n [] -> return ()\n es -> putStrLn . PJ.render =<< UX.renderErrors es\n return (F.resultExit r)\n\nresultErrs :: SrcResult -> [UX.UserError]\nresultErrs (F.Unsafe _ es) = es\nresultErrs (F.Crash es _) = fst <$> es\nresultErrs _ = []\n\nresultStr :: SrcResult -> String\nresultStr (F.Safe {}) = \"Safe\"\nresultStr (F.Unsafe {}) = \"Unsafe\"\nresultStr (F.Crash _ msg) = \"Crash!: \" ++ msg\n\n---------------------------------------------------------------------------------\nnat :: F.Expr -> F.Expr\nnat p = F.PAtom F.Le (F.ECon (F.I 0)) p\n\nlt :: F.Expr -> F.Expr -> F.Expr\nlt e1 e2 = F.PAtom F.Lt e1 e2\n\neq :: (F.Expression a, F.Expression b) => a -> b -> F.Expr\neq e1 e2 = F.PAtom F.Eq (F.expr e1) (F.expr e2)\n\n---------------------------------------------------------------------------------\n\n-- predApp f xs = F.eApps (F.expr f) (F.expr <$> xs)\n\npredApp :: (F.Expression e) => F.Symbol -> [e] -> F.Expr\npredApp f xs = F.eApps (F.expr pn) (F.expr f : (F.expr <$> xs))\n where\n pn = pappSym n\n n = length xs\n\npappSym :: Int -> F.Symbol\npappSym n = F.symbol $ \"papp\" ++ show n\n\npappSortArgs :: Int -> [F.Sort] -> F.Sort\npappSortArgs tvars args = F.mkFFunc tvars $ ptycon : args ++ [F.boolSort]\n where\n ptycon = F.fAppTC predFTyCon args\n\npappSort :: Int -> F.Sort\npappSort n = pappSortArgs n (pappArgs n)\n\npappArgs :: Int -> [F.Sort]\npappArgs n = F.FVar <$> [0 .. n-1]\n\npappQual :: Int -> F.Qualifier\npappQual n = F.mkQ name (vt : args ++ [(p, pt)]) pred pos\n where\n pt = F.fAppTC predFTyCon (snd <$> args ++ [vt])\n name = F.symbol (\"PApp\" ++ show n)\n vt = (F.vv Nothing, F.FVar (n-1))\n args = [ (x i, F.FVar i) | i <- [0 .. n-2] ]\n p = \"p\"\n x i = F.symbol (\"x\" ++ show i)\n pred = predApp p (fst <$> (args ++ [vt]))\n pos = F.dummyPos \"pappQual\"\n\npredFTyCon :: F.FTycon\npredFTyCon = F.symbolFTycon (F.dummyLoc \"Pred\")\n" }, { "path": "src/Language/Sprite/L1/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L1.Check (vcgen) where\n\nimport Control.Monad (void)\nimport qualified Data.Map as M\nimport Text.PrettyPrint.HughesPJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L1.Types\nimport Language.Sprite.L1.Prims\nimport Language.Sprite.L1.Constraints\n\n-------------------------------------------------------------------------------\nvcgen:: SrcExpr -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen e = query [] [] <$> check empEnv e (bTrue TInt)\n\n\n\n-- | CG Monad -----------------------------------------------------------------\ntype CG a = Either [UX.UserError] a\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = Left [UX.mkError msg l]\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n\n -}\nsub l s@(TBase b1 (F.Reft (v, _))) (TBase b2 (F.Reft (w, q)))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith \"Invalid Subtyping\" l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 t2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n\n--------------------------------------------------------------------\n-- | 'Checking' constraints\n--------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n--------------------------------------------------------------------\n\n\n{- [Chk-Lam]\n\n G, x:s |- e <== t\n --------------------------\n G |- \\x.e <== x:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) | y == x = do\n c <- check (extEnv g bx s) e t\n return $ cAll l x s c\n where\n x = bindId bx\n\n{- [Chk-Let]\n\n G |- e1 ==> t1 G, x:t1 |- e2 <== t2\n -------------------------------------------\n G |- let x = e1 in e2 <== t2\n\n-}\ncheck g (ELet (Decl bx@(Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g bx s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsynthImm :: Env -> SrcImm -> CG RType\n\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return t\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm g (ECon c l) = return (constTy l c)\n\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t\n -----------------\n G |- e:t => t\n\n-}\nsynth g (EAnn e t _) = do\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e) )) (label e)\n" }, { "path": "src/Language/Sprite/L1/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L1.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll\n\n -- * Substitutions\n , subst, substImm\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv\n ) where\n\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L1.Types\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> F.Expr -> SrcCstr\ncHead l e = H.Head (H.Reft e) (UX.mkError \"Subtype error\" l)\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll sp x t c = case sortPred x t of\n Just (so, p) -> H.All (bind sp x so p) c\n _ -> c\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x (TBase b (F.Reft (v, p))) = Just (baseSort b, H.Reft (subst p v x))\nsortPred x _ = Nothing\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where\n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ntype Env = F.SEnv RType\n\nextEnv :: Env -> Bind a -> RType -> Env\nextEnv env bx t = F.insertSEnv (bindId bx) t env\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x env\n\nempEnv :: Env\nempEnv = F.emptySEnv\n" }, { "path": "src/Language/Sprite/L1/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L1.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , rtype\n , expr\n ) where\n\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport Control.Monad.Combinators.Expr\nimport Text.Megaparsec hiding (State, label)\nimport Text.Megaparsec.Char\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport Language.Sprite.Common\nimport Language.Sprite.Common.Parse\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L1.Types\n\nparseFile :: FilePath -> IO SrcExpr\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser SrcExpr\nprog = declsExpr <$> many decl\n\nexpr :: FP.Parser SrcExpr\nexpr = makeExprParser expr1 binOps\n\nbinOps =\n [ [InfixR (FP.reservedOp \"*\" >> pure (op BTimes)) ]\n , [InfixR (FP.reservedOp \"+\" >> pure (op BPlus)) ]\n , [InfixL (FP.reservedOp \"-\" >> pure (op BMinus)) ]\n ]\n\nop :: PrimOp -> SrcExpr -> SrcExpr -> SrcExpr\nop o e1 e2 = case (e1, e2) of\n (EImm x lx, EImm y ly) -> mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n _ -> UX.panic \"Prim-Ops only on variables\" l\n where\n l = stretch [e1, e2]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\nexpr1 :: FP.Parser SrcExpr\nexpr1 = try appExpr\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try funExpr\n <|> letExpr\n -- <|> try ifExpr\n <|> FP.parens expr\n <|> FP.braces expr\n <|> immExpr\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = withSpan' $ (EVar <$> identifier) <|> (ECon . PInt <$> FP.natural )\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- FP.parens (sepBy1 binder FP.comma)\n _ <- FP.reservedOp \"=>\"\n body <- expr\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> expr0 <*> FP.parens (sepBy1 imm FP.comma)\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = mkDecl <$> ann <*> plainDecl\n\n\ntype Ann = Maybe (F.Symbol, RType)\n\nann :: FP.Parser Ann\n-- ann = (FP.reservedOp \"/*@\" >> (Just <$> annot)) <|> pure Nothing\nann = (FP.reserved \"/*@\" >> (Just <$> annot)) <|> pure Nothing\n\nannot :: FP.Parser (F.Symbol, RType)\nannot = do\n FP.reserved \"val\"\n x <- identifier\n FP.colon\n t <- rtype\n FP.reservedOp \"*/\"\n return (x, t)\n\nmkDecl :: Ann -> SrcDecl -> SrcDecl\nmkDecl (Just (x, t)) (Decl b e l)\n | x == bindId b = Decl b (EAnn e t (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl Nothing d = d\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n FP.reserved \"let\"\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (Decl b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\npairSpan :: FP.Parser a -> FP.Parser (a, F.SrcSpan)\npairSpan p = withSpan' $ do\n x <- p\n return (x,)\n\nisKey :: String -> Bool\nisKey x = S.member x keywords\n\nstretch :: (Label t, Monoid a) => [t a] -> a\nstretch = mconcat . fmap label\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = try rfun\n <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = FP.parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArg <*> (FP.reservedOp \"=>\" *> rtype)\n\nfunArg :: FP.Parser (F.Symbol, RType)\nfunArg = try ((,) <$> FP.lowerIdP <*> (FP.colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = TBase <$> tbase <*> refTop\n\ntbase :: FP.Parser Base\ntbase = FP.reserved \"int\" >> pure TInt\n\nrefTop :: FP.Parser F.Reft\nrefTop = FP.brackets reftB <|> pure mempty\n\nreftB :: FP.Parser F.Reft\nreftB = mkReft <$> (FP.lowerIdP <* mid) <*> FP.predP\n\nmkReft :: F.Symbol -> F.Pred -> F.Reft\nmkReft x r = F.Reft (x, r)\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))\n\n-- >>> parseWith ann \"\" \"/*@ val inc: x:int => int[v|v = x + 1] */\"" }, { "path": "src/Language/Sprite/L1/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L1.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L1.Types \nimport Language.Sprite.L1.Parse\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (F.exprReft (F.expr n)) \nconstTy l (PBin o) = binOpTy l o\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n -- , (BLt , mkTy \"x:int => y:int => bool{v|v <=> (x < y)}\")\n -- , (BGt , mkTy \"x:int => y:int => bool{v|v <=> (x > y)}\")\n -- , (BEq , mkTy \"x:int => y:int => bool{v|v <=> (x = y)}\")\n ]\n\nmkTy :: String -> RType\nmkTy = parseWith rtype \"prims\" \n" }, { "path": "src/Language/Sprite/L1/Types.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE DeriveFunctor #-}\n\nmodule Language.Sprite.L1.Types where \n\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common.Misc \nimport Language.Sprite.Common\n\n-- | Basic types --------------------------------------------------------------\n\ndata Base = TInt\n deriving (Eq, Ord, Show)\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r \n = TBase !Base r -- Int{r} \n | TFun !F.Symbol !(Type r) !(Type r) -- x:s -> t \n deriving (Eq, Ord, Show)\n\ntype RType = Type F.Reft\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp \n = BPlus \n | BMinus \n | BTimes\n | BLt\n | BGt\n | BEq \n deriving (Eq, Ord, Show)\n\ndata Prim \n = PInt Integer\n | PBin !PrimOp \n deriving (Eq, Ord, Show)\n\n-- | Terms --------------------------------------------------------------------\ndata Decl a = Decl (Bind a) (Expr a) a\n deriving (Show, Functor)\n\ndata Bind a \n = Bind !F.Symbol a\n deriving (Eq, Ord, Show, Functor)\n\nbindId :: Bind a -> F.Symbol \nbindId (Bind x _) = x\n\ndata Imm a\n = EVar !F.Symbol a\n | ECon !Prim a\n deriving (Show, Functor)\n\ndata Expr a \n = EImm !(Imm a) a\n | EFun !(Bind a) !(Expr a) a\n | EApp !(Expr a) !(Imm a) a\n | ELet !(Decl a) !(Expr a) a\n | EAnn !(Expr a) !RType a\n deriving (Show, Functor)\n\ninstance Label Imm where \n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where \n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ l) = l\n \ninstance Label Decl where \n label (Decl _ _ l) = l\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d \ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d \ndeclsExpr _ = UX.panic \"declsExpr with empty declarations!\" UX.junkSpan \n \nintExpr :: Integer -> a -> Expr a \nintExpr i l = EImm (ECon (PInt i) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\n\ninstance F.Subable r => F.Subable (Type r) where \n -- syms :: a -> [Symbol] \n syms (TBase _ r) = F.syms r\n syms (TFun _ s t) = F.syms s ++ F.syms t\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r \n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n\n\n" }, { "path": "src/Language/Sprite/L1.hs", "content": "module Language.Sprite.L1 ( sprite ) where\n\nimport Control.Monad (void)\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\n-- import qualified Language.Fixpoint.Types.Config as F\n-- import qualified Language.Fixpoint.Misc as F\n-- import Language.Sprite.L1.Types\nimport Language.Sprite.L1.Check\nimport Language.Sprite.L1.Parse\nimport Language.Sprite.Common\n\nsprite :: FilePath -> IO ()\nsprite f = do\n src <- parseFile f\n -- print (void src)\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValid f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "src/Language/Sprite/L2/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L2.Check (vcgen) where\n\nimport Control.Monad (void)\n-- import qualified Data.Map as M\nimport Text.PrettyPrint.HughesPJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L2.Types\nimport Language.Sprite.L2.Prims\nimport Language.Sprite.L2.Constraints\n\n-------------------------------------------------------------------------------\nvcgen:: SrcExpr -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen e = query [] [] <$> check empEnv e (bTrue TInt)\n\n-- | CG Monad -----------------------------------------------------------------\ntype CG a = Either [UX.UserError] a\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = Left [UX.mkError msg l]\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n\n -}\nsub l s@(TBase b1 (F.Reft (v, _))) (TBase b2 (F.Reft (w, q)))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith \"Invalid Subtyping\" l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 t2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n\n--------------------------------------------------------------------\n-- | 'Checking' constraints\n--------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n--------------------------------------------------------------------\n\n\n{- [Chk-Lam]\n\n G, x:s |- e <== t\n --------------------------\n G |- \\x.e <== x:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) | y == x = do\n c <- check (extEnv g bx s') e t'\n return $ cAll l x s c\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n\n{- [Chk-Let]\n\n G |- e1 ==> t1 G, x:t1 |- e2 <== t2\n -------------------------------------------\n G |- let x = e1 in e2 <== t2\n\n-}\ncheck g (ELet (Decl bx@(Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g bx s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Rec]\n\n G; f:s |- e <== s G; f:s |- e' <== t'\n ----------------------------------------[Chk-Rec]\n G |- letrec f = (e:s) in e' <== t'\n\n -}\ncheck g (ELet (RDecl bx@(Bind x l) (EAnn e s _) _) e' _) t' = do\n c <- check g' e s\n c' <- check g' e' t'\n return $ cAnd c c'\n where\n g' = extEnv g bx s\n\n{- [Chk-If]\n G |- v <== bool\n G, _:{v} |- e1 <== t\n G, _:{not v} |- e2 <== t\n ----------------------------- [Chk-If]\n G |- if v e1 e2 <== t\n -}\ncheck g (EIf v e1 e2 l) t = do\n cv <- check g (EImm v l) rBool\n c1 <- cAll l xv tT <$> check g e1 t\n c2 <- cAll l xv tF <$> check g e2 t\n return (cAnd c1 c2)\n where\n tT = predRType pv\n tF = predRType (F.PNot pv)\n pv = immExpr v\n xv = grdSym g\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsingleton :: F.Symbol -> RType -> RType\nsingleton x (TBase b (F.Reft (v, p))) = TBase b (F.Reft (v, F.pAnd [p, v_eq_x]))\n where v_eq_x = F.PAtom F.Eq (F.expr v) (F.expr x)\nsingleton _ t = t\n\nsynthImm :: Env -> SrcImm -> CG RType\n\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return (singleton x t)\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm g (ECon c l) = return (constTy l c)\n\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t\n -----------------\n G |- e:t => t\n\n-}\nsynth g (EAnn e t _) = do\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e) )) (label e)\n" }, { "path": "src/Language/Sprite/L2/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L2.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll\n\n -- * Substitutions\n , subst, substImm\n\n -- * Conversions\n , immExpr, predRType\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv, grdSym\n ) where\n\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L2.Types\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> F.Expr -> SrcCstr\ncHead l e = H.Head (H.Reft e) (UX.mkError \"Subtype error\" l)\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll l x t c = case sortPred x t of\n Just (so, p) -> H.All (bind l x so p) c\n _ -> c\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x (TBase b (F.Reft (v, p))) = Just (baseSort b, H.Reft (subst p v x))\nsortPred x _ = Nothing\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\nbaseSort TBool = F.boolSort\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where\n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\nimmExpr (ECon (PBool True) _) = F.PTrue\nimmExpr (ECon (PBool False) _) = F.PFalse\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ndata Env = Env\n { eBinds :: !(F.SEnv RType)\n , eSize :: !Integer\n }\n\nextEnv :: Env -> Bind a -> RType -> Env\nextEnv env bx t = Env\n { eBinds = F.insertSEnv (bindId bx) t (eBinds env)\n , eSize = 1 + eSize env\n }\n\ngrdSym :: Env -> F.Symbol\ngrdSym env = F.tempSymbol \"grd\" (eSize env)\n\npredRType :: F.Pred -> RType\npredRType p = TBase TBool (F.predReft p)\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x (eBinds env)\n\nempEnv :: Env\nempEnv = Env F.emptySEnv 0\n" }, { "path": "src/Language/Sprite/L2/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L2.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , rtype\n , expr\n ) where\n\nimport qualified Data.List as L\nimport Text.Megaparsec hiding (State, label)\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport Language.Sprite.Common\nimport Language.Sprite.Common.Parse\nimport Language.Sprite.L2.Types\n\nparseFile :: FilePath -> IO SrcExpr\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser SrcExpr\nprog = declsExpr <$> many decl\n\nexpr :: FP.Parser SrcExpr\nexpr = try funExpr\n <|> try letExpr\n <|> try ifExpr\n <|> try (FP.braces (expr <* whiteSpace))\n <|> try appExpr\n <|> try binExp\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try (FP.parens expr)\n <|> immExpr\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> immExpr <*> parens (sepBy1 imm comma)\n\n\n\nbinExp :: FP.Parser SrcExpr\nbinExp = withSpan' $ do\n x <- imm\n o <- op\n y <- imm\n return (bop o x y)\n\nop :: FP.Parser PrimOp\nop = (FP.reservedOp \"*\" >> pure BTimes)\n <|> (FP.reservedOp \"+\" >> pure BPlus )\n <|> (FP.reservedOp \"-\" >> pure BMinus)\n <|> (FP.reservedOp \"<\" >> pure BLt )\n <|> (FP.reservedOp \"<=\" >> pure BLe )\n <|> (FP.reservedOp \"==\" >> pure BEq )\n <|> (FP.reservedOp \">\" >> pure BGt )\n <|> (FP.reservedOp \">=\" >> pure BGe )\n <|> (FP.reservedOp \"&&\" >> pure BAnd )\n <|> (FP.reservedOp \"||\" >> pure BOr )\n\nbop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr\nbop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nifExpr :: FP.Parser SrcExpr\nifExpr = withSpan' $ do\n FP.reserved \"if\"\n v <- parens imm\n e1 <- expr\n FP.reserved \"else\"\n e2 <- expr\n return (EIf v e1 e2)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = immInt <|> immBool <|> immId\n\nimmInt :: FP.Parser SrcImm\nimmInt = withSpan' (ECon . PInt <$> FP.natural)\n\nimmBool :: FP.Parser SrcImm\nimmBool = withSpan' (ECon . PBool <$> bool)\n\nimmId :: FP.Parser SrcImm\nimmId = withSpan' (EVar <$> identifier)\n\nbool :: FP.Parser Bool\nbool = (reserved \"true\" >> pure True)\n <|>(reserved \"false\" >> pure False)\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- parens (sepBy1 binder comma)\n _ <- FP.reservedOp \"=>\"\n -- _ <- FP.reservedOp \"{\"\n body <- braces (expr <* whiteSpace)\n -- _ <- FP.reservedOp \"}\"\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = mkDecl <$> ann <*> plainDecl\n\ntype Ann = Maybe (F.Symbol, RType)\n\nann :: FP.Parser Ann\nann = (reservedOp \"/*@\" >> (Just <$> annot)) <|> pure Nothing\n\nannot :: FP.Parser (F.Symbol, RType)\nannot = do\n reserved \"val\"\n x <- identifier\n colon\n t <- rtype\n reservedOp \"*/\"\n return (x, t)\n\nmkDecl :: Ann -> SrcDecl -> SrcDecl\nmkDecl (Just (x, t)) (Decl b e l)\n | x == bindId b = Decl b (EAnn e t (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl (Just (x, t)) (RDecl b e l)\n | x == bindId b = RDecl b (EAnn e t (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl Nothing d = d\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n ctor <- (FP.reserved \"let rec\" >> pure RDecl) <|>\n (FP.reserved \"let\" >> pure Decl)\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (ctor b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = try rfun\n <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArg <*> (FP.reservedOp \"=>\" *> rtype)\n\nfunArg :: FP.Parser (F.Symbol, RType)\nfunArg = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = TBase <$> tbase <*> refTop\n\ntbase :: FP.Parser Base\ntbase = (reserved \"int\" >> pure TInt)\n <|>(reserved \"bool\" >> pure TBool)\n\nrefTop :: FP.Parser F.Reft\nrefTop = brackets reftB <|> pure mempty\n\nreftB :: FP.Parser F.Reft\nreftB = mkReft <$> (FP.lowerIdP <* mid) <*> FP.predP\n\nmkReft :: F.Symbol -> F.Pred -> F.Reft\nmkReft x r = F.Reft (x, r)\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))" }, { "path": "src/Language/Sprite/L2/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L2.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L2.Types \nimport Language.Sprite.L2.Parse\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (F.exprReft (F.expr n)) \nconstTy _ (PBool True) = TBase TBool (F.propReft F.PTrue)\nconstTy _ (PBool False) = TBase TBool (F.propReft F.PFalse)\nconstTy l (PBin o) = binOpTy l o\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n , (BLt , mkTy \"x:int => y:int => bool[v|v <=> (x < y)]\")\n , (BLe , mkTy \"x:int => y:int => bool[v|v <=> (x <= y)]\")\n , (BGt , mkTy \"x:int => y:int => bool[v|v <=> (x > y)]\")\n , (BGe , mkTy \"x:int => y:int => bool[v|v <=> (x >= y)]\")\n , (BEq , mkTy \"x:int => y:int => bool[v|v <=> (x == y)]\")\n , (BAnd , mkTy \"x:bool => y:bool => bool[v|v <=> (x && y)]\")\n , (BOr , mkTy \"x:bool => y:bool => bool[v|v <=> (x || y)]\")\n , (BNot , mkTy \"x:bool => bool[v|v <=> not x]\")\n ]\n\nmkTy :: String -> RType\nmkTy = parseWith rtype \"prims\" \n" }, { "path": "src/Language/Sprite/L2/Types.hs", "content": "{-# LANGUAGE DeriveFunctor #-}\nmodule Language.Sprite.L2.Types where \n\n-- import qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\n-- import qualified Language.Sprite.Common.UX as UX\n-- import Language.Sprite.Common.Misc \nimport Language.Sprite.Common\n\n-- | Basic types --------------------------------------------------------------\n\ndata Base = TInt | TBool\n deriving (Eq, Ord, Show)\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r \n = TBase !Base r -- Int{r} \n | TFun !F.Symbol !(Type r) !(Type r) -- x:s -> t \n deriving (Eq, Ord, Show)\n\nrInt :: RType \nrInt = TBase TInt mempty\n\nrBool :: RType \nrBool = TBase TBool mempty \n\ntype RType = Type F.Reft\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp \n = BPlus \n | BMinus \n | BTimes\n | BLt\n | BLe\n | BEq \n | BGt\n | BGe\n | BAnd\n | BOr\n | BNot\n deriving (Eq, Ord, Show)\n\ndata Prim \n = PInt !Integer -- 0,1,2,... \n | PBool !Bool -- true, false\n | PBin !PrimOp -- +,-,==,<=,...\n deriving (Eq, Ord, Show)\n\n---------------------------------------------------------------------------------\n-- | Terms ----------------------------------------------------------------------\n---------------------------------------------------------------------------------\n\n-- | Bindings -------------------------------------------------------------------\n\ndata Bind a \n = Bind !F.Symbol a\n deriving (Eq, Ord, Show, Functor)\n\nbindId :: Bind a -> F.Symbol \nbindId (Bind x _) = x\n\n-- | \"Immediate\" terms (can appear as function args & in refinements) -----------\n\ndata Imm a\n = EVar !F.Symbol a\n | ECon !Prim a\n deriving (Show, Functor)\n\n-- | Variable definition ---------------------------------------------------------\n\ndata Decl a \n = Decl (Bind a) (Expr a) a -- plain \"let\" \n | RDecl (Bind a) (Expr a) a -- recursive \"let rec\"\n deriving (Show, Functor)\n\n-- | Terms -----------------------------------------------------------------------\n\ndata Expr a \n = EImm !(Imm a) a -- x,y,z,... 1,2,3...\n | EFun !(Bind a) !(Expr a) a -- \\x -> e\n | EApp !(Expr a) !(Imm a) a -- e v\n | ELet !(Decl a) !(Expr a) a -- let/rec x = e1 in e2\n | EAnn !(Expr a) !RType a -- e:t\n | EIf !(Imm a) !(Expr a) !(Expr a) a -- if v e1 e2\n deriving (Show, Functor)\n\ninstance Label Imm where \n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where \n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ l) = l\n label (EIf _ _ _ l) = l\n \ninstance Label Decl where \n label (Decl _ _ l) = l\n label (RDecl _ _ l) = l\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d \ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d \n\nintExpr :: Integer -> a -> Expr a \nintExpr i l = EImm (ECon (PInt i) l) l\n\nboolExpr :: Bool -> a -> Expr a\nboolExpr b l = EImm (ECon (PBool b) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\n\ninstance F.Subable r => F.Subable (Type r) where \n -- syms :: a -> [Symbol] \n syms (TBase _ r) = F.syms r\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r \n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n\n\n" }, { "path": "src/Language/Sprite/L2.hs", "content": "module Language.Sprite.L2 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Types.Config as F\nimport qualified Language.Fixpoint.Misc as F\nimport Language.Sprite.L2.Types\nimport Language.Sprite.L2.Check\nimport Language.Sprite.L2.Parse\nimport Language.Sprite.Common\n\n--------------------------------------------------------------------------------\nsprite :: FilePath -> IO ()\n--------------------------------------------------------------------------------\nsprite f = do\n src <- parseFile f\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValid f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "src/Language/Sprite/L3/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L3.Check (vcgen) where\n\nimport Control.Monad (void)\n-- import qualified Data.Maybe as Mb\n-- import qualified Data.Map as M\nimport Text.PrettyPrint.HughesPJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L3.Types\nimport Language.Sprite.L3.Prims\nimport Language.Sprite.L3.Constraints\n\n-------------------------------------------------------------------------------\nvcgen:: ([F.Qualifier], SrcExpr) -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen (qs, e) = do\n (c, ks) <- run (check empEnv e (bTrue TInt))\n return $ query qs ks c\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n\n -}\nsub l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith \"Invalid Subtyping\" l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 s2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n-- sub l t1 t2 = failWith (\"sub: cannot handle:\" <+> tshow (t1, t2)) l\n\ntshow :: (Show a) => a -> Doc\ntshow = text . show\n--------------------------------------------------------------------\n-- | 'Checking' constraints\n--------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n--------------------------------------------------------------------\n\n\n{- [Chk-Lam]\n\n G, x:s[y:=x] |- e <== t[y:=x]\n -----------------------------\n G |- \\x.e <== y:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) = do\n c <- check (extEnv g x s') e t'\n return $ cAll l x s c\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n\n{- [Chk-Let]\n\n G |- e ==> s G, x:s |- e' <== t'\n -------------------------------------------\n G |- let x = e in e' <== t'\n\n-}\ncheck g (ELet (Decl (Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g x s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Rec]\n\n t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'\n ---------------------------------------------------------[Chk-Rec]\n G |- letrec f = (e:s) in e' <== t'\n\n -}\ncheck g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do\n t <- fresh l g s\n let g' = extEnv g x t\n c <- check g' e t\n c' <- check g' e' t'\n return $ cAnd c c'\n\n{- [Chk-If]\n G |- v <== bool\n G, _:{v} |- e1 <== t\n G, _:{not v} |- e2 <== t\n ----------------------------- [Chk-If]\n G |- if v e1 e2 <== t\n -}\ncheck g (EIf v e1 e2 l) t = do\n _ <- check g (EImm v l) rBool\n c1 <- cAll l xv tT <$> check g e1 t\n c2 <- cAll l xv tF <$> check g e2 t\n return (cAnd c1 c2)\n where\n tT = predRType pv\n tF = predRType (F.PNot pv)\n pv = immExpr v\n xv = grdSym g\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsingleton :: F.Symbol -> RType -> RType\n\nsingleton x (TBase b (Known v p)) = TBase b (Known v (H.PAnd [p, v `peq` x]))\nsingleton _ t = t\n\npeq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred\npeq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))\n\n-- singleton x (TBase b (KReft v p)) = TBase b (KReft v (F.pAnd [p, v_eq_x]))\n-- where v_eq_x = F.PAtom F.Eq (F.expr v) (F.expr x)\n\nsynthImm :: Env -> SrcImm -> CG RType\n\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return (singleton x t)\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm _ (ECon c l) = return (constTy l c)\n\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t t := fresh(s)\n ---------------------------\n G |- e:s => t\n\n-}\nsynth g (EAnn e s l) = do\n t <- fresh l g s\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e))) (label e)\n\n-------------------------------------------------------------------------------\n-- | Fresh templates for `Unknown` refinements\n-------------------------------------------------------------------------------\nfresh :: F.SrcSpan -> Env -> RType -> CG RType\nfresh l g (TBase b r) = TBase b <$> freshR l g b r\nfresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t\n\nfreshR :: F.SrcSpan -> Env -> Base -> Reft -> CG Reft\nfreshR _ _ _ r@(Known {}) = pure r\nfreshR l g b Unknown = freshK l g b\n" }, { "path": "src/Language/Sprite/L3/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L3.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll\n\n -- * Substitutions\n , subst, substImm\n\n -- * Conversions\n , predRType, baseSort\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv, grdSym, envSorts\n\n -- * Constraint Generation Monad\n , CG, run, failWith, freshK\n\n ) where\n\nimport qualified Data.Maybe as Mb\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L3.Types\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd (H.CAnd []) c = c\ncAnd c (H.CAnd []) = c\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> H.Pred -> SrcCstr\ncHead _ (H.PAnd []) = cTrue\ncHead _ (H.Reft p)\n | F.isTautoPred p = cTrue\ncHead l p = H.Head p (UX.mkError \"Subtype error\" l)\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll l x t c = case sortPred x t of\n Just (so, p) -> H.All (bind l x so p) c\n _ -> c\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x (TBase b (Known v p)) = Just (baseSort b, subst p v x)\nsortPred _ _ = Nothing\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\nbaseSort TBool = F.boolSort\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ndata Env = Env\n { eBinds :: !(F.SEnv RType)\n , eSize :: !Integer\n }\n\nextEnv :: Env -> F.Symbol -> RType -> Env\nextEnv env x t\n | x == junkSymbol = env\n | otherwise = Env { eBinds = F.insertSEnv x t (eBinds env)\n , eSize = 1 + eSize env\n }\n\ngrdSym :: Env -> F.Symbol\ngrdSym env = F.tempSymbol \"grd\" (eSize env)\n\npredRType :: F.Pred -> RType\npredRType p = TBase TBool (known $ F.predReft p)\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x (eBinds env)\n\nempEnv :: Env\nempEnv = Env F.emptySEnv 0\n\nenvSorts :: Env -> [(F.Symbol, F.Sort)]\nenvSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)\n , (t, _) <- Mb.maybeToList (sortPred x s) ]\n\n-------------------------------------------------------------------------------\n-- | CG Monad -----------------------------------------------------------------\n-------------------------------------------------------------------------------\n\ntype CG a = StateT CGState (Either [UX.UserError]) a\n\ndata CGState = CGState\n { cgCount :: !Integer -- ^ monotonic counter, to get fresh things\n , cgKVars :: ![SrcHVar] -- ^ list of generated kvars\n }\n\ns0 :: CGState\ns0 = CGState 0 []\n\nrun :: CG a -> Either [UX.UserError] (a, [SrcHVar])\nrun act = do\n (x, s) <- runStateT act s0\n return (x, cgKVars s)\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = throwError [UX.mkError msg l]\n\nfreshK :: F.SrcSpan -> Env -> Base -> CG Reft\nfreshK l g b = do\n v <- freshValueSym\n k <- freshKVar l t ts\n return $ Known v (H.Var k (v:xs))\n where\n t = baseSort b\n (xs,ts) = unzip (envSorts g)\n\nfreshKVar :: F.SrcSpan -> F.Sort -> [F.Sort] -> CG F.Symbol\nfreshKVar l t ts = do\n k <- F.kv . F.intKvar <$> freshInt\n _ <- addSrcKVar (H.HVar k (t:ts) (UX.mkError \"fake\" l))\n return k\n\naddSrcKVar :: SrcHVar -> CG ()\naddSrcKVar k = modify $ \\s -> s { cgKVars = k : cgKVars s }\n\nfreshValueSym :: CG F.Symbol\nfreshValueSym = F.vv . Just <$> freshInt\n\nfreshInt :: CG Integer\nfreshInt = do\n s <- get\n let n = cgCount s\n put s { cgCount = 1 + n}\n return n\n" }, { "path": "src/Language/Sprite/L3/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L3.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , rtype\n , expr\n ) where\n\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport Control.Monad.Combinators.Expr\nimport Text.Megaparsec hiding (State, label)\nimport Text.Megaparsec.Char\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport Language.Sprite.Common\nimport Language.Sprite.Common.Parse\nimport Language.Sprite.L3.Types hiding (immExpr)\nimport Language.Sprite.L3.Constraints\n\nparseFile :: FilePath -> IO ([F.Qualifier], SrcExpr)\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser ([F.Qualifier], SrcExpr)\nprog = do\n qs <- quals\n src <- declsExpr <$> many decl\n return (qs, src)\n\nquals :: FP.Parser [F.Qualifier]\nquals = try ((:) <$> between annL annR qual <*> quals)\n <|> pure []\n\nqual ::FP.Parser F.Qualifier\nqual = FP.reserved \"qualif\" >> FP.qualifierP (baseSort <$> tbase)\n\nexpr :: FP.Parser SrcExpr\nexpr = try funExpr\n <|> try letExpr\n <|> try ifExpr\n <|> try (FP.braces (expr <* FP.spaces))\n <|> try appExpr\n <|> try binExp\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try (FP.parens expr)\n <|> immExpr\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> immExpr <*> FP.parens (sepBy1 imm FP.comma)\n\nbinExp :: FP.Parser SrcExpr\nbinExp = withSpan' $ do\n x <- imm\n o <- op\n y <- imm\n return (bop o x y)\n\nop :: FP.Parser PrimOp\nop = (FP.reservedOp \"*\" >> pure BTimes)\n <|> (FP.reservedOp \"+\" >> pure BPlus )\n <|> (FP.reservedOp \"-\" >> pure BMinus)\n <|> (FP.reservedOp \"<\" >> pure BLt )\n <|> (FP.reservedOp \"<=\" >> pure BLe )\n <|> (FP.reservedOp \"==\" >> pure BEq )\n <|> (FP.reservedOp \">\" >> pure BGt )\n <|> (FP.reservedOp \">=\" >> pure BGe )\n <|> (FP.reservedOp \"&&\" >> pure BAnd )\n <|> (FP.reservedOp \"||\" >> pure BOr )\n\nbop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr\nbop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nifExpr :: FP.Parser SrcExpr\nifExpr = withSpan' $ do\n FP.reserved \"if\"\n v <- FP.parens imm\n e1 <- expr\n FP.reserved \"else\"\n e2 <- expr\n return (EIf v e1 e2)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = immInt <|> immBool <|> immId\n\nimmInt :: FP.Parser SrcImm\nimmInt = withSpan' (ECon . PInt <$> FP.natural)\n\nimmBool :: FP.Parser SrcImm\nimmBool = withSpan' (ECon . PBool <$> bool)\n\nimmId :: FP.Parser SrcImm\nimmId = withSpan' (EVar <$> identifier)\n\nbool :: FP.Parser Bool\nbool = (FP.reserved \"true\" >> pure True)\n <|>(FP.reserved \"false\" >> pure False)\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- FP.parens (sepBy1 binder FP.comma)\n _ <- FP.reservedOp \"=>\"\n body <- FP.braces (expr <* FP.spaces)\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = mkDecl <$> ann <*> plainDecl\n\ntype Ann = Maybe (F.Symbol, RType)\n\nannL, annR :: FP.Parser ()\nannL = FP.reservedOp \"/*@\"\nannR = FP.reservedOp \"*/\"\n\nann :: FP.Parser Ann\nann = (annL >> (Just <$> annot)) <|> pure Nothing\n\nannot :: FP.Parser (F.Symbol, RType)\nannot = do\n FP.reserved \"val\"\n x <- identifier\n FP.colon\n t <- rtype\n annR\n return (x, t)\n\n{-\nbetween :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a\nbetween lP rP xP = do\n lP\n x <- xP\n rP\n return x\n -}\nmkDecl :: Ann -> SrcDecl -> SrcDecl\nmkDecl (Just (x, t)) (Decl b e l)\n | x == bindId b = Decl b (EAnn e t (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl (Just (x, t)) (RDecl b e l)\n | x == bindId b = RDecl b (EAnn e t (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl Nothing d = d\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n ctor <- (FP.reserved \"let rec\" >> pure RDecl) <|>\n (FP.reserved \"let\" >> pure Decl)\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (ctor b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = try rfun\n <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArg <*> (FP.reservedOp \"=>\" *> rtype)\n\nfunArg :: FP.Parser (F.Symbol, RType)\nfunArg = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = TBase <$> tbase <*> refTop\n\ntbase :: FP.Parser Base\ntbase = (reserved \"int\" >> pure TInt)\n <|>(reserved \"bool\" >> pure TBool)\n\nrefTop :: FP.Parser Reft\nrefTop = brackets reftB <|> pure mempty\n\nreftB :: FP.Parser Reft\nreftB = (question >> pure Unknown)\n <|> KReft <$> (FP.lowerIdP <* mid) <*> FP.predP\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\nquestion :: FP.Parser ()\nquestion = FP.reservedOp \"?\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))\n\n\n-- | list of reserved words\nkeywords :: S.Set String\nkeywords = S.fromList\n [ \"if\" , \"else\"\n , \"true\" , \"false\"\n , \"let\" , \"in\"\n , \"int\"\n ]" }, { "path": "src/Language/Sprite/L3/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L3.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.L3.Types \nimport Language.Sprite.L3.Parse\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n)) \nconstTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)\nconstTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)\nconstTy l (PBin o) = binOpTy l o\n\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n\n , (BLt , mkTy \"x:int => y:int => bool[v|v <=> (x < y)]\")\n , (BLe , mkTy \"x:int => y:int => bool[v|v <=> (x <= y)]\")\n , (BGt , mkTy \"x:int => y:int => bool[v|v <=> (x > y)]\")\n , (BGe , mkTy \"x:int => y:int => bool[v|v <=> (x >= y)]\")\n , (BEq , mkTy \"x:int => y:int => bool[v|v <=> (x == y)]\")\n\n , (BAnd , mkTy \"x:bool => y:bool => bool[v|v <=> (x && y)]\")\n , (BOr , mkTy \"x:bool => y:bool => bool[v|v <=> (x || y)]\")\n , (BNot , mkTy \"x:bool => bool[v|v <=> not x]\")\n ]\n\nmkTy :: String -> RType\nmkTy = {- Misc.traceShow \"mkTy\" . -} rebind . parseWith rtype \"prims\" \n\n\n\nrebind :: RType -> RType\nrebind t@(TBase {}) = t \nrebind (TFun x s t) = TFun x' s' t' \n where \n x' = F.mappendSym \"spec#\" x\n s' = subst (rebind s) x x'\n t' = subst (rebind t) x x'" }, { "path": "src/Language/Sprite/L3/Types.hs", "content": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L3.Types where \n\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\n-- import Language.Sprite.Common.Misc \nimport Language.Sprite.Common\n\n-- | Basic types --------------------------------------------------------------\n\ndata Base = TInt | TBool\n deriving (Eq, Ord, Show)\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r \n = TBase !Base r -- ^ Int{r} \n | TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t \n deriving (Eq, Ord, Show)\n\nrInt :: RType \nrInt = TBase TInt mempty\n\nrBool :: RType \nrBool = TBase TBool mempty \n\ndata Reft \n = Known !F.Symbol !H.Pred -- ^ Known refinement\n | Unknown -- ^ Unknown, to-be-synth refinement\n deriving (Show)\n\nknown :: F.Reft -> Reft\nknown (F.Reft (v, r)) = KReft v r\n\npattern KReft v p = Known v (H.Reft p)\n\ninstance Semigroup Reft where \n Unknown <> r = r\n r <> Unknown = r\n KReft v1 r1 <> KReft v2 r2 = KReft v r \n where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)\n \n\ninstance Monoid Reft where \n mempty = KReft v r where F.Reft (v, r) = mempty\n\ntype RType = Type Reft\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp \n = BPlus \n | BMinus \n | BTimes\n | BLt\n | BLe\n | BEq \n | BGt\n | BGe\n | BAnd\n | BOr\n | BNot\n deriving (Eq, Ord, Show)\n\ndata Prim \n = PInt !Integer -- 0,1,2,... \n | PBool !Bool -- true, false\n | PBin !PrimOp -- +,-,==,<=,...\n deriving (Eq, Ord, Show)\n\n---------------------------------------------------------------------------------\n-- | Terms ----------------------------------------------------------------------\n---------------------------------------------------------------------------------\n\n-- | Bindings -------------------------------------------------------------------\n\ndata Bind a \n = Bind !F.Symbol a\n deriving (Eq, Ord, Show, Functor)\n\nbindId :: Bind a -> F.Symbol \nbindId (Bind x _) = x\n\njunkSymbol :: F.Symbol\njunkSymbol = \"_\"\n\n-- | \"Immediate\" terms (can appear as function args & in refinements) -----------\n\ndata Imm a\n = EVar !F.Symbol a\n | ECon !Prim a\n deriving (Show, Functor)\n\n-- | Variable definition ---------------------------------------------------------\n\ndata Decl a \n = Decl (Bind a) (Expr a) a -- plain \"let\" \n | RDecl (Bind a) (Expr a) a -- recursive \"let rec\"\n deriving (Show, Functor)\n\n-- | Terms -----------------------------------------------------------------------\n\ndata Expr a \n = EImm !(Imm a) a -- x,y,z,... 1,2,3...\n | EFun !(Bind a) !(Expr a) a -- \\x -> e\n | EApp !(Expr a) !(Imm a) a -- e v\n | ELet !(Decl a) !(Expr a) a -- let/rec x = e1 in e2\n | EAnn !(Expr a) !RType a -- e:t\n | EIf !(Imm a) !(Expr a) !(Expr a) a -- if v e1 e2\n deriving (Show, Functor)\n\ninstance Label Imm where \n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where \n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ l) = l\n label (EIf _ _ _ l) = l\n \ninstance Label Decl where \n label (Decl _ _ l) = l\n label (RDecl _ _ l) = l\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d \ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d \n\nintExpr :: Integer -> a -> Expr a \nintExpr i l = EImm (ECon (PInt i) l) l\n\nboolExpr :: Bool -> a -> Expr a\nboolExpr b l = EImm (ECon (PBool b) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\n\n-- | should/need only be defined on \"Known\" variants. TODO:LIQUID\ninstance F.Subable Reft where \n syms (Known v r) = v : F.syms r\n substa f (Known v r) = Known (f v) (F.substa f r)\n substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r) \n subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)\n subst1 (Known v r) su = Known v (F.subst1Except [v] r su)\n\ninstance F.Subable r => F.Subable (Type r) where \n -- syms :: a -> [Symbol] \n syms (TBase _ r) = F.syms r\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r \n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where \n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\nimmExpr (ECon (PBool True) _) = F.PTrue\nimmExpr (ECon (PBool False) _) = F.PFalse\n\n" }, { "path": "src/Language/Sprite/L3.hs", "content": "module Language.Sprite.L3 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\n-- import qualified Language.Fixpoint.Types.Config as F\n-- import qualified Language.Fixpoint.Misc as F\n-- import Language.Sprite.L3.Types\nimport Language.Sprite.L3.Check\nimport Language.Sprite.L3.Parse\nimport Language.Sprite.Common\n\n--------------------------------------------------------------------------------\nsprite :: FilePath -> IO ()\n--------------------------------------------------------------------------------\nsprite f = do\n src <- parseFile f\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValid f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "src/Language/Sprite/L4/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Sprite.L4.Check (vcgen) where\n\nimport Control.Monad (void)\n-- import qualified Data.Maybe as Mb\n-- import qualified Data.Map as M\nimport Text.PrettyPrint.HughesPJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common\nimport Language.Sprite.L4.Types\nimport Language.Sprite.L4.Prims\nimport Language.Sprite.L4.Constraints\nimport Language.Sprite.L4.Elaborate\n-- import Debug.Trace (trace)\n\n\n-------------------------------------------------------------------------------\nvcgen:: ([F.Qualifier], SrcExpr) -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen (qs, e) = do\n let eL = elaborate e\n (c, ks) <- run (check empEnv eL (bTrue TInt))\n return $ query qs ks c\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n\n -}\nsub l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith \"Invalid Subtyping\" l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 s2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n-- sub l (TAll a1 t1) (TAll a2 t2) = do\n-- failWith \"TBD:sub-All\" l\n\nsub l t1 t2 = failWith (\"sub: cannot handle:\" <+> UX.tshow (t1, t2)) l\n\n--------------------------------------------------------------------\n-- | 'Checking' constraints\n--------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n--------------------------------------------------------------------\n{- [Chk-Lam]\n\n G, x:s[y:=x] |- e <== t[y:=x]\n -----------------------------\n G |- \\x.e <== y:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) = do\n c <- check (extEnv g x s') e t'\n return $ cAll l x s c\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n\n{- [Chk-Let]\n\n G |- e ==> s G, x:s |- e' <== t'\n -------------------------------------------\n G |- let x = e in e' <== t'\n\n-}\ncheck g (ELet (Decl (Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g x s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Rec]\n\n t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'\n ---------------------------------------------------------[Chk-Rec]\n G |- letrec f = (e:s) in e' <== t'\n\n -}\ncheck g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do\n t <- fresh l g s\n let g' = extEnv g x t\n c <- check g' e t\n c' <- check g' e' t'\n return $ cAnd c c'\n\n{- [Chk-If]\n G |- v <== bool\n G, _:{v} |- e1 <== t\n G, _:{not v} |- e2 <== t\n ----------------------------- [Chk-If]\n G |- if v e1 e2 <== t\n -}\ncheck g (EIf v e1 e2 l) t = do\n _ <- check g (EImm v l) rBool\n c1 <- cAll l xv tT <$> check g e1 t\n c2 <- cAll l xv tF <$> check g e2 t\n return (cAnd c1 c2)\n where\n tT = predRType pv\n tF = predRType (F.PNot pv)\n pv = immExpr v\n xv = grdSym g\n\n{- [Chk-TLam]\n\n G, a |- e <== t\n ------------------------ [Chk-TLam]\n G |- Λ a. e <== all a. t\n-}\ncheck g (ETLam a e _) (TAll b t) | a == b = do\n check g e t\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsingleton :: F.Symbol -> RType -> RType\n\nsingleton x (TBase b (Known v p)) = TBase b (Known v (H.PAnd [p, v `peq` x]))\nsingleton _ t = t\n\npeq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred\npeq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))\n\nsynthImm :: Env -> SrcImm -> CG RType\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return (singleton x t)\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm _ (ECon c l) = return (constTy l c)\n\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t t := fresh(s)\n ---------------------------\n G |- e:s => t\n\n-}\nsynth g (EAnn e s l) = do\n t <- fresh l g s\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\n\n{- [Syn-TApp]\n\n G |- e ==> all a. s\n ---------------------------\n G |- e[t] ==> s [ a := t]\n\n-}\nsynth g (ETApp e t l) = do\n (ce, te) <- synth g e\n case te of\n TAll a s -> do tt <- {- Misc.traceShow \"REFRESH\" <$> -} refresh l g t\n return (ce, tsubst a tt s)\n _ -> failWith \"Type Application to non-forall\" l\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e))) (label e)\n\n-------------------------------------------------------------------------------\n-- | Fresh templates for `Unknown` refinements\n-------------------------------------------------------------------------------\nrefresh :: F.SrcSpan -> Env -> RType -> CG RType\nrefresh l g = fresh l g . go\n where\n go (TBase b _) = TBase b Unknown\n go (TFun b s t) = TFun b (go s) (go t)\n go (TAll a t) = TAll a (go t)\n\nfresh :: F.SrcSpan -> Env -> RType -> CG RType\nfresh l g (TBase b r) = TBase b <$> freshR l g b r\nfresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t\nfresh l g (TAll a t) = TAll a <$> fresh l g t\n\nfreshR :: F.SrcSpan -> Env -> Base -> Reft -> CG Reft\nfreshR _ _ _ r@(Known {}) = pure r\nfreshR l g b Unknown = freshK l g b\n" }, { "path": "src/Language/Sprite/L4/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L4.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll\n\n -- * Substitutions\n , subst, substImm\n\n -- * Conversions\n , predRType, baseSort\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv, extEnvTV, grdSym, envSorts\n\n -- * Constraint Generation Monad\n , CG, run, failWith, freshK\n\n ) where\n\nimport qualified Data.Maybe as Mb\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L4.Types\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd (H.CAnd []) c = c\ncAnd c (H.CAnd []) = c\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> H.Pred -> SrcCstr\ncHead _ (H.PAnd []) = cTrue\ncHead _ (H.Reft p)\n | F.isTautoPred p = cTrue\ncHead l p = H.Head p (UX.mkError \"Subtype error\" l)\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll l x t c = case sortPred x t of\n Just (so, p) -> H.All (bind l x so p) c\n _ -> c\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x (TBase b (Known v p)) = Just (baseSort b, subst p v x)\nsortPred _ _ = Nothing\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\nbaseSort TBool = F.boolSort\nbaseSort (TVar a) = F.FObj (F.symbol a)\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ndata Env = Env\n { eBinds :: !(F.SEnv RType) -- ^ value binders\n , eSize :: !Integer -- ^ number of binders?\n , eTVars :: !(F.SEnv ()) -- ^ type variables\n }\n\nextEnv :: Env -> F.Symbol -> RType -> Env\nextEnv env x t\n | x == junkSymbol = env\n | otherwise = env { eBinds = F.insertSEnv x t (eBinds env)\n , eSize = 1 + eSize env\n }\n\nextEnvTV :: Env -> TVar -> Env\nextEnvTV env (TV a) = env { eTVars = F.insertSEnv a () (eTVars env) }\n\ngrdSym :: Env -> F.Symbol\ngrdSym env = F.tempSymbol \"grd\" (eSize env)\n\npredRType :: F.Pred -> RType\npredRType p = TBase TBool (known $ F.predReft p)\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x (eBinds env)\n\nempEnv :: Env\nempEnv = Env F.emptySEnv 0 F.emptySEnv\n\n\n\nenvSorts :: Env -> [(F.Symbol, F.Sort)]\nenvSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)\n , (t, _) <- Mb.maybeToList (sortPred x s) ]\n\n-------------------------------------------------------------------------------\n-- | CG Monad -----------------------------------------------------------------\n-------------------------------------------------------------------------------\n\ntype CG a = StateT CGState (Either [UX.UserError]) a\n\ndata CGState = CGState\n { cgCount :: !Integer -- ^ monotonic counter, to get fresh things\n , cgKVars :: ![SrcHVar] -- ^ list of generated kvars\n }\n\ns0 :: CGState\ns0 = CGState 0 []\n\nrun :: CG a -> Either [UX.UserError] (a, [SrcHVar])\nrun act = do\n (x, s) <- runStateT act s0\n return (x, cgKVars s)\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = throwError [UX.mkError msg l]\n\nfreshK :: F.SrcSpan -> Env -> Base -> CG Reft\nfreshK l g b = do\n v <- freshValueSym\n k <- freshKVar l t ts\n return $ Known v (H.Var k (v:xs))\n where\n t = baseSort b\n (xs,ts) = unzip (envSorts g)\n\nfreshKVar :: F.SrcSpan -> F.Sort -> [F.Sort] -> CG F.Symbol\nfreshKVar l t ts = do\n k <- F.kv . F.intKvar <$> freshInt\n _ <- addSrcKVar (H.HVar k (t:ts) (UX.mkError \"fake\" l))\n return k\n\naddSrcKVar :: SrcHVar -> CG ()\naddSrcKVar k = modify $ \\s -> s { cgKVars = k : cgKVars s }\n\nfreshValueSym :: CG F.Symbol\nfreshValueSym = F.vv . Just <$> freshInt\n\nfreshInt :: CG Integer\nfreshInt = do\n s <- get\n let n = cgCount s\n put s { cgCount = 1 + n}\n return n\n" }, { "path": "src/Language/Sprite/L4/Elaborate.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n\nmodule Language.Sprite.L4.Elaborate (elaborate) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.List as L\nimport Control.Exception (throw)\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport Text.PrettyPrint.HughesPJ\n-- import Text.Printf (printf)\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.Common\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L4.Prims\nimport Language.Sprite.L4.Types\nimport Language.Sprite.L4.Constraints\nimport Control.Monad (void)\n-- import Debug.Trace (trace)\n\n-------------------------------------------------------------------------------\nelaborate :: SrcExpr -> ElbExpr\n-------------------------------------------------------------------------------\nelaborate e = {- trace msg -} e''\n where\n _msg = \"elaborate: \" ++ show (void e, void e'')\n e'' = subsTy su e'\n (su, e') = runElabM act\n act = elabC empEnv e (bTrue TInt)\n\nrunElabM :: ElabM a -> (TvSub, a)\nrunElabM act = case runStateT act s0 of\n Left errs -> throw errs\n Right (v, s) -> (eSub s, v)\n where s0 = ElabS mempty 0\n\ntype TvSub = F.SEnv RType\ndata ElabS = ElabS { eSub :: !TvSub, eNum :: !Int }\ntype ElabM a = StateT ElabS (Either [UX.UserError]) a\n\nunifyV :: F.SrcSpan -> TVar -> RType -> ElabM RType\nunifyV _ a t@(TBase (TVar b) r)\n | a == b\n = return t\n | nonRigid a\n = assign a t >> return t\n | nonRigid b\n = assign b t' >> return t' where t' = TBase (TVar a) r\n\nunifyV l a t\n | a `elem` freeTVars t\n = occurError l a t\n | nonRigid a\n = assign a t >> return t\n | otherwise\n = rigidError l a t\n\nunify :: F.SrcSpan -> RType -> RType -> ElabM RType\nunify l (TBase (TVar a) _) t =\n unifyV l a t\nunify l t (TBase (TVar a) _) =\n unifyV l a t\nunify _ t1@(TBase b1 _) (TBase b2 _) | b1 == b2 =\n return t1\nunify l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n x <- pure (unifyX l x1 x2)\n s <- unify l s1 s2\n t1' <- subsTyM t1\n t2' <- subsTyM t2\n t <- unify l t1' t2'\n return (TFun x s t)\nunify l t1 t2 =\n unifyError l t1 t2\n\nunifyX :: F.SrcSpan -> F.Symbol -> F.Symbol -> F.Symbol\nunifyX _ x _ = x\n\nunifyError :: F.SrcSpan -> RType -> RType -> ElabM a\nunifyError l t1 t2 = throwError [UX.mkError msg l]\n where msg = \"type error: cannot unify\" <+> UX.tshow t1 <+> \"and\" <+> UX.tshow t2\n\nrigidError :: F.SrcSpan -> TVar -> RType -> ElabM a\nrigidError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: cannot assign rigid\" <+> UX.tshow a <+> \"the type\" <+> UX.tshow t\n\noccurError :: F.SrcSpan -> TVar -> RType -> ElabM a\noccurError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: occurs check\" <+> UX.tshow a <+> \"occurs in\" <+> UX.tshow t\n\n-------------------------------------------------------------------------------\nelabC :: Env -> SrcExpr -> RType -> ElabM ElbExpr\nelabC g (EFun b e l) (TFun _ s t) = do\n e' <- elabC (extEnv g (bindId b) s) e t\n return $ EFun b e' l\n\n-- let rec x:s = e1 in e2\nelabC g (ELet (RDecl (Bind x l) (EAnn e1 s1 l1) ld) e2 l2) t2 = do\n let g' = extEnv g x s1\n let (as, t1) = splitTAll s1\n e1' <- elabC (extEnvTVs g' as) e1 t1\n e2' <- elabC g' e2 t2\n return $ ELet (RDecl (Bind x l) (EAnn (mkTLam e1' as) s1 l1) ld) e2' l2\n\n-- let x = e in e'\nelabC g (ELet (Decl (Bind x l) e1 l1) e2 l2) t2 = do\n (e1', s) <- elabS g e1\n e2' <- elabC (extEnv g x s) e2 t2\n return $ ELet (Decl (Bind x l) e1' l1) e2' l2\n\n-- if b e1 e2\nelabC g (EIf b e1 e2 l) t = do\n e1' <- elabC g e1 t\n e2' <- elabC g e2 t\n return $ EIf b e1' e2' l\n\nelabC g e t = do\n (e', t') <- elabS g e\n unify (label e) t t'\n return e'\n\nimmS :: Env -> SrcImm -> ElabM ([RType], RType)\nimmS g i = instantiate =<< immTy g i\n\nextEnvTVs :: Env -> [TVar] -> Env\nextEnvTVs = foldr (flip extEnvTV)\n\n-------------------------------------------------------------------------------\nelabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType)\nelabS g e@(EImm i _) = do\n (ts, t') <- {- Misc.traceShow (\"elabS\" ++ show i) <$> -} immS g i\n return (mkTApp e ts, t')\n\nelabS g (EAnn e s l) = do\n let (as, t) = splitTAll s\n e' <- elabC (extEnvTVs g as) e t\n return (EAnn (mkTLam e' as) s l, s)\n\nelabS g (EApp e y l) = do\n (e', te) <- elabS g e\n case te of\n TFun _ s t -> do unify l s =<< immTy g y\n return (EApp e' y l, t)\n _ -> elabErr \"Application to non-function\" l\n\nelabS _ e =\n elabErr (\"elabS unexpected:\" <+> UX.tshow (void e)) (label e)\n\n\n-------------------------------------------------------------------------------\n\nelabErr :: UX.Text -> F.SrcSpan -> ElabM a\nelabErr msg l = throwError [UX.mkError msg l]\n\ninstantiate :: RType -> ElabM ([RType], RType)\ninstantiate = go []\n where\n go ts (TAll a s) = do v <- fresh\n let vt = TBase (TVar v) mempty\n go (vt:ts) (tsubst a vt s)\n go ts s = return (reverse ts, s)\n\nsplitTAll :: RType -> ([TVar], RType)\nsplitTAll (TAll a s) = (a:as, t) where (as, t) = splitTAll s\nsplitTAll t = ([] , t)\n\nfresh :: ElabM TVar\nfresh = do\n s <- get\n let n = eNum s\n put s { eNum = n + 1 }\n return (nonRigidTV n)\n\nnonRigidTV :: Int -> TVar\nnonRigidTV = TV . F.intSymbol \"fv\"\n\nnonRigid :: TVar -> Bool\nnonRigid (TV a) = F.isPrefixOfSym \"fv\" a\n\nimmTy :: Env -> SrcImm -> ElabM RType\nimmTy g (EVar x l)\n | Just t <- getEnv g x = return ({- Misc.traceShow (\"immTy: \" ++ show x) -} t)\n | otherwise = elabErr (\"Unbound variable:\" <+> F.pprint x) l\nimmTy _ (ECon c l) = return (constTy l c)\n\nmkTLam :: SrcExpr -> [TVar] -> ElbExpr\nmkTLam = foldr (\\a e -> ETLam a e (label e))\n\nmkTApp :: SrcExpr -> [RType] -> ElbExpr\nmkTApp = L.foldl' (\\e t -> ETApp e t (label e))\n\n-- | Type Substitutions --------------------------------------------------------------\n\nclass SubsTy a where\n subsTy :: TvSub -> a -> a\n subsTy1 :: TVar -> RType -> a -> a\n subsTy1 a t x = subsTy (singTvSub a t) x\n\nsingTvSub :: TVar -> RType -> TvSub\nsingTvSub a t = F.fromListSEnv [(F.symbol a, t)]\n\ninstance SubsTy RType where\n subsTy su t@(TBase (TVar a) _) = Mb.fromMaybe t t'\n where\n t' = F.lookupSEnv (F.symbol a) su\n\n subsTy _su t@(TBase {}) = t\n\n subsTy su (TFun x s t) = TFun x s' t'\n where\n s' = subsTy su s\n t' = subsTy su t\n\n subsTy su (TAll a t) = TAll a t'\n where\n t' = subsTy su' t\n su' = F.deleteSEnv (F.symbol a) su\n\ninstance SubsTy TvSub where\n subsTy = F.mapSEnv . subsTy\n\n-- applies the substs to the ETApp types\ninstance SubsTy ElbExpr where\n subsTy = subsTyExpr\n\ninstance SubsTy ElbDecl where\n subsTy su (Decl b e l) = Decl b (subsTy su e) l\n subsTy su (RDecl b e l) = RDecl b (subsTy su e) l\n\nsubsTyExpr :: TvSub -> ElbExpr -> ElbExpr\nsubsTyExpr su = go\n where\n go (EFun b e l) = EFun b (go e) l\n go (EApp e i l) = EApp (go e) i l\n go (ELet d e l) = ELet d' (go e) l where d' = subsTy su d\n go (EAnn e t l) = EAnn (go e) t l\n go (EIf i e1 e2 l) = EIf i (go e1) (go e2) l\n go (ETLam a e l) = ETLam a (go e) l\n go (ETApp e t l) = ETApp (go e) (subsTy su t) l\n go e@(EImm {}) = e\n\n\n\n\n\nsubsTyM :: (SubsTy a) => a -> ElabM a\nsubsTyM x = do\n su <- gets eSub\n return (subsTy su x)\n\nassign :: TVar -> RType -> ElabM ()\nassign a t = modify $ \\s -> s { eSub = updSub a t (eSub s)}\n\nupdSub :: TVar -> RType -> TvSub -> TvSub\nupdSub a t su = F.insertSEnv (F.symbol a) t (subsTy1 a t su)\n" }, { "path": "src/Language/Sprite/L4/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L4.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , rtype\n , expr\n ) where\n\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport Control.Monad.Combinators.Expr\nimport Text.Megaparsec hiding (State, label)\nimport Text.Megaparsec.Char\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport Language.Sprite.Common\nimport Language.Sprite.Common.Parse\nimport Language.Sprite.L4.Types hiding (immExpr)\nimport Language.Sprite.L4.Constraints\n\nparseFile :: FilePath -> IO ([F.Qualifier], SrcExpr)\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser ([F.Qualifier], SrcExpr)\nprog = do\n qs <- quals\n src <- declsExpr <$> many decl\n return (qs, src)\n\nquals :: FP.Parser [F.Qualifier]\nquals = try ((:) <$> between annL annR qual <*> quals)\n <|> pure []\n\nqual ::FP.Parser F.Qualifier\nqual = reserved \"qualif\" >> FP.qualifierP (baseSort <$> tbase)\n\nexpr :: FP.Parser SrcExpr\nexpr = try funExpr\n <|> try letExpr\n <|> try ifExpr\n <|> try (FP.braces (expr <* whiteSpace))\n <|> try appExpr\n <|> try binExp\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try (FP.parens expr)\n <|> immExpr\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> immExpr <*> parens (sepBy1 imm comma)\n\nbinExp :: FP.Parser SrcExpr\nbinExp = withSpan' $ do\n x <- imm\n o <- op\n y <- imm\n return (bop o x y)\n\nop :: FP.Parser PrimOp\nop = (FP.reservedOp \"*\" >> pure BTimes)\n <|> (FP.reservedOp \"+\" >> pure BPlus )\n <|> (FP.reservedOp \"-\" >> pure BMinus)\n <|> (FP.reservedOp \"<\" >> pure BLt )\n <|> (FP.reservedOp \"<=\" >> pure BLe )\n <|> (FP.reservedOp \"==\" >> pure BEq )\n <|> (FP.reservedOp \">\" >> pure BGt )\n <|> (FP.reservedOp \">=\" >> pure BGe )\n <|> (FP.reservedOp \"&&\" >> pure BAnd )\n <|> (FP.reservedOp \"||\" >> pure BOr )\n\nbop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr\nbop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nifExpr :: FP.Parser SrcExpr\nifExpr = withSpan' $ do\n FP.reserved \"if\"\n v <- parens imm\n e1 <- expr\n FP.reserved \"else\"\n e2 <- expr\n return (EIf v e1 e2)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = immInt <|> immBool <|> immId\n\nimmInt :: FP.Parser SrcImm\nimmInt = withSpan' (ECon . PInt <$> FP.natural)\n\nimmBool :: FP.Parser SrcImm\nimmBool = withSpan' (ECon . PBool <$> bool)\n\nimmId :: FP.Parser SrcImm\nimmId = withSpan' (EVar <$> identifier)\n\nbool :: FP.Parser Bool\nbool = (reserved \"true\" >> pure True)\n <|>(reserved \"false\" >> pure False)\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- parens (sepBy1 binder comma)\n _ <- FP.reservedOp \"=>\"\n -- _ <- FP.reservedOp \"{\"\n body <- braces (expr <* whiteSpace)\n -- _ <- FP.reservedOp \"}\"\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = mkDecl <$> ann <*> plainDecl\n\ntype Ann = Maybe (F.Symbol, RType)\n\nannL, annR :: FP.Parser ()\nannL = reservedOp \"/*@\"\nannR = reservedOp \"*/\"\n\nann :: FP.Parser Ann\nann = (annL >> (Just <$> annot)) <|> pure Nothing\n\nannot :: FP.Parser (F.Symbol, RType)\nannot = do\n reserved \"val\"\n x <- identifier\n colon\n t <- rtype\n annR\n return (x, t)\n\n{-\nbetween :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a\nbetween lP rP xP = do\n lP\n x <- xP\n rP\n return x\n -}\nmkDecl :: Ann -> SrcDecl -> SrcDecl\nmkDecl (Just (x, t)) (Decl b e l)\n | x == bindId b = Decl b (EAnn e (generalize t) (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl (Just (x, t)) (RDecl b e l)\n | x == bindId b = RDecl b (EAnn e (generalize t) (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl Nothing d = d\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n ctor <- (FP.reserved \"let rec\" >> pure RDecl) <|>\n (FP.reserved \"let\" >> pure Decl)\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (ctor b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = try rfun <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArg <*> (FP.reservedOp \"=>\" *> rtype)\n\nfunArg :: FP.Parser (F.Symbol, RType)\nfunArg = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = TBase <$> tbase <*> refTop\n\ntbase :: FP.Parser Base\ntbase = (reserved \"int\" >> pure TInt)\n <|> (reserved \"bool\" >> pure TBool)\n <|> tvarP\n\ntvarP :: FP.Parser Base\ntvarP = FP.reservedOp \"'\" >> FP.lowerIdP >>= return . TVar . TV\n\n-- tVar :: F.Symbol -> Base\n-- tVar = TVar . TV\n\nrefTop :: FP.Parser Reft\nrefTop = brackets reftB <|> pure mempty\n\nreftB :: FP.Parser Reft\nreftB = (question >> pure Unknown)\n <|> KReft <$> (FP.lowerIdP <* mid) <*> FP.predP\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\nquestion :: FP.Parser ()\nquestion = FP.reservedOp \"?\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))\n\n\n-- | list of reserved words\nkeywords :: S.Set String\nkeywords = S.fromList\n [ \"if\" , \"else\"\n , \"true\" , \"false\"\n , \"let\" , \"in\"\n , \"int\"\n ]\n" }, { "path": "src/Language/Sprite/L4/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L4.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.L4.Types \nimport Language.Sprite.L4.Parse\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n)) \nconstTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)\nconstTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)\nconstTy l (PBin o) = binOpTy l o\n\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n\n , (BLt , mkTy \"x:int => y:int => bool[v|v <=> (x < y)]\")\n , (BLe , mkTy \"x:int => y:int => bool[v|v <=> (x <= y)]\")\n , (BGt , mkTy \"x:int => y:int => bool[v|v <=> (x > y)]\")\n , (BGe , mkTy \"x:int => y:int => bool[v|v <=> (x >= y)]\")\n , (BEq , mkTy \"x:int => y:int => bool[v|v <=> (x == y)]\")\n\n , (BAnd , mkTy \"x:bool => y:bool => bool[v|v <=> (x && y)]\")\n , (BOr , mkTy \"x:bool => y:bool => bool[v|v <=> (x || y)]\")\n , (BNot , mkTy \"x:bool => bool[v|v <=> not x]\")\n ]\n\nmkTy :: String -> RType\nmkTy = rebind . parseWith rtype \"prims\" \n\n\nrebind :: RType -> RType\nrebind t@(TBase {}) = t \nrebind (TAll a t) = TAll a (rebind t) \nrebind (TFun x s t) = TFun x' s' t' \n where \n x' = F.mappendSym \"spec#\" x\n s' = subst (rebind s) x x'\n t' = subst (rebind t) x x'" }, { "path": "src/Language/Sprite/L4/Types.hs", "content": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L4.Types where \n\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Misc as Misc \nimport Language.Sprite.Common\nimport qualified Data.Set as S\n\n-- | Basic types --------------------------------------------------------------\nnewtype TVar = TV F.Symbol\n deriving (Eq, Ord, Show)\n\ninstance F.Symbolic TVar where \n symbol (TV a) = a\n\ndata Base = TInt | TBool | TVar TVar\n deriving (Eq, Ord, Show)\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r \n = TBase !Base r -- ^ Int{r} \n | TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t \n | TAll !TVar !(Type r)\n deriving (Eq, Ord, Show)\n\nrInt :: RType \nrInt = TBase TInt mempty\n\nrBool :: RType \nrBool = TBase TBool mempty \n\ndata Reft \n = Known !F.Symbol !H.Pred -- ^ Known refinement\n | Unknown -- ^ Unknown, to-be-synth refinement\n deriving (Show)\n\nknown :: F.Reft -> Reft\nknown (F.Reft (v, r)) = KReft v r\n\npattern KReft v p = Known v (H.Reft p)\n\ninstance Semigroup Reft where \n Unknown <> r = r\n r <> Unknown = r\n-- KReft v1 r1 <> KReft v2 r2 = KReft v r where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)\n Known v p <> Known v' p' \n | v == v' = Known v (p <> p')\n | v == F.dummySymbol = Known v' (p' <> (p `F.subst1` (v , F.EVar v')))\n | otherwise = Known v (p <> (p' `F.subst1` (v', F.EVar v )))\n-- _ <> _ = error \"Semigroup Reft: TBD\"\n \ninstance Monoid Reft where \n mempty = KReft v r where F.Reft (v, r) = mempty\n\ntype RType = Type Reft\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp \n = BPlus \n | BMinus \n | BTimes\n | BLt\n | BLe\n | BEq \n | BGt\n | BGe\n | BAnd\n | BOr\n | BNot\n deriving (Eq, Ord, Show)\n\ndata Prim \n = PInt !Integer -- 0,1,2,... \n | PBool !Bool -- true, false\n | PBin !PrimOp -- +,-,==,<=,...\n deriving (Eq, Ord, Show)\n\n---------------------------------------------------------------------------------\n-- | Terms ----------------------------------------------------------------------\n---------------------------------------------------------------------------------\n\n-- | Bindings -------------------------------------------------------------------\n\ndata Bind a \n = Bind !F.Symbol a\n deriving (Eq, Ord, Show, Functor)\n\nbindId :: Bind a -> F.Symbol \nbindId (Bind x _) = x\n\njunkSymbol :: F.Symbol\njunkSymbol = \"_\"\n\n-- | \"Immediate\" terms (can appear as function args & in refinements) -----------\n\ndata Imm a\n = EVar !F.Symbol a\n | ECon !Prim a\n deriving (Show, Functor)\n\n-- | Variable definition ---------------------------------------------------------\ndata Decl a \n = Decl (Bind a) (Expr a) a -- plain \"let\" \n | RDecl (Bind a) (Expr a) a -- recursive \"let rec\"\n deriving (Show, Functor)\n\n-- | Terms -----------------------------------------------------------------------\n\ndata Expr a \n = EImm !(Imm a) a -- ^ x,y,z,... 1,2,3...\n | EFun !(Bind a) !(Expr a) a -- ^ \\x -> e\n | EApp !(Expr a) !(Imm a) a -- ^ e v\n | ELet !(Decl a) !(Expr a) a -- ^ let/rec x = e1 in e2\n | EAnn !(Expr a) !RType a -- ^ e:t\n | EIf !(Imm a) !(Expr a) !(Expr a) a -- ^ if v e1 e2\n | ETLam !TVar !(Expr a) a -- ^ Λ a. e (type abstraction)\n | ETApp !(Expr a) !RType a -- ^ e [t] (type application)\n deriving (Show, Functor)\n\ninstance Label Imm where \n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where \n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ l) = l\n label (EIf _ _ _ l) = l\n label (ETLam _ _ l) = l\n label (ETApp _ _ l) = l\n \ninstance Label Decl where \n label (Decl _ _ l) = l\n label (RDecl _ _ l) = l\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d \ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d \ndeclsExpr _ = error \"impossible\"\n\nintExpr :: Integer -> a -> Expr a \nintExpr i l = EImm (ECon (PInt i) l) l\n\nboolExpr :: Bool -> a -> Expr a\nboolExpr b l = EImm (ECon (PBool b) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\ntype ElbDecl = Decl F.SrcSpan\ntype ElbExpr = Expr F.SrcSpan \n------------------------------------------------------------------------------\n\n-- | should/need only be defined on \"Known\" variants. TODO:LIQUID\ninstance F.Subable Reft where \n syms (Known v r) = v : F.syms r\n syms Unknown = []\n substa f (Known v r) = Known (f v) (F.substa f r)\n substa _ (Unknown) = Unknown\n substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r) \n substf _ (Unknown) = Unknown\n subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)\n subst _ (Unknown) = Unknown\n subst1 (Known v r) su = Known v (F.subst1Except [v] r su)\n subst1 (Unknown) _ = Unknown\n\ninstance F.Subable r => F.Subable (Type r) where \n -- syms :: a -> [Symbol] \n syms (TBase _ r) = F.syms r\n syms (TAll _ t) = F.syms t\n syms (TFun _ s t) = F.syms s ++ F.syms t\n\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r \n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n substa f (TAll a t) = TAll a (F.substa f t)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n substf f (TAll a t) = TAll a (F.substf f t)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n subst f (TAll a t) = TAll a (F.subst f t)\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where \n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\nimmExpr (ECon (PBool True) _) = F.PTrue\nimmExpr (ECon (PBool False) _) = F.PFalse\nimmExpr _ = error \"impossible\"\n\n\n--------------------------------------------------------------------------------\n-- | Dealing with Type Variables -----------------------------------------------\n--------------------------------------------------------------------------------\ntsubst :: TVar -> RType -> RType -> RType\ntsubst a t = go \n where \n go (TAll b s) \n | a == b = TAll b s \n | otherwise = TAll b (go s)\n go (TFun x s1 s2) = TFun x (go s1) (go s2) \n go (TBase b r) = bsubst a t b r\n \nbsubst :: TVar -> RType -> Base -> Reft -> RType \nbsubst a t (TVar v) r \n | v == a = strengthenTop t r \nbsubst _ _ b r = TBase b r\n \nstrengthenTop :: RType -> Reft -> RType\nstrengthenTop t@(TFun {}) _ = t\nstrengthenTop t@(TAll {}) _ = t\nstrengthenTop (TBase b r) r' = TBase b (r <> r')\n\ngeneralize :: RType -> RType\ngeneralize t = foldr TAll t (freeTVars t) \n\nfreeTVars :: RType -> [TVar]\nfreeTVars = Misc.sortNub . S.toList . go\n where \n go (TAll a t) = S.delete a (go t) \n go (TFun _ s t) = S.union (go s) (go t)\n go (TBase b _) = goB b \n goB (TVar a) = S.singleton a\n goB _ = S.empty\n\n" }, { "path": "src/Language/Sprite/L4.hs", "content": "module Language.Sprite.L4 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.L4.Check\nimport Language.Sprite.L4.Parse\nimport Language.Sprite.Common\n\n--------------------------------------------------------------------------------\nsprite :: FilePath -> IO ()\n--------------------------------------------------------------------------------\nsprite f = do\n src <- parseFile f\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValid f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "src/Language/Sprite/L5/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Use uncurry\" #-}\nmodule Language.Sprite.L5.Check (vcgen) where\n\nimport Control.Monad (void)\nimport qualified Data.HashMap.Strict as M\n-- import qualified Data.Maybe as Mb\n-- import qualified Data.Map as M\nimport Text.PrettyPrint.HughesPJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common\nimport Language.Sprite.L5.Types\nimport Language.Sprite.L5.Prims\nimport Language.Sprite.L5.Constraints\nimport Language.Sprite.L5.Elaborate\n-- import Debug.Trace (trace)\n\n-------------------------------------------------------------------------------\nvcgen:: SrcProg -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen (Prog qs ms e typs) = do\n let env = empEnv typs\n let eL = elaborate env e\n (c, ks) <- run (check env eL (bTrue TInt))\n return $ H.Query qs ks c (M.fromList ms) mempty mempty mempty mempty mempty\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n\n -}\nsub l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith (\"Invalid Subtyping: \" <+> F.pprint (b1, b2)) l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 s2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n{- | [Sub-TCon]\n\n G,v:int{p} |- q[w:=v] G |- si <: ti\n -----------------------------------------\n G |- (C s1...)[v|p] <: (C t1...)[w|q]\n\n -}\n\nsub l s@(TCon c1 t1s (Known v _)) (TCon c2 t2s (Known w q)) | c1 == c2 = do\n let cTop = cAll l v s (cHead l (subst q w v))\n cIns <- subs l t1s t2s\n return (Misc.traceShow \"SUB-LIST\" $ cAnd cTop cIns)\n\nsub l t1 t2 = failWith (\"sub: cannot handle:\" <+> UX.tshow (t1, t2)) l\n\n\nsubs :: F.SrcSpan -> [RType] -> [RType] -> CG SrcCstr\nsubs _ [] [] = return cTrue\nsubs l (t1:t1s) (t2:t2s) = cAnd <$> sub l t1 t2 <*> subs l t1s t2s\nsubs l _ _ = failWith \"subs: invalid args\" l\n\n--------------------------------------------------------------------\n-- | 'Checking' constraints\n--------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n--------------------------------------------------------------------\n{- [Chk-Lam]\n\n G, x:s[y:=x] |- e <== t[y:=x]\n -----------------------------\n G |- \\x.e <== y:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) = do\n c <- check (extEnv g x s') e t'\n return $ cAll l x s c\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n\n{- [Chk-Let]\n\n G |- e ==> s G, x:s |- e' <== t'\n -------------------------------------------\n G |- let x = e in e' <== t'\n\n-}\ncheck g (ELet (Decl (Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g x s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Rec]\n\n t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'\n ---------------------------------------------------------[Chk-Rec]\n G |- letrec f = (e:s) in e' <== t'\n\n -}\ncheck g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do\n t <- fresh l g s\n let g' = extEnv g x t\n c <- check g' e t\n c' <- check g' e' t'\n return $ cAnd c c'\n\n{- [Chk-If]\n G |- v <== bool\n G, _:{v} |- e1 <== t\n G, _:{not v} |- e2 <== t\n ----------------------------- [Chk-If]\n G |- if v e1 e2 <== t\n -}\ncheck g (EIf v e1 e2 l) t = do\n _ <- check g (EImm v l) rBool\n c1 <- cAll l xv tT <$> check g e1 t\n c2 <- cAll l xv tF <$> check g e2 t\n return (cAnd c1 c2)\n where\n tT = predRType pv\n tF = predRType (F.PNot pv)\n pv = immExpr v\n xv = grdSym g\n\n{- [Chk-Switch]\n\n G | y |- a_i <== t\n ---------------------------\n G |- switch y {a_1...} <== t\n-}\n\ncheck g (ECase y alts _) t = do\n H.CAnd <$> mapM (checkAlt g y t) alts\n\n\n{- [Chk-TLam]\n\n G, a |- e <== t\n ------------------------ [Chk-TLam]\n G |- Λ a. e <== all a. t\n-}\ncheck g (ETLam a e _) (TAll b t) | a == b = do\n check g e t\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n{- [Chk-Alt]\n\n unfold(G, c, y) === s G | y + z... * s ~~> G' G' |- e <== t\n ---------------------------------------------------------------\n G | y |- C z... -> e <== t\n\n-}\ncheckAlt :: Env -> Ident -> RType -> SrcAlt -> CG SrcCstr\ncheckAlt g y t (Alt c zs e l) = do\n let al = mconcat (label <$> zs)\n case unfoldEnv g y c zs of\n Nothing -> failWith \"checkAlt: incompatible pattern\" al\n Just zts -> cAlls l zts <$> check (extEnvs g zts) e t\n\ncAlls :: F.SrcSpan -> [(F.Symbol, RType)] -> SrcCstr -> SrcCstr\ncAlls l xts c = foldr (\\(x, t) -> cAll l x t) c (reverse xts)\n\n-- cAlls l [] c = c\n-- cAlls l ((x,t):xts) c = cAll l xts (cAll l x t c)\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsingleton :: F.Symbol -> RType -> RType\nsingleton x (TBase b (Known v p)) = TBase b (Known v (pAnd [p, v `peq` x]))\nsingleton x (TCon c ts (Known v p)) = TCon c ts (Known v (pAnd [p, v `peq` x]))\nsingleton _ t = t\n\npeq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred\npeq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))\n\nsynthImm :: Env -> SrcImm -> CG RType\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return (singleton x t)\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm _ (ECon c l) = return (constTy l c)\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t t := fresh(s)\n ---------------------------\n G |- e:s => t\n\n-}\nsynth g (EAnn e s l) = do\n t <- fresh l g s\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\n\n{- [Syn-TApp]\n\n G |- e ==> all a. s\n ---------------------------\n G |- e[t] ==> s [ a := t]\n\n-}\nsynth g (ETApp e t l) = do\n (ce, te) <- synth g e\n case te of\n TAll a s -> do tt <- {- Misc.traceShow \"REFRESH\" <$> -} refresh l g t\n return (ce, Misc.traceShow \"SYN-TApp: \" $ tsubst a tt s)\n _ -> failWith \"Type Application to non-forall\" l\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e))) (label e)\n\n-------------------------------------------------------------------------------\n-- | Fresh templates for `Unknown` refinements\n-------------------------------------------------------------------------------\nrefresh :: F.SrcSpan -> Env -> RType -> CG RType\nrefresh l g = fresh l g . go\n where\n go (TBase b _) = TBase b Unknown\n go (TFun b s t) = TFun b (go s) (go t)\n go (TCon c ts _) = TCon c (go <$> ts) Unknown\n go (TAll a t) = TAll a (go t)\n\nfresh :: F.SrcSpan -> Env -> RType -> CG RType\nfresh l g t@(TBase b r) = TBase b <$> freshR l g (rTypeSort t) r\nfresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t\nfresh l g t@(TCon c ts r) = TCon c <$> mapM (fresh l g) ts <*> freshR l g (rTypeSort t) r\nfresh l g (TAll a t) = TAll a <$> fresh l g t\n\nfreshR :: F.SrcSpan -> Env -> F.Sort -> Reft -> CG Reft\nfreshR _ _ _ r@(Known {}) = pure r\nfreshR l g t Unknown = freshK l g t\n" }, { "path": "src/Language/Sprite/L5/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L5.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll, pAnd\n\n -- * Substitutions\n , subst, substImm\n\n -- * Conversions\n , predRType, rTypeSort\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv, extEnvs\n , extEnvTV, grdSym, envSorts\n\n -- * Case-Related manipulation\n , unfoldEnv, unfoldEnv'\n\n -- * Constraint Generation Monad\n , CG, run, failWith, freshK\n\n ) where\n\nimport qualified Data.List as L\nimport qualified Data.Maybe as Mb\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common\nimport Language.Sprite.L5.Types\nimport Language.Sprite.L5.Prims\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd (H.CAnd []) c = c\ncAnd c (H.CAnd []) = c\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> H.Pred -> SrcCstr\ncHead _ (H.Reft p)\n | F.isTautoPred p = cTrue\ncHead l (H.PAnd ps) = case filter (not . pTrivial) ps of\n [] -> cTrue\n [p] -> mkHead l p\n qs -> mkHead l (H.PAnd qs)\ncHead l p = mkHead l p\n\nmkHead :: F.SrcSpan -> H.Pred -> SrcCstr\nmkHead l p = case smash p of\n [] -> cTrue\n [q] -> mk1 l q\n qs -> H.CAnd (mk1 l <$> qs)\n\nmk1 :: F.SrcSpan -> H.Pred -> SrcCstr\nmk1 l p = H.Head p (UX.mkError \"Subtype error\" l)\n\nsmash :: H.Pred -> [H.Pred]\nsmash (H.PAnd ps) = concatMap smash ps\nsmash p = [p]\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll l x t c = case sortPred x t of\n Just (so, p) -> H.All (bind l x so p) c\n _ -> c\n\npAnd :: [H.Pred] -> H.Pred\npAnd ps = case filter (not . pTrivial) ps of\n [p] -> p\n ps' -> H.PAnd ps'\n\npTrivial :: H.Pred -> Bool\npTrivial (H.PAnd []) = True\npTrivial (H.Reft p) = F.isTautoPred p\npTrivial _ = False\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x t@(TBase _ (Known v p)) = Just (rTypeSort t, subst p v x)\nsortPred x t@(TCon _ _ (Known v p)) = Just (rTypeSort t, subst p v x)\nsortPred _ _ = Nothing\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ndata Env = Env\n { eBinds :: !(F.SEnv RType) -- ^ value binders\n , eSize :: !Integer -- ^ number of binders?\n , eTVars :: !(F.SEnv ()) -- ^ type variables\n }\n\nextEnv :: Env -> F.Symbol -> RType -> Env\nextEnv env x t\n | x == junkSymbol = env\n | otherwise = env { eBinds = F.insertSEnv x t (eBinds env)\n , eSize = 1 + eSize env\n }\n\nextEnvs :: Env -> [(F.Symbol, RType)] -> Env\nextEnvs = L.foldl' (\\g (x, t) -> extEnv g x t)\n\nextEnvTV :: Env -> TVar -> Env\nextEnvTV env (TV a) = env { eTVars = F.insertSEnv a () (eTVars env) }\n\ngrdSym :: Env -> F.Symbol\ngrdSym env = F.tempSymbol \"grd\" (eSize env)\n\npredRType :: F.Pred -> RType\npredRType p = TBase TBool (known $ F.predReft p)\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x (eBinds env)\n\nempEnv :: [SrcData] -> Env\nempEnv typs = Env ctorEnv 0 F.emptySEnv\n where\n ctorEnv = F.fromListSEnv (prelude ++ concatMap dataSigs typs)\n\n\n\ndataSigs :: SrcData -> [(F.Symbol, RType)]\ndataSigs (Data _ _ ctors) = [(F.symbol b, t) | (b, t) <- ctors]\n\n\nenvSorts :: Env -> [(F.Symbol, F.Sort)]\nenvSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)\n , (t, _) <- Mb.maybeToList (sortPred x s) ]\n\n--------------------------------------------------------------------------------\n-- | Case-Related Environment Manipulation -------------------------------------\n--------------------------------------------------------------------------------\nunfoldEnv' :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe Env\nunfoldEnv' g y c zs = extEnvs g <$> unfoldEnv g y c zs\n\nunfoldEnv :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe [(F.Symbol, RType)]\nunfoldEnv g y c zs = unfold g c y >>= extCase y zs\n\nunfold:: Env -> DaCon -> Ident -> Maybe (RType, RType)\nunfold g c y = do\n sig <- getEnv g c\n ty@(TCon _ ts _) <- getEnv g y\n let (as, t) = bkAll sig\n ats <- Misc.safeZip as ts\n return (ty, tsubsts ats t)\n\nextCase :: Ident -> [SrcBind] -> (RType, RType) -> Maybe [(F.Symbol, RType)]\nextCase y zs (ty, t) = go [] (F.symbol <$> zs) t\n where\n go acc (z:zs) (TFun x s t) = go ((z, s) : acc) zs (subst t x z)\n go acc [] t = Just ((y, meet ty t) : acc)\n go _ _ _ = Nothing\n\nmeet :: RType -> RType -> RType\nmeet t1 t2 = case rTypeReft t2 of\n Just r2 -> strengthenTop t1 r2\n Nothing -> t1\n\n{-\nextCaseEnv :: Env -> [Bind F.SrcSpan] -> RType -> Maybe Env\nextCaseEnv g (z:zs) (TFun _ s t) = extCaseEnv g' zs t\n where\n g' = extEnv g (F.symbol z) s\nextCaseEnv g [] _ = Just g\nextCaseEnv _ _ _ = Nothing\n\n-}\n\n\n\n-------------------------------------------------------------------------------\n-- | CG Monad -----------------------------------------------------------------\n-------------------------------------------------------------------------------\n\ntype CG a = StateT CGState (Either [UX.UserError]) a\n\ndata CGState = CGState\n { cgCount :: !Integer -- ^ monotonic counter, to get fresh things\n , cgKVars :: ![SrcHVar] -- ^ list of generated kvars\n }\n\ns0 :: CGState\ns0 = CGState 0 []\n\nrun :: CG a -> Either [UX.UserError] (a, [SrcHVar])\nrun act = do\n (x, s) <- runStateT act s0\n return (x, cgKVars s)\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = throwError [UX.mkError msg l]\n\nfreshK :: F.SrcSpan -> Env -> F.Sort -> CG Reft\nfreshK l g t = do\n v <- freshValueSym\n k <- freshKVar l t ts\n return $ Known v (H.Var k (v:xs))\n where\n -- t = baseSort b\n (xs,ts) = unzip (envSorts g)\n\nfreshKVar :: F.SrcSpan -> F.Sort -> [F.Sort] -> CG F.Symbol\nfreshKVar l t ts = do\n k <- F.kv . F.intKvar <$> freshInt\n _ <- addSrcKVar (H.HVar k (t:ts) (UX.mkError \"fake\" l))\n return k\n\naddSrcKVar :: SrcHVar -> CG ()\naddSrcKVar k = modify $ \\s -> s { cgKVars = k : cgKVars s }\n\nfreshValueSym :: CG F.Symbol\nfreshValueSym = F.vv . Just <$> freshInt\n\nfreshInt :: CG Integer\nfreshInt = do\n s <- get\n let n = cgCount s\n put s { cgCount = 1 + n}\n return n\n" }, { "path": "src/Language/Sprite/L5/Elaborate.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n\nmodule Language.Sprite.L5.Elaborate (elaborate) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.List as L\nimport Control.Exception (throw)\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport Text.PrettyPrint.HughesPJ\n-- import Text.Printf (printf)\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.Common\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L5.Prims\nimport Language.Sprite.L5.Types\nimport Language.Sprite.L5.Constraints\nimport Debug.Trace (trace)\nimport Control.Monad (void)\n\n-------------------------------------------------------------------------------\nelaborate :: Env -> SrcExpr -> ElbExpr\n-------------------------------------------------------------------------------\nelaborate g e = {- trace _msg -} e''\n where\n _msg = \"elaborate: \" ++ show (F.toListSEnv su, void e, void e'')\n e'' = subsTy su e'\n (su, e') = runElabM act\n act = elabC g e (bTrue TInt)\n\nrunElabM :: ElabM a -> (TvSub, a)\nrunElabM act = case runStateT act s0 of\n Left errs -> throw errs\n Right (v, s) -> (eSub s, v)\n where s0 = ElabS mempty 0\n\ntype TvSub = F.SEnv RType\ndata ElabS = ElabS { eSub :: !TvSub, eNum :: !Int }\ntype ElabM a = StateT ElabS (Either [UX.UserError]) a\n\nunifyV :: F.SrcSpan -> TVar -> RType -> ElabM RType\nunifyV _ a t@(TBase (TVar b) r)\n | a == b\n = return t\n | nonRigid a\n = assign a t >> return t\n | nonRigid b\n = assign b t' >> return t' where t' = TBase (TVar a) r\n\nunifyV l a t\n | a `elem` freeTVars t\n = occurError l a t\n | nonRigid a\n = assign a t >> return t\n | otherwise\n = rigidError l a t\n\nunify :: F.SrcSpan -> RType -> RType -> ElabM RType\nunify l (TBase (TVar a) _) t =\n unifyV l a t\nunify l t (TBase (TVar a) _) =\n unifyV l a t\nunify _ t1@(TBase b1 _) (TBase b2 _) | b1 == b2 =\n return t1\nunify l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n x <- pure (unifyX l x1 x2)\n s <- unify l s1 s2\n t1' <- subsTyM t1\n t2' <- subsTyM t2\n t <- unify l t1' t2'\n return (TFun x s t)\nunify l (TCon c1 t1s _) (TCon c2 t2s _) | c1 == c2 = do\n ts <- unifys l t1s t2s\n return (TCon c1 ts mempty)\n\nunify l t1 t2 =\n unifyError l t1 t2\n\nunifys :: F.SrcSpan -> [RType] -> [RType] -> ElabM [RType]\nunifys _ [] [] =\n return []\nunifys l (t1:t1s) (t2:t2s) = do\n t <- unify l t1 t2\n t1s' <- mapM subsTyM t1s\n t2s' <- mapM subsTyM t2s\n ts <- unifys l t1s' t2s'\n return (t:ts)\nunifys l _ _ =\n throwError [UX.mkError \"unifys-mismatched args\" l]\n\n\nunifyX :: F.SrcSpan -> F.Symbol -> F.Symbol -> F.Symbol\nunifyX _ x _ = x\n\nunifyError :: F.SrcSpan -> RType -> RType -> ElabM a\nunifyError l t1 t2 = throwError [UX.mkError msg l]\n where msg = \"type error: cannot unify\" <+> UX.tshow t1 <+> \"and\" <+> UX.tshow t2\n\nrigidError :: F.SrcSpan -> TVar -> RType -> ElabM a\nrigidError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: cannot assign rigid\" <+> UX.tshow a <+> \"the type\" <+> UX.tshow t\n\noccurError :: F.SrcSpan -> TVar -> RType -> ElabM a\noccurError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: occurs check\" <+> UX.tshow a <+> \"occurs in\" <+> UX.tshow t\n\nmatchError :: F.SrcSpan -> Doc -> ElabM a\nmatchError l msg = throwError [UX.mkError (\"case-alt error:\" <+> msg) l]\n\n-------------------------------------------------------------------------------\nelabC :: Env -> SrcExpr -> RType -> ElabM ElbExpr\nelabC g (EFun b e l) (TFun _ s t) = do\n e' <- elabC (extEnv g (bindId b) s) e t\n return $ EFun b e' l\n\n-- let rec x:s = e1 in e2\nelabC g (ELet (RDecl (Bind x l) (EAnn e1 s1 l1) ld) e2 l2) t2 = do\n let g' = extEnv g x s1\n let (as, t1) = splitTAll s1\n e1' <- elabC (extEnvTVs g' as) e1 t1\n e2' <- elabC g' e2 t2\n return $ ELet (RDecl (Bind x l) (EAnn (mkTLam e1' as) s1 l1) ld) e2' l2\n\n-- let x = e in e'\nelabC g (ELet (Decl (Bind x l) e1 l1) e2 l2) t2 = do\n (e1', s) <- elabS g e1\n e2' <- elabC (extEnv g x s) e2 t2\n return $ ELet (Decl (Bind x l) e1' l1) e2' l2\n\n-- if b e1 e2\nelabC g (EIf b e1 e2 l) t = do\n e1' <- elabC g e1 t\n e2' <- elabC g e2 t\n return $ EIf b e1' e2' l\n\n-- switch (y) { | C(z..) => e | ... }\nelabC g (ECase y alts l) t = do\n alts' <- mapM (elabAlt g y t) alts\n return $ ECase y alts' l\n\nelabC g e t = do\n (e', t') <- elabS g e\n unify (label e) t t'\n return e'\n\nelabAlt :: Env -> Ident -> RType -> SrcAlt -> ElabM SrcAlt\nelabAlt g y t (Alt c zs e l) = do\n let al = mconcat (label <$> zs)\n case unfoldEnv' g y c zs of\n Nothing -> matchError al \"bad pattern match\"\n Just g' -> (\\e' -> Alt c zs e' l) <$> elabC g' e t\n\n\nimmS :: Env -> SrcImm -> ElabM ([RType], RType)\nimmS g i = instantiate =<< immTy g i\n\nextEnvTVs :: Env -> [TVar] -> Env\nextEnvTVs = foldr (flip extEnvTV)\n\n-------------------------------------------------------------------------------\nelabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType)\nelabS g e@(EImm i _) = do\n (ts, t') <- {- Misc.traceShow (\"elabS: \" ++ show i) <$> -} immS g i\n return (mkTApp e ts, t')\n\nelabS g (EAnn e s l) = do\n let (as, t) = splitTAll s\n e' <- elabC (extEnvTVs g as) e t\n return (EAnn (mkTLam e' as) s l, s)\n\nelabS g (EApp e y l) = do\n (e', te) <- elabS g e\n case te of\n TFun _ s t -> do (\\yt -> unify l s ({- Misc.traceShow (\"elabS1 \" ++ show s) -} yt) ) =<< immTy g y\n t' <- subsTyM t\n return (EApp e' y l, t')\n _ -> elabErr \"Application to non-function\" l\n\nelabS _ e =\n elabErr (\"elabS unexpected:\" <+> UX.tshow (void e)) (label e)\n\n\n-------------------------------------------------------------------------------\n\nelabErr :: UX.Text -> F.SrcSpan -> ElabM a\nelabErr msg l = throwError [UX.mkError msg l]\n\ninstantiate :: RType -> ElabM ([RType], RType)\ninstantiate = go []\n where\n go ts (TAll a s) = do v <- fresh\n let vt = TBase (TVar v) mempty\n go (vt:ts) (tsubst a vt s)\n go ts s = return (reverse ts, s)\n\nsplitTAll :: RType -> ([TVar], RType)\nsplitTAll (TAll a s) = (a:as, t) where (as, t) = splitTAll s\nsplitTAll t = ([] , t)\n\nfresh :: ElabM TVar\nfresh = do\n s <- get\n let n = eNum s\n put s { eNum = n + 1 }\n return (nonRigidTV n)\n\nnonRigidTV :: Int -> TVar\nnonRigidTV = TV . F.intSymbol \"fv\"\n\nnonRigid :: TVar -> Bool\nnonRigid (TV a) = F.isPrefixOfSym \"fv\" a\n\nimmTy :: Env -> SrcImm -> ElabM RType\nimmTy g (EVar x l)\n | Just t <- getEnv g x = return ({- Misc.traceShow (\"immTy: \" ++ show x) -} t)\n | otherwise = elabErr (\"Unbound variable:\" <+> F.pprint x) l\nimmTy _ (ECon c l) = return (constTy l c)\n\nmkTLam :: SrcExpr -> [TVar] -> ElbExpr\nmkTLam = foldr (\\a e -> ETLam a e (label e))\n\nmkTApp :: SrcExpr -> [RType] -> ElbExpr\nmkTApp = L.foldl' (\\e t -> ETApp e t (label e))\n\n\n\n-- | Type Substitutions --------------------------------------------------------------\n\nclass SubsTy a where\n subsTy :: TvSub -> a -> a\n subsTy1 :: TVar -> RType -> a -> a\n subsTy1 a t x = subsTy (singTvSub a t) x\n\nsingTvSub :: TVar -> RType -> TvSub\nsingTvSub a t = F.fromListSEnv [(F.symbol a, t)]\n\ninstance SubsTy RType where\n subsTy su t@(TBase (TVar a) _) = Mb.fromMaybe t t'\n where\n t' = F.lookupSEnv (F.symbol a) su\n\n subsTy _su t@(TBase {}) = t\n\n subsTy su (TCon c ts r) = TCon c (subsTy su <$> ts) r\n\n subsTy su (TFun x s t) = TFun x s' t'\n where\n s' = subsTy su s\n t' = subsTy su t\n\n subsTy su (TAll a t) = TAll a t'\n where\n t' = subsTy su' t\n su' = F.deleteSEnv (F.symbol a) su\n\ninstance SubsTy TvSub where\n subsTy = F.mapSEnv . subsTy\n\n-- applies the substs to the ETApp types\ninstance SubsTy ElbExpr where\n subsTy = subsTyExpr\n\ninstance SubsTy ElbDecl where\n subsTy su (Decl b e l) = Decl b (subsTy su e) l\n subsTy su (RDecl b e l) = RDecl b (subsTy su e) l\n\nsubsTyExpr :: TvSub -> ElbExpr -> ElbExpr\nsubsTyExpr su = go\n where\n go (EFun b e l) = EFun b (go e) l\n go (EApp e i l) = EApp (go e) i l\n go (ELet d e l) = ELet d' (go e) l where d' = subsTy su d\n go (EAnn e t l) = EAnn (go e) t l\n go (EIf i e1 e2 l) = EIf i (go e1) (go e2) l\n go (ETLam a e l) = ETLam a (go e) l\n go (ETApp e t l) = ETApp (go e) (subsTy su t) l\n go (ECase x as l) = ECase x (goA <$> as) l\n go e@(EImm {}) = e\n goA alt = alt -- { altTyArgs = fmap (subsTy su) <$> altTyArgs alt }\n { altExpr = go $ altExpr alt }\n\n\n\n\nsubsTyM :: (SubsTy a) => a -> ElabM a\nsubsTyM x = do\n su <- gets eSub\n return (subsTy su x)\n\nassign :: TVar -> RType -> ElabM ()\nassign a t = modify $ \\s -> s { eSub = updSub a t (eSub s)}\n\nupdSub :: TVar -> RType -> TvSub -> TvSub\nupdSub a t su = F.insertSEnv (F.symbol a) t (subsTy1 a t su)\n" }, { "path": "src/Language/Sprite/L5/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L5.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , measureP\n , rtype\n , expr\n , typP\n , switchExpr\n , altP\n ) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport Control.Monad.Combinators.Expr\nimport Text.Megaparsec hiding (State, label)\nimport Text.Megaparsec.Char\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport Language.Sprite.Common\nimport Language.Sprite.Common.Parse\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.L5.Types hiding (immExpr)\n-- import Language.Sprite.L5.Constraints\n\nparseFile :: FilePath -> IO SrcProg\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser SrcProg\nprog = do\n qs <- quals\n ms <- try (many measureP) <|> return []\n typs <- many typP\n src <- declsExpr <$> many decl\n return (Prog qs ms src (Misc.traceShow \"prog-types\" typs))\n\nmeasureP :: FP.Parser (F.Symbol, F.Sort)\nmeasureP = annL >> (Misc.mapSnd (rTypeSort . generalize) <$> tyBindP \"measure\")\n\ntypP :: FP.Parser SrcData\ntypP = do\n reserved \"type\"\n tc <- FP.lowerIdP\n args <- typArgs\n FP.reservedOp \"=\" >> whiteSpace\n ctors <- ctorsP\n return (Data tc args (mkCtor tc args <$> ctors))\n\ndata Ctor = Ctor SrcBind [FunArg] (Maybe Reft)\ntype FunArg = (F.Symbol, RType)\n\nctorsP :: FP.Parser [Ctor]\nctorsP = try (FP.semi >> return [])\n <|> (:) <$> ctorP <*> ctorsP\n\nctorP :: FP.Parser Ctor\nctorP = Ctor <$> (whiteSpace *> mid *> cbind) <*> commaList funArgP <*> ctorResP\n\ncbind :: FP.Parser SrcBind\ncbind = withSpan' (Bind <$> FP.upperIdP)\n\ntypArgs :: FP.Parser [F.Symbol]\ntypArgs = commaList tvarP\n\nctorResP :: FP.Parser (Maybe Reft)\nctorResP = Just <$> (FP.reservedOp \"=>\" *> brackets concReftB)\n <|> return Nothing\n\nmkCtor :: Ident -> [Ident] -> Ctor -> (SrcBind, RType)\nmkCtor tc args c = (dc, generalize dcType)\n where\n dcType = foldr (\\(x, t) s -> TFun x t s) dcRes xts\n dcRes = TCon tc (rVar <$> args) dcReft\n Ctor dc xts r = c\n dcReft = Mb.fromMaybe mempty r\n\ncommaList :: FP.Parser a -> FP.Parser [a]\ncommaList p = try (parens (sepBy p comma)) <|> return []\n\nquals :: FP.Parser [F.Qualifier]\nquals = try ((:) <$> between annL annR qual <*> quals)\n <|> pure []\n\nqual ::FP.Parser F.Qualifier\nqual = reserved \"qualif\" >> FP.qualifierP (rTypeSort <$> rtype)\n\nexpr :: FP.Parser SrcExpr\nexpr = try funExpr\n <|> try letExpr\n <|> try ifExpr\n <|> try switchExpr\n <|> try (FP.braces (expr <* whiteSpace))\n <|> try appExpr\n <|> try binExp\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try (FP.parens expr)\n <|> immExpr\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> immExpr <*> parens (sepBy1 imm comma)\n\nbinExp :: FP.Parser SrcExpr\nbinExp = withSpan' $ do\n x <- imm\n o <- op\n y <- imm\n return (bop o x y)\n\nop :: FP.Parser PrimOp\nop = (FP.reservedOp \"*\" >> pure BTimes)\n <|> (FP.reservedOp \"+\" >> pure BPlus )\n <|> (FP.reservedOp \"-\" >> pure BMinus)\n <|> (FP.reservedOp \"<\" >> pure BLt )\n <|> (FP.reservedOp \"<=\" >> pure BLe )\n <|> (FP.reservedOp \"==\" >> pure BEq )\n <|> (FP.reservedOp \">\" >> pure BGt )\n <|> (FP.reservedOp \">=\" >> pure BGe )\n <|> (FP.reservedOp \"&&\" >> pure BAnd )\n <|> (FP.reservedOp \"||\" >> pure BOr )\n\nbop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr\nbop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nifExpr :: FP.Parser SrcExpr\nifExpr = withSpan' $ do\n FP.reserved \"if\"\n v <- parens imm\n e1 <- expr\n FP.reserved \"else\"\n e2 <- expr\n return (EIf v e1 e2)\n\nswitchExpr :: FP.Parser SrcExpr\nswitchExpr = withSpan' $ do\n FP.reserved \"switch\"\n x <- parens FP.lowerIdP\n alts <- braces (many altP)\n return (ECase x alts)\n\naltP :: FP.Parser SrcAlt\naltP = withSpan' $ Alt\n <$> (whiteSpace *> mid *> FP.upperIdP)\n -- <*> pure Nothing\n <*> commaList binder\n <*> (FP.reservedOp \"=>\" *> expr)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = immInt <|> immBool <|> immId\n\nimmInt :: FP.Parser SrcImm\nimmInt = withSpan' (ECon . PInt <$> FP.natural)\n\nimmBool :: FP.Parser SrcImm\nimmBool = withSpan' (ECon . PBool <$> bool)\n\nimmId :: FP.Parser SrcImm\nimmId = withSpan' (EVar <$> identifier')\n\nbool :: FP.Parser Bool\nbool = (reserved \"true\" >> pure True)\n <|>(reserved \"false\" >> pure False)\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- parens (sepBy1 binder comma)\n _ <- FP.reservedOp \"=>\"\n -- _ <- FP.reservedOp \"{\"\n body <- braces (expr <* whiteSpace)\n -- _ <- FP.reservedOp \"}\"\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = mkDecl <$> ann <*> plainDecl\n where\n ann = (annL >> (Just <$> tyBindP \"val\")) <|> pure Nothing\n\ntype Ann = Maybe (F.Symbol, RType)\n\nannL, annR :: FP.Parser ()\nannL = reservedOp \"/*@\"\nannR = reservedOp \"*/\"\n\ntyBindP :: String -> FP.Parser (F.Symbol, RType)\ntyBindP kw = do\n reserved kw\n x <- identifier\n colon\n t <- rtype\n annR\n return (x, t)\n\n{-\nbetween :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a\nbetween lP rP xP = do\n lP\n x <- xP\n rP\n return x\n -}\nmkDecl :: Ann -> SrcDecl -> SrcDecl\nmkDecl (Just (x, t)) (Decl b e l)\n | x == bindId b = Decl b (EAnn e (generalize t) (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl (Just (x, t)) (RDecl b e l)\n | x == bindId b = RDecl b (EAnn e (generalize t) (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl Nothing d = d\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n ctor <- (FP.reserved \"let rec\" >> pure RDecl) <|>\n (FP.reserved \"let\" >> pure Decl)\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (ctor b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = try rfun <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArgP <*> (FP.reservedOp \"=>\" *> rtype)\n\nfunArgP :: FP.Parser FunArg\nfunArgP = try ((,) <$> FP.lowerIdP <*> (colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = try (TBase <$> tbase <*> refTop)\n <|> TCon <$> identifier' <*> commaList rtype <*> refTop\n\ntbase :: FP.Parser Base\ntbase = (reserved \"int\" >> pure TInt)\n <|> (reserved \"bool\" >> pure TBool)\n <|> (tvarP >>= return . TVar. TV)\n\ntvarP :: FP.Parser F.Symbol\ntvarP = FP.reservedOp \"'\" >> FP.lowerIdP -- >>= return . TVar . TV\n\nrefTop :: FP.Parser Reft\nrefTop = brackets reftB <|> pure mempty\n\nreftB :: FP.Parser Reft\nreftB = (question >> pure Unknown)\n <|> concReftB\n\nconcReftB :: FP.Parser Reft\nconcReftB = KReft <$> (FP.lowerIdP <* mid) <*> myPredP\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\nquestion :: FP.Parser ()\nquestion = FP.reservedOp \"?\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))\n\n\n-- | list of reserved words\nkeywords :: S.Set String\nkeywords = S.fromList\n [ \"if\" , \"else\"\n , \"true\" , \"false\"\n , \"let\" , \"in\"\n , \"int\"\n ]" }, { "path": "src/Language/Sprite/L5/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L5.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.L5.Types \nimport Language.Sprite.L5.Parse\n\n-- | \"Prelude\" Environment --------------------------------------------\n\nprelude :: [(F.Symbol, RType)]\nprelude = \n [ (\"diverge\" , mkTy \"x:int => 'a\")\n , (\"impossible\", mkTy \"x:int[v|false] => 'a\")\n ]\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n)) \nconstTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)\nconstTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)\nconstTy l (PBin o) = binOpTy l o\n\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n\n , (BLt , mkTy \"x:'a => y:'a => bool[v|v <=> (x < y)]\")\n , (BLe , mkTy \"x:'a => y:'a => bool[v|v <=> (x <= y)]\")\n , (BGt , mkTy \"x:'a => y:'a => bool[v|v <=> (x > y)]\")\n , (BGe , mkTy \"x:'a => y:'a => bool[v|v <=> (x >= y)]\")\n , (BEq , mkTy \"x:'a => y:'a => bool[v|v <=> (x == y)]\")\n\n , (BAnd , mkTy \"x:bool => y:bool => bool[v|v <=> (x && y)]\")\n , (BOr , mkTy \"x:bool => y:bool => bool[v|v <=> (x || y)]\")\n , (BNot , mkTy \"x:bool => bool[v|v <=> not x]\")\n ]\n\nmkTy :: String -> RType\nmkTy = {- Misc.traceShow \"mkTy\" . -} rebind . generalize . parseWith rtype \"prims\" \n\n\nrebind :: RType -> RType\nrebind t@(TBase {}) = t \nrebind (TAll a t) = TAll a (rebind t) \nrebind (TCon c ts r) = TCon c (rebind <$> ts) r\nrebind (TFun x s t) = TFun x' s' t' \n where \n x' = F.mappendSym \"spec#\" x\n s' = subst (rebind s) x x'\n t' = subst (rebind t) x x'" }, { "path": "src/Language/Sprite/L5/Types.hs", "content": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L5.Types where\n\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Misc as Misc\nimport qualified Language.Sprite.Common.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport qualified Data.Set as S\nimport qualified Data.List as L\n\n-- | Basic types --------------------------------------------------------------\nnewtype TVar = TV F.Symbol\n deriving (Eq, Ord, Show)\n\ninstance F.Symbolic TVar where\n symbol (TV a) = a\n\ndata Base = TInt | TBool | TVar TVar\n deriving (Eq, Ord, Show)\n\ninstance F.PPrint Base where\n pprintTidy _ = UX.tshow\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r\n = TBase !Base r -- ^ Int{r}\n | TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t\n | TAll !TVar !(Type r) -- ^ all a. t\n | TCon !TyCon ![Type r] r -- ^ C t1...tn\n deriving (Eq, Ord, Show)\n\n\nrVar :: F.Symbol -> RType\nrVar a = TBase (TVar (TV a)) mempty\n\nrInt :: RType\nrInt = TBase TInt mempty\n\nrBool :: RType\nrBool = TBase TBool mempty\n\ndata Reft\n = Known !F.Symbol !H.Pred -- ^ Known refinement\n | Unknown -- ^ Unknown, to-be-synth refinement\n deriving (Show)\n\nknown :: F.Reft -> Reft\nknown (F.Reft (v, r)) = KReft v r\n\npattern KReft v p = Known v (H.Reft p)\n\ninstance Semigroup Reft where\n Unknown <> r = r\n r <> Unknown = r\n-- KReft v1 r1 <> KReft v2 r2 = KReft v r where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)\n Known v p <> Known v' p'\n | v == v' = Known v (p <> p')\n | v == F.dummySymbol = Known v' (p' <> (p `F.subst1` (v , F.EVar v')))\n | otherwise = Known v (p <> (p' `F.subst1` (v', F.EVar v )))\n-- _ <> _ = error \"Semigroup Reft: TBD\"\n\ninstance Monoid Reft where\n mempty = KReft v r where F.Reft (v, r) = mempty\n\ntype RType = Type Reft\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp\n = BPlus\n | BMinus\n | BTimes\n | BLt\n | BLe\n | BEq\n | BGt\n | BGe\n | BAnd\n | BOr\n | BNot\n deriving (Eq, Ord, Show)\n\ndata Prim\n = PInt !Integer -- 0,1,2,...\n | PBool !Bool -- true, false\n | PBin !PrimOp -- +,-,==,<=,...\n deriving (Eq, Ord, Show)\n\n---------------------------------------------------------------------------------\n-- | Terms ----------------------------------------------------------------------\n---------------------------------------------------------------------------------\n\n-- | Bindings -------------------------------------------------------------------\n\ndata Bind a\n = Bind !Ident a\n deriving (Eq, Ord, Show, Functor)\n\ninstance F.Symbolic (Bind a) where\n symbol = bindId\n\nbindId :: Bind a -> F.Symbol\nbindId (Bind x _) = x\n\njunkSymbol :: F.Symbol\njunkSymbol = \"_\"\n\n-- | Names of things ------------------------------------------------------------\ntype Ident = F.Symbol -- ^ Identifiers\ntype DaCon = F.Symbol -- ^ Data constructors\ntype TyCon = F.Symbol -- ^ Type constructors\n\n-- | \"Immediate\" terms (can appear as function args & in refinements) -----------\n\ndata Imm a\n = EVar !Ident a\n | ECon !Prim a\n deriving (Show, Functor)\n\n-- | Variable definition ---------------------------------------------------------\ndata Decl a\n = Decl (Bind a) (Expr a) a -- ^ plain \"let\"\n | RDecl (Bind a) (Expr a) a -- ^ recursive \"let rec\"\n deriving (Show, Functor)\n\n-- | Case-Alternatives -----------------------------------------------------------\n\ndata Alt a = Alt\n { altDaCon :: !DaCon -- ^ Data constructor\n , altBinds :: ![Bind a] -- ^ Binders x1...xn\n , altExpr :: !(Expr a) -- ^ Body-expr\n , altLabel :: a -- ^ Label\n }\n deriving (Show, Functor)\n\n-- | Terms -----------------------------------------------------------------------\ndata Expr a\n = EImm !(Imm a) a -- ^ x,y,z,... 1,2,3...\n | EFun !(Bind a) !(Expr a) a -- ^ \\x -> e\n | EApp !(Expr a) !(Imm a) a -- ^ e v\n | ELet !(Decl a) !(Expr a) a -- ^ let/rec x = e1 in e2\n | EAnn !(Expr a) !RType a -- ^ e:t\n | EIf !(Imm a) !(Expr a) !(Expr a) a -- ^ if v e1 e2\n | ETLam !TVar !(Expr a) a -- ^ Λ a. e (type abstraction)\n | ETApp !(Expr a) !RType a -- ^ e [t] (type application)\n | ECase !Ident ![Alt a] a -- ^ switch (x) { a1 ... }\n deriving (Show, Functor)\n\ninstance Label Bind where\n label (Bind _ l) = l\n\ninstance Label Alt where\n label = altLabel\n\ninstance Label Imm where\n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where\n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ l) = l\n label (EIf _ _ _ l) = l\n label (ETLam _ _ l) = l\n label (ETApp _ _ l) = l\n label (ECase _ _ l) = l\n\ninstance Label Decl where\n label (Decl _ _ l) = l\n label (RDecl _ _ l) = l\n\n------------------------------------------------------------------------------\n-- | Top-level `Program` datatype\n------------------------------------------------------------------------------\ndata Prog a = Prog\n { prQuals :: ![F.Qualifier]\n , prMeas :: ![(F.Symbol, F.Sort)]\n , prExpr :: !(Expr a)\n , prData :: ![Data a]\n }\n deriving (Show, Functor)\n\ndata Data a = Data\n { dcName :: !Ident -- ^ name of the datatype\n , dcVars :: ![Ident] -- ^ type variables\n , dcCtors :: ![(Bind a, RType)] -- ^ constructors\n }\n deriving (Show, Functor)\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d\ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d\ndeclsExpr _ = error \"impossible\"\n\nintExpr :: Integer -> a -> Expr a\nintExpr i l = EImm (ECon (PInt i) l) l\n\nboolExpr :: Bool -> a -> Expr a\nboolExpr b l = EImm (ECon (PBool b) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\ntype ElbDecl = Decl F.SrcSpan\ntype ElbExpr = Expr F.SrcSpan\ntype SrcProg = Prog F.SrcSpan\ntype SrcData = Data F.SrcSpan\ntype SrcAlt = Alt F.SrcSpan\n------------------------------------------------------------------------------\n\n-- | should/need only be defined on \"Known\" variants. TODO:LIQUID\ninstance F.Subable Reft where\n syms (Known v r) = v : F.syms r\n syms Unknown = []\n substa f (Known v r) = Known (f v) (F.substa f r)\n substa _ Unknown = Unknown\n substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r)\n substf _ Unknown = Unknown\n subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)\n subst _ Unknown = Unknown\n subst1 (Known v r) su = Known v (F.subst1Except [v] r su)\n subst1 Unknown _ = Unknown\n\ninstance F.Subable r => F.Subable (Type r) where\n -- syms :: a -> [Symbol]\n syms (TBase _ r) = F.syms r\n syms (TAll _ t) = F.syms t\n syms (TFun _ s t) = F.syms s ++ F.syms t\n syms (TCon _ ts r) = concatMap F.syms ts ++ F.syms r\n\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r\n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n substa f (TAll a t) = TAll a (F.substa f t)\n substa f (TCon c ts r) = TCon c (F.substa f <$> ts) (F.substa f r)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n substf f (TAll a t) = TAll a (F.substf f t)\n substf f (TCon c ts r) = TCon c (F.substf f <$> ts) (F.substf f r)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n subst f (TAll a t) = TAll a (F.subst f t)\n subst f (TCon c ts r) = TCon c (F.subst f <$> ts) (F.subst f r)\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where\n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\nimmExpr (ECon (PBool True) _) = F.PTrue\nimmExpr (ECon (PBool False) _) = F.PFalse\nimmExpr _ = error \"impossible\"\n\n\n--------------------------------------------------------------------------------\n-- | Dealing with Type Variables -----------------------------------------------\n--------------------------------------------------------------------------------\ntsubst :: TVar -> RType -> RType -> RType\ntsubst a t = go\n where\n go (TAll b s)\n | a == b = TAll b s\n | otherwise = TAll b (go s)\n go (TFun x s1 s2) = TFun x (go s1) (go s2)\n go (TBase b r) = bsubst a t b r\n go (TCon c ts r) = TCon c (go <$> ts) r\n\ntsubsts :: [(TVar, RType)] -> RType -> RType\ntsubsts ats s = L.foldl' (\\s (a, t) -> tsubst a t s) s ats\n\nbsubst :: TVar -> RType -> Base -> Reft -> RType\nbsubst a t (TVar v) r\n | v == a = strengthenTop t r\nbsubst _ _ b r = TBase b r\n\nrTypeReft :: RType -> Maybe Reft\nrTypeReft (TBase _ r) = Just r\nrTypeReft (TCon _ _ r) = Just r\nrTypeReft _ = Nothing\n\nstrengthenTop :: RType -> Reft -> RType\nstrengthenTop t@(TFun {}) _ = t\nstrengthenTop t@(TAll {}) _ = t\nstrengthenTop (TBase b r) r' = TBase b (r <> r')\nstrengthenTop (TCon c ts r) r' = TCon c ts (r <> r')\n\ngeneralize :: RType -> RType\ngeneralize t = foldr TAll t (freeTVars t)\n\nfreeTVars :: RType -> [TVar]\nfreeTVars = Misc.sortNub . S.toList . go\n where\n go (TAll a t) = S.delete a (go t)\n go (TFun _ s t) = S.union (go s) (go t)\n go (TCon _ ts _) = S.unions (go <$> ts)\n go (TBase b _) = goB b\n goB (TVar a) = S.singleton a\n goB _ = S.empty\n\n-------------------------------------------------------------------------------\n-- | Types and Sorts\n-------------------------------------------------------------------------------\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\nbaseSort TBool = F.boolSort\nbaseSort (TVar a) = F.FObj (F.symbol a)\n\nrTypeSort :: RType -> F.Sort\nrTypeSort (TBase b _) = baseSort b\nrTypeSort (TCon c ts _) = F.fAppTC (fTyCon c) (rTypeSort <$> ts)\nrTypeSort t@(TFun {}) = rTypeSortFun t\nrTypeSort t@(TAll {}) = rTypeSortAll t\n\nrTypeSortFun :: RType -> F.Sort\nrTypeSortFun = F.mkFFunc 0 . fmap rTypeSort . go []\n where\n go ts (TFun _ t1 t2) = go (t1:ts) t2\n go ts t = reverse (t:ts)\n\nrTypeSortAll :: RType -> F.Sort\nrTypeSortAll s = genSort (rTypeSort t)\n where\n genSort t = L.foldl' (flip F.FAbs) (F.sortSubst su t) [0..n-1]\n (as, t) = bkAll s\n su = F.mkSortSubst $ zip sas (F.FVar <$> [0..])\n sas = F.symbol <$> as\n n = length as\n\nbkAll :: RType -> ([TVar], RType)\nbkAll (TAll a s) = (a:as, t) where (as, t) = bkAll s\nbkAll t = ([] , t)\n\nfTyCon :: TyCon -> F.FTycon\nfTyCon = F.symbolFTycon . F.dummyLoc\n" }, { "path": "src/Language/Sprite/L5.hs", "content": "module Language.Sprite.L5 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.L5.Check\nimport Language.Sprite.L5.Parse\nimport Language.Sprite.Common\n\n--------------------------------------------------------------------------------\nsprite :: FilePath -> IO ()\n--------------------------------------------------------------------------------\nsprite f = do\n src <- parseFile f\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValid f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "src/Language/Sprite/L6/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Use uncurry\" #-}\n\nmodule Language.Sprite.L6.Check (vcgen) where\n\nimport Control.Monad (void)\nimport Control.Monad.Except (throwError, catchError)\nimport qualified Data.HashMap.Strict as M\n-- import qualified Data.Map as M\nimport Text.PrettyPrint.HughesPJ\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport Language.Fixpoint.Misc (safeZip)\nimport qualified Language.Sprite.Common.UX as UX\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common\nimport Language.Sprite.L6.Types\nimport Language.Sprite.L6.Prims\nimport Language.Sprite.L6.Constraints\nimport Language.Sprite.L6.Elaborate\n-- import Debug.Trace (trace)\n\n-------------------------------------------------------------------------------\nvcgen:: SrcProg -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen (Prog qs ms e typs) = do\n let env = empEnv typs\n let eL = elaborate env e\n let ps = [(pappSym n, pappSort n) | n <- [1..3]]\n let pqs = pappQual <$> [1..3]\n let syms = M.fromList (ps ++ ms)\n (c, ks) <- run (check env eL (bTrue TInt))\n return $ H.Query (qs ++ pqs) ks c syms mempty mempty mempty mempty mempty\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\nsub l s t = sub' l s t `catchError` (\\es -> throwError (UX.mkError msg l : es))\n where\n msg = text $ \"Invalid Subtyping: \" ++ show (s, t)\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n -}\n\nsub' :: F.SrcSpan -> RType -> RType -> CG SrcCstr\nsub' l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith (\"Invalid Subtyping: \" <+> F.pprint (b1, b2)) l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub' l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 s2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n{- | [Sub-TCon]\n\n G,v:int{p} |- q[w:=v] G |- si <: ti\n -----------------------------------------\n G |- (C s1...)[v|p] <: (C t1...)[w|q]\n\n -}\n\nsub' l s@(TCon c1 t1s p1s (Known v _)) (TCon c2 t2s p2s (Known w q)) | c1 == c2 = do\n let cTop = cAll l v s (cHead l (subst q w v))\n cIns <- subs l t1s t2s\n cARefs <- subPs l p1s p2s\n return (cAnd cTop (cAnd cIns cARefs))\n\nsub' l t1 t2 = failWith (\"sub: cannot handle:\" <+> UX.tshow (t1, t2)) l\n\nsubs :: F.SrcSpan -> [RType] -> [RType] -> CG SrcCstr\nsubs _ [] [] = return cTrue\nsubs l (t1:t1s) (t2:t2s) = cAnd <$> sub l t1 t2 <*> subs l t1s t2s\nsubs l _ _ = failWith \"subs: invalid args\" l\n\nsubPs :: F.SrcSpan -> [RARef] -> [RARef] -> CG SrcCstr\nsubPs l (p1:p1s) (p2:p2s) = cAnd (subP l p1 p2) <$> subPs l p1s p2s\nsubPs l [] [] = pure cTrue\nsubPs l _ _ = error \"subPs: mismatch\"\n\n\n{- | [Sub-ARef]\n\n G; x1:t... |- p1 => p2[x2 := x1]\n ---------------------------------\n G |- \\x1:t. p1 <: \\x2:t. p2\n\n -}\n\nsubP :: F.SrcSpan -> RARef -> RARef -> SrcCstr\nsubP l (ARef xts1 (Known _ p1)) (ARef xts2 (Known _ p2))\n = cImpl l xts1 p1 (substs p2 su)\n where\n su = Misc.traceShow \"subP\" $ safeZip \"subP\" (fst <$> xts2) (fst <$> xts1)\n\n-------------------------------------------------------------------------------\n-- | 'Checking' constraints\n-------------------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n{- [Chk-Lam]\n\n G, x:s[y:=x] |- e <== t[y:=x]\n -----------------------------\n G |- \\x.e <== y:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) = do\n c <- check (extEnv g x s') e t'\n return $ cAll l x s c\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n\n{- [Chk-Let]\n\n G |- e ==> s G, x:s |- e' <== t'\n -------------------------------------------\n G |- let x = e in e' <== t'\n\n-}\ncheck g (ELet (Decl (Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g x s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Rec]\n\n t := fresh(s) G; f:t |- e <== t G; f:t |- e' <== t'\n ---------------------------------------------------------[Chk-Rec]\n G |- letrec f = (e:s) in e' <== t'\n\n -}\ncheck g (ELet (RDecl (Bind x l) (EAnn e s _) _) e' _) t' = do\n t <- fresh l g s\n let g' = extEnv g x t\n c <- check g' e t\n c' <- check g' e' t'\n return $ cAnd c c'\n\n{- [Chk-If]\n G |- v <== bool\n G, _:{v} |- e1 <== t\n G, _:{not v} |- e2 <== t\n ----------------------------- [Chk-If]\n G |- if v e1 e2 <== t\n -}\ncheck g (EIf v e1 e2 l) t = do\n _ <- check g (EImm v l) rBool\n c1 <- cAll l xv tT <$> check g e1 t\n c2 <- cAll l xv tF <$> check g e2 t\n return (cAnd c1 c2)\n where\n tT = predRType pv\n tF = predRType (F.PNot pv)\n pv = immExpr v\n xv = grdSym g\n\n{- [Chk-Switch]\n\n G | y |- a_i <== t\n ---------------------------\n G |- switch y {a_1...} <== t\n-}\n\ncheck g (ECase y alts _) t = do\n H.CAnd <$> mapM (checkAlt g y t) alts\n\n\n{- [Chk-TLam]\n\n G, a |- e <== t\n ------------------------ [Chk-TLam]\n G |- Λ a. e <== all a. t\n-}\ncheck g (ETLam a e _) (TAll b t) | a == b = do\n check g e t\n\n{- [Chk-RAbs]\n\n ρ = κ:t -> Bool s' = s[κ := fκ] G; fκ : t → Bool ⊢ e <== s'\n ----------------------------------------------------------------[Chk-RAbs]\n G |- e <== all ρ. s\n\n-}\ncheck g e (TRAll r s) = do\n c <- check g' e s'\n return (cAllF l kf kt c)\n where\n l = label e\n g' = extEnv g kf kt\n s' = hvarPred kf <$> s\n (kf, kt) = predBind r\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n\n{- [Chk-Alt]\n\n unfold(G, c, y) === s G | y + z... * s ~~> G' G' |- e <== t\n ---------------------------------------------------------------\n G | y |- C z... -> e <== t\n\n-}\ncheckAlt :: Env -> Ident -> RType -> SrcAlt -> CG SrcCstr\ncheckAlt g y t (Alt c zs e l) = do\n let al = mconcat (label <$> zs)\n case unfoldEnv g y c zs of\n Nothing -> failWith \"checkAlt: incompatible pattern\" al\n Just zts -> cAlls l zts <$> check (extEnvs g zts) e t\n\ncAlls :: F.SrcSpan -> [(F.Symbol, RType)] -> SrcCstr -> SrcCstr\ncAlls l xts c = foldr (\\(x, t) -> cAll l x t) c (reverse xts)\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsingleton :: F.Symbol -> RType -> RType\nsingleton x (TBase b (Known v p)) = TBase b (Known v (pAnd [p, v `peq` x]))\nsingleton x (TCon c ts ps (Known v p)) = TCon c ts ps (Known v (pAnd [p, v `peq` x]))\nsingleton _ t = t\n\npeq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred\npeq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))\n\nsynthImm :: Env -> SrcImm -> CG RType\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return $ Misc.traceShow \"synthImm\" $ singleton x t\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm _ (ECon c l) = return (constTy l c)\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t t := fresh(s)\n ---------------------------\n G |- e:s => t\n\n-}\nsynth g (EAnn e s l) = do\n t <- Misc.traceShow \"EANN-FRESH\" <$> fresh l g s\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\n\n{- [Syn-TApp]\n\n G |- e ==> all a. s\n ---------------------------\n G |- e[t] ==> s [ a := t]\n\n-}\nsynth g (ETApp e t l) = do\n (ce, te) <- synth g e\n case te of\n TAll a s -> do tt <- {- Misc.traceShow \"REFRESH\" <$> -} refresh l g t\n return (ce, Misc.traceShow \"SYN-TApp: \" $ tsubst a tt s)\n _ -> failWith \"Type Application to non-forall\" l\n\n{- [Syn-RApp]\n\n G |- e => forall r.s r = K:t... -> bool p = fresh(G, t...-> bool)\n ----------------------------------------------------------------------\n G |- e[?] => s [ r := p ]\n -}\n\nsynth g (ERApp e l) = do\n (c, s) <- synth g e\n s' <- Misc.traceShow (\"SYN-RApp: \" ++ show (void e, void s)) <$> rinst l s\n return (c, s')\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e))) (label e)\n\n-------------------------------------------------------------------------------\n-- | Fresh templates for `Unknown` refinements\n-------------------------------------------------------------------------------\nrefresh :: F.SrcSpan -> Env -> RType -> CG RType\nrefresh l g = fresh l g . go\n where\n go (TBase b _) = TBase b Unknown\n go (TFun b s t) = TFun b (go s) (go t)\n go (TCon c ts ps _) = TCon c (go <$> ts) ps Unknown\n go (TAll a t) = TAll a (go t)\n\nfresh :: F.SrcSpan -> Env -> RType -> CG RType\nfresh l g t@(TBase b r) = TBase b <$> freshR l g (rTypeSort t) r\nfresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t\nfresh l g t@(TCon c ts ps r) = TCon c <$> mapM (fresh l g) ts <*> pure ps <*> freshR l g (rTypeSort t) r\nfresh l g (TAll a t) = TAll a <$> fresh l g t\nfresh l g (TRAll r t) = TRAll r <$> fresh l g t\n\nfreshR :: F.SrcSpan -> Env -> F.Sort -> Reft -> CG Reft\nfreshR _ _ _ r@(Known {}) = pure r\nfreshR l g t Unknown = freshK l g t\n\n\nrinst :: F.SrcSpan -> RType -> CG RType\nrinst l (TRAll (RVar p ts) s) = do\n ar <- freshKVarReft l ts\n return (subsAR p ar s)\nrinst _ s =\n return s\n\nfreshKVarReft :: F.SrcSpan -> [RSort] -> CG RARef\nfreshKVarReft l ts = do\n k <- freshKVar l (rSortToFSort <$> ts)\n return $ rVarARef (RVar k ts)\n\n-- | Abstract Refinement Substitutions (sec 7.2.1) ------------------------------------\n\n{-\nrinst :: F.SrcSpan -> RType -> CG RType\nrinst l (TRAll (RVar p ts) s) = do\n s' <- rinst l s\n k <- freshKVar l (rSortToFSort <$> ts)\n return (substKVar p k <$> s')\nrinst _ s =\n return s\n\n\n-- | @substK f k@ replaces all occurences of `H.Var f xs` with `H.Var k xs`\nsubstKVar :: F.Symbol -> F.Symbol -> Reft -> Reft\nsubstKVar _ _ Unknown = Unknown\nsubstKVar f k (Known v p) = Known v (go p)\n where\n go pred = case pred of\n H.Var g xs | f == g -> H.Var k xs\n H.PAnd preds -> H.PAnd (go <$> preds)\n _ -> pred\n-}\n\n-- | @hvarPred f r@ converts all occurrences of `H.Var f xs` in `r` to `H.Reft (EApp f xs)`\nhvarPred :: F.Symbol -> Reft -> Reft\nhvarPred _ Unknown = Unknown\nhvarPred f (Known v p) = Known v (go p)\n where\n go (H.Var g xs)\n | f == g = H.Reft (predApp f xs)\n go (H.PAnd ps) = H.PAnd (go <$> ps)\n go r = r\n\npredBind :: RVar -> (F.Symbol, RType)\npredBind (RVar p ts) = (p, TCon \"Pred\" (rSortToRType <$> ts) mempty mempty)" }, { "path": "src/Language/Sprite/L6/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Eta reduce\" #-}\n\nmodule Language.Sprite.L6.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll, cAllF, cImpl, pAnd\n\n -- * Substitutions\n , subst, substImm\n\n -- * Conversions\n , predRType, rTypeSort\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv, extEnvs\n , extEnvTV, grdSym, envSorts\n\n -- * Case-Related manipulation\n , unfoldEnv, unfoldEnv'\n\n -- * Constraint Generation Monad\n , CG, run, failWith, freshK, freshKVar\n\n ) where\n\nimport qualified Data.List as L\nimport qualified Data.Maybe as Mb\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common\nimport Language.Sprite.L6.Types\nimport Language.Sprite.L6.Prims\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd (H.CAnd []) c = c\ncAnd c (H.CAnd []) = c\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> H.Pred -> SrcCstr\ncHead _ (H.Reft p)\n | F.isTautoPred p = cTrue\ncHead l (H.PAnd ps) = case filter (not . pTrivial) ps of\n [] -> cTrue\n [p] -> mkHead l p\n qs -> mkHead l (H.PAnd qs)\ncHead l p = mkHead l p\n\n{-@ ListNE a = {v:_ | len v > 0} @-}\ntype ListNE a = [a]\n\ncImpl :: F.SrcSpan -> ListNE (F.Symbol, RSort) -> H.Pred -> H.Pred -> SrcCstr\ncImpl l xts p1 p2 = go [ (x, rSortToFSort t) | (x, t) <- xts]\n where\n go [(x,t)] = H.All (bind l x t p1) (cHead l p2)\n go ((x,t):xts) = H.All (bind l x t mempty) (go xts)\n\n\nmkHead :: F.SrcSpan -> H.Pred -> SrcCstr\nmkHead l p = case smash p of\n [] -> cTrue\n [q] -> mk1 l q\n qs -> H.CAnd (mk1 l <$> qs)\n\nmk1 :: F.SrcSpan -> H.Pred -> SrcCstr\nmk1 l p = H.Head p (UX.mkError \"Subtype error\" l)\n\nsmash :: H.Pred -> [H.Pred]\nsmash (H.PAnd ps) = concatMap smash ps\nsmash p = [p]\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll l x t c = case sortPred x t of\n Just (so, p) -> H.All (bind l x so p) c\n _ -> c\n\n-- | @cAllF@ is a variant of @cAll@ used when the binder is a function, e.g. in [Chk-RAbs]\ncAllF :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAllF l f t c = H.All (bind l f (rTypeSort t) mempty) c\n\npAnd :: [H.Pred] -> H.Pred\npAnd ps = case filter (not . pTrivial) ps of\n [p] -> p\n ps' -> H.PAnd ps'\n\npTrivial :: H.Pred -> Bool\npTrivial (H.PAnd []) = True\npTrivial (H.Reft p) = F.isTautoPred p\npTrivial _ = False\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x t@(TBase _ (Known v p)) = Just (rTypeSort t, subst p v x)\nsortPred x t@(TCon _ _ _ (Known v p)) = Just (rTypeSort t, subst p v x)\nsortPred _ _ = Nothing\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ndata Env = Env\n { eBinds :: !(F.SEnv RType) -- ^ value binders\n , eSize :: !Integer -- ^ number of binders?\n , eTVars :: !(F.SEnv ()) -- ^ type variables\n }\n\nextEnv :: Env -> F.Symbol -> RType -> Env\nextEnv env x t\n | x == junkSymbol = env\n | otherwise = env { eBinds = F.insertSEnv x t (eBinds env)\n , eSize = 1 + eSize env\n }\n\nextEnvs :: Env -> [(F.Symbol, RType)] -> Env\nextEnvs = L.foldl' (\\g (x, t) -> extEnv g x t)\n\nextEnvTV :: Env -> TVar -> Env\nextEnvTV env (TV a) = env { eTVars = F.insertSEnv a () (eTVars env) }\n\ngrdSym :: Env -> F.Symbol\ngrdSym env = F.tempSymbol \"grd\" (eSize env)\n\npredRType :: F.Pred -> RType\npredRType p = TBase TBool (known $ F.predReft p)\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x (eBinds env)\n\nempEnv :: [SrcData] -> Env\nempEnv typs = Env ctorEnv 0 F.emptySEnv\n where\n ctorEnv = F.fromListSEnv (prelude ++ concatMap dataSigs typs)\n\ndataSigs :: SrcData -> [(F.Symbol, RType)]\ndataSigs (Data _ _ _ ctors) = [(F.symbol b, t) | (b, t) <- ctors]\n\nenvSorts :: Env -> [(F.Symbol, F.Sort)]\nenvSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)\n , (t, _) <- Mb.maybeToList (sortPred x s) ]\n\n--------------------------------------------------------------------------------\n-- | Case-Related Environment Manipulation -------------------------------------\n--------------------------------------------------------------------------------\nunfoldEnv' :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe Env\nunfoldEnv' g y c zs = extEnvs g <$> unfoldEnv g y c zs\n\nunfoldEnv :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe [(F.Symbol, RType)]\nunfoldEnv g y c zs = unfold g c y >>= extCase y zs\n\nunfold:: Env -> DaCon -> Ident -> Maybe (RType, RType)\nunfold g c y = do\n (as, ps, t) <- bkAlls <$> getEnv g c\n ty@(TCon _ ts rs _) <- getEnv g y\n prs <- Misc.safeZip ps rs\n ats <- Misc.safeZip as ts\n return (ty, rsubsts prs . tsubsts ats $ t)\n\nextCase :: Ident -> [SrcBind] -> (RType, RType) -> Maybe [(F.Symbol, RType)]\nextCase y zs (ty, t) = go [] (F.symbol <$> zs) t\n where\n go acc (z:zs) (TFun x s t) = go ((z, s) : acc) zs (subst t x z)\n go acc [] t = Just ((y, meet ty t) : acc)\n go _ _ _ = Nothing\n\nmeet :: RType -> RType -> RType\nmeet t1 t2 = case rTypeReft t2 of\n Just r2 -> strengthenTop t1 r2\n Nothing -> t1\n\n{-\nextCaseEnv :: Env -> [Bind F.SrcSpan] -> RType -> Maybe Env\nextCaseEnv g (z:zs) (TFun _ s t) = extCaseEnv g' zs t\n where\n g' = extEnv g (F.symbol z) s\nextCaseEnv g [] _ = Just g\nextCaseEnv _ _ _ = Nothing\n\n-}\n\n\n\n-------------------------------------------------------------------------------\n-- | CG Monad -----------------------------------------------------------------\n-------------------------------------------------------------------------------\n\ntype CG a = StateT CGState (Either [UX.UserError]) a\n\ndata CGState = CGState\n { cgCount :: !Integer -- ^ monotonic counter, to get fresh things\n , cgKVars :: ![SrcHVar] -- ^ list of generated kvars\n }\n\ns0 :: CGState\ns0 = CGState 0 []\n\nrun :: CG a -> Either [UX.UserError] (a, [SrcHVar])\nrun act = do\n (x, s) <- runStateT act s0\n return (x, cgKVars s)\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = throwError [UX.mkError msg l]\n\nfreshK :: F.SrcSpan -> Env -> F.Sort -> CG Reft\nfreshK l g t = do\n v <- freshValueSym\n k <- freshKVar l (t:ts)\n return $ Known v (H.Var k (v:xs))\n where\n -- t = baseSort b\n (xs,ts) = unzip (envSorts g)\n\nfreshKVar :: F.SrcSpan -> [F.Sort] -> CG F.Symbol\nfreshKVar l ts = do\n k <- F.kv . F.intKvar <$> freshInt\n _ <- addSrcKVar (H.HVar k ts (UX.mkError \"fake\" l))\n return k\n\naddSrcKVar :: SrcHVar -> CG ()\naddSrcKVar k = modify $ \\s -> s { cgKVars = k : cgKVars s }\n\nfreshValueSym :: CG F.Symbol\nfreshValueSym = F.vv . Just <$> freshInt\n\nfreshInt :: CG Integer\nfreshInt = do\n s <- get\n let n = cgCount s\n put s { cgCount = 1 + n}\n return n\n" }, { "path": "src/Language/Sprite/L6/Elaborate.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n\nmodule Language.Sprite.L6.Elaborate (elaborate) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.List as L\nimport Control.Exception (throw)\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport Text.PrettyPrint.HughesPJ\n-- import Text.Printf (printf)\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.Common\nimport qualified Language.Sprite.Common.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L6.Prims\nimport Language.Sprite.L6.Types\nimport Language.Sprite.L6.Constraints\nimport Debug.Trace (trace)\nimport Control.Monad (void)\n\n-------------------------------------------------------------------------------\nelaborate :: Env -> SrcExpr -> ElbExpr\n-------------------------------------------------------------------------------\nelaborate g e = {- trace _msg -} e''\n where\n _msg = \"elaborate: \" ++ show (F.toListSEnv su, void e, void e'')\n e'' = subsTy su e'\n (su, e') = runElabM act\n act = elabC g e (bTrue TInt)\n\nrunElabM :: ElabM a -> (TvSub, a)\nrunElabM act = case runStateT act s0 of\n Left errs -> throw errs\n Right (v, s) -> (eSub s, v)\n where s0 = ElabS mempty 0\n\ntype TvSub = F.SEnv RType\ndata ElabS = ElabS { eSub :: !TvSub, eNum :: !Int }\ntype ElabM a = StateT ElabS (Either [UX.UserError]) a\n\nunifyV :: F.SrcSpan -> TVar -> RType -> ElabM RType\nunifyV _ a t@(TBase (TVar b) r)\n | a == b\n = return t\n | nonRigid a\n = assign a t >> return t\n | nonRigid b\n = assign b t' >> return t' where t' = TBase (TVar a) r\n\nunifyV l a t\n | a `elem` freeTVars t\n = occurError l a t\n | nonRigid a\n = assign a t >> return t\n | otherwise\n = rigidError l a t\n\nunify :: F.SrcSpan -> RType -> RType -> ElabM RType\nunify l (TBase (TVar a) _) t =\n unifyV l a t\nunify l t (TBase (TVar a) _) =\n unifyV l a t\nunify _ t1@(TBase b1 _) (TBase b2 _) | b1 == b2 =\n return t1\nunify l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n x <- pure (unifyX l x1 x2)\n s <- unify l s1 s2\n t1' <- subsTyM t1\n t2' <- subsTyM t2\n t <- unify l t1' t2'\n return (TFun x s t)\nunify l (TCon c1 t1s _ _) (TCon c2 t2s _ _) | c1 == c2 = do\n ts <- unifys l t1s t2s\n return (TCon c1 ts mempty mempty)\n\nunify l t1 t2 =\n unifyError l t1 t2\n\nunifys :: F.SrcSpan -> [RType] -> [RType] -> ElabM [RType]\nunifys _ [] [] =\n return []\nunifys l (t1:t1s) (t2:t2s) = do\n t <- unify l t1 t2\n t1s' <- mapM subsTyM t1s\n t2s' <- mapM subsTyM t2s\n ts <- unifys l t1s' t2s'\n return (t:ts)\nunifys l _ _ =\n throwError [UX.mkError \"unifys-mismatched args\" l]\n\n\nunifyX :: F.SrcSpan -> F.Symbol -> F.Symbol -> F.Symbol\nunifyX _ x _ = x\n\nunifyError :: F.SrcSpan -> RType -> RType -> ElabM a\nunifyError l t1 t2 = throwError [UX.mkError msg l]\n where msg = \"type error: cannot unify\" <+> UX.tshow t1 <+> \"and\" <+> UX.tshow t2\n\nrigidError :: F.SrcSpan -> TVar -> RType -> ElabM a\nrigidError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: cannot assign rigid\" <+> UX.tshow a <+> \"the type\" <+> UX.tshow t\n\noccurError :: F.SrcSpan -> TVar -> RType -> ElabM a\noccurError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: occurs check\" <+> UX.tshow a <+> \"occurs in\" <+> UX.tshow t\n\nmatchError :: F.SrcSpan -> Doc -> ElabM a\nmatchError l msg = throwError [UX.mkError (\"case-alt error:\" <+> msg) l]\n\n-------------------------------------------------------------------------------\nelabC :: Env -> SrcExpr -> RType -> ElabM ElbExpr\nelabC g (EFun b e l) (TFun _ s t) = do\n e' <- elabC (extEnv g (bindId b) s) e t\n return $ EFun b e' l\n\n-- let rec x:s = e1 in e2\nelabC g (ELet (RDecl (Bind x l) (EAnn e1 s1 l1) ld) e2 l2) t2 = do\n let g' = extEnv g x s1\n let (as, _, t1) = bkAlls s1\n e1' <- elabC (extEnvTVs g' as) e1 t1\n e2' <- elabC g' e2 t2\n return $ ELet (RDecl (Bind x l) (EAnn (mkTLam e1' as) s1 l1) ld) e2' l2\n\n-- let x = e in e'\nelabC g (ELet (Decl (Bind x l) e1 l1) e2 l2) t2 = do\n (e1', s) <- elabS g e1\n e2' <- elabC (extEnv g x s) e2 t2\n return $ ELet (Decl (Bind x l) e1' l1) e2' l2\n\n-- if b e1 e2\nelabC g (EIf b e1 e2 l) t = do\n e1' <- elabC g e1 t\n e2' <- elabC g e2 t\n return $ EIf b e1' e2' l\n\n-- switch (y) { | C(z..) => e | ... }\nelabC g (ECase y alts l) t = do\n alts' <- mapM (elabAlt g y t) alts\n return $ ECase y alts' l\n\nelabC g e t = do\n (e', t') <- elabS g e\n unify (label e) t t'\n return e'\n\nelabAlt :: Env -> Ident -> RType -> SrcAlt -> ElabM SrcAlt\nelabAlt g y t (Alt c zs e l) = do\n let al = mconcat (label <$> zs)\n case unfoldEnv' g y c zs of\n Nothing -> matchError al \"bad pattern match\"\n Just g' -> (\\e' -> Alt c zs e' l) <$> elabC g' e t\n\n\n\nextEnvTVs :: Env -> [TVar] -> Env\nextEnvTVs = foldr (flip extEnvTV)\n\n-------------------------------------------------------------------------------\nelabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType)\nelabS g e@(EImm i _) = do\n (ts, n, t') <- Misc.traceShow (\"elabS: \" ++ show i) <$> immS g i\n return (mkTApp e ts n, t')\n\nelabS g (EAnn e s l) = do\n let (as, _, t) = bkAlls s\n e' <- elabC (extEnvTVs g as) e t\n return (EAnn (mkTLam e' as) s l, s)\n\nelabS g (EApp e y l) = do\n (e', te) <- elabS g e\n case te of\n TFun _ s t -> do (\\(_,_,yt) -> unify l s ({- Misc.traceShow (\"elabS1 \" ++ show s) -} yt) ) =<< immS g y\n t' <- subsTyM t\n return (EApp e' y l, t')\n _ -> elabErr (\"elabS: Application to non-function; caller type = \" <+> UX.tshow te) l\n\nelabS _ e =\n elabErr (\"elabS unexpected:\" <+> UX.tshow (void e)) (label e)\n\n\n-------------------------------------------------------------------------------\n\nelabErr :: UX.Text -> F.SrcSpan -> ElabM a\nelabErr msg l = throwError [UX.mkError msg l]\n\ninstantiate :: RType -> ElabM ([RType], Int, RType)\ninstantiate = go [] 0\n where\n go ts n (TAll a s) = do v <- fresh\n let vt = TBase (TVar v) mempty\n go (vt:ts) n (tsubst a vt s)\n go ts n (TRAll _ s) = go ts (n+1) s\n go ts n s = return (reverse ts, n, s)\n\nfresh :: ElabM TVar\nfresh = do\n s <- get\n let n = eNum s\n put s { eNum = n + 1 }\n return (nonRigidTV n)\n\nnonRigidTV :: Int -> TVar\nnonRigidTV = TV . F.intSymbol \"fv\"\n\nnonRigid :: TVar -> Bool\nnonRigid (TV a) = F.isPrefixOfSym \"fv\" a\n\nimmS :: Env -> SrcImm -> ElabM ([RType], Int, RType)\nimmS g i = instantiate =<< immTy g i\n where\n immTy :: Env -> SrcImm -> ElabM RType\n immTy g (EVar x l)\n | Just t <- getEnv g x = return t\n | otherwise = elabErr (\"Unbound variable:\" <+> F.pprint x) l\n immTy _ (ECon c l) = return (constTy l c)\n\nmkTLam :: SrcExpr -> [TVar] -> ElbExpr\nmkTLam = foldr (\\a e -> ETLam a e (label e))\n\nmkTApp :: SrcExpr -> [RType] -> Int -> ElbExpr\nmkTApp e ts n = mkRApps n (mkTApps e ts)\n where\n mkRApps 0 e = e\n mkRApps k e = mkRApps (k-1) (ERApp e (label e))\n mkTApps = L.foldl' (\\e t -> ETApp e t (label e))\n\n-- | Type Substitutions --------------------------------------------------------------\n\nclass SubsTy a where\n subsTy :: TvSub -> a -> a\n subsTy1 :: TVar -> RType -> a -> a\n subsTy1 a t x = subsTy (singTvSub a t) x\n\nsingTvSub :: TVar -> RType -> TvSub\nsingTvSub a t = F.fromListSEnv [(F.symbol a, t)]\n\ninstance SubsTy RARef where\n subsTy su (ARef xts p) = ARef xts' p\n where\n xts' = [(x, subsTy su t) | (x, t) <- xts ]\n\ninstance SubsTy RType where\n subsTy su t@(TBase (TVar a) _) = Mb.fromMaybe t t'\n where\n t' = F.lookupSEnv (F.symbol a) su\n\n subsTy _su t@(TBase {}) = t\n\n subsTy su (TCon c ts ps r) = TCon c (subsTy su <$> ts) (subsTy su <$> ps) r\n\n subsTy su (TFun x s t) = TFun x s' t'\n where\n s' = subsTy su s\n t' = subsTy su t\n\n subsTy su (TAll a t) = TAll a t'\n where\n t' = subsTy su' t\n su' = F.deleteSEnv (F.symbol a) su\n\n subsTy su (TRAll p t) = TRAll p' t'\n where\n t' = subsTy su t\n p' = subsTy su p\n\ninstance SubsTy RVar where\n subsTy su (RVar p args) = RVar p (subsTy su <$> args)\n\ninstance SubsTy RSort where\n subsTy su = asRType (subsTy su)\n\ninstance SubsTy TvSub where\n subsTy = F.mapSEnv . subsTy\n\n-- applies the substs to the ETApp types\ninstance SubsTy ElbExpr where\n subsTy = subsTyExpr\n\ninstance SubsTy ElbDecl where\n subsTy su (Decl b e l) = Decl b (subsTy su e) l\n subsTy su (RDecl b e l) = RDecl b (subsTy su e) l\n\nsubsTyExpr :: TvSub -> ElbExpr -> ElbExpr\nsubsTyExpr su = go\n where\n go (EFun b e l) = EFun b (go e) l\n go (EApp e i l) = EApp (go e) i l\n go (ELet d e l) = ELet d' (go e) l where d' = subsTy su d\n go (EAnn e t l) = EAnn (go e) t l\n go (EIf i e1 e2 l) = EIf i (go e1) (go e2) l\n go (ETLam a e l) = ETLam a (go e) l\n go (ETApp e t l) = ETApp (go e) (subsTy su t) l\n go (ERApp e l) = ERApp (go e) l\n go (ECase x as l) = ECase x (goA <$> as) l\n go e@(EImm {}) = e\n goA alt = alt -- { altTyArgs = fmap (subsTy su) <$> altTyArgs alt }\n { altExpr = go $ altExpr alt }\n\n\n\n\nsubsTyM :: (SubsTy a) => a -> ElabM a\nsubsTyM x = do\n su <- gets eSub\n return (subsTy su x)\n\nassign :: TVar -> RType -> ElabM ()\nassign a t = modify $ \\s -> s { eSub = updSub a t (eSub s)}\n\nupdSub :: TVar -> RType -> TvSub -> TvSub\nupdSub a t su = F.insertSEnv (F.symbol a) t (subsTy1 a t su)\n" }, { "path": "src/Language/Sprite/L6/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L6.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , measureP\n , rtype\n , expr\n , typP\n , switchExpr\n , altP\n ) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport Control.Monad.Combinators.Expr\nimport Text.Megaparsec hiding (State, label)\nimport Text.Megaparsec.Char\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport qualified Language.Fixpoint.Horn.Types as H\nimport Language.Sprite.Common\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common.Parse\n\nimport Language.Sprite.L6.Types hiding (rVarARef, immExpr)\n-- import Language.Sprite.L6.Constraints\n\nparseFile :: FilePath -> IO SrcProg\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser SrcProg\nprog = do\n qs <- quals\n ms <- (try (many measureP)) <|> return []\n typs <- many typP\n src <- declsExpr <$> many decl\n return (Prog qs ms src (Misc.traceShow \"prog-types\" typs))\n\nmeasureP :: FP.Parser (F.Symbol, F.Sort)\nmeasureP = annL >> (Misc.mapSnd (rTypeSort . generalize) <$> tyBindP \"measure\")\n\ntypP :: FP.Parser SrcData\ntypP = do\n FP.reserved \"type\"\n tc <- FP.lowerIdP\n tvars <- typArgs\n rvars <- commaList refVar\n (FP.reservedOp \"=\" >> FP.spaces)\n ctors <- ctorsP\n return (Data tc tvars rvars (mkCtor tc tvars rvars <$> ctors))\n\ndata Ctor = Ctor SrcBind [FunArg] (Maybe Reft)\ntype FunArg = (F.Symbol, RType)\n\nctorsP :: FP.Parser [Ctor]\nctorsP = try (FP.semi >> return [])\n <|> (:) <$> ctorP <*> ctorsP\n\nctorP :: FP.Parser Ctor\nctorP = Ctor <$> (FP.spaces *> mid *> cbind) <*> commaList funArgP <*> ctorResP\n\ncbind :: FP.Parser SrcBind\ncbind = withSpan' (Bind <$> FP.upperIdP)\n\ntypArgs :: FP.Parser [F.Symbol]\ntypArgs = commaList tvarP\n\nctorResP :: FP.Parser (Maybe Reft)\nctorResP = Just <$> (FP.reservedOp \"=>\" *> FP.brackets concReftB)\n <|> return Nothing\n\nmkCtor :: Ident -> [Ident] -> [RVar] -> Ctor -> (SrcBind, RType)\nmkCtor tc tvs rvs c = (dc, closeType rvs xts dcRes)\n where\n -- dcType = foldr (\\(x, t) s -> TFun x t s) dcRes xts\n dcRes = TCon tc (rVar <$> tvs) (rVarARef <$> rvs) dcReft\n Ctor dc xts r = c\n dcReft = Mb.fromMaybe mempty r\n\ncloseType :: [RVar] -> [(F.Symbol, RType)] -> RType -> RType\ncloseType rvs xts = tyParams\n . rvarParams\n . valParams\n where\n tyParams = generalize\n rvarParams t = foldr TRAll t rvs\n valParams ty = foldr (\\(x, t) s -> TFun x t s) ty xts\n\nrVarARef :: RVar -> RARef\nrVarARef (RVar p ts) = ARef xts (predReft pred)\n where\n xts = zipWith (\\t i -> (F.intSymbol \"rvTmp\" i, t)) ts [0..]\n pred = F.eApps (F.expr p) (F.expr . fst <$> xts)\n\ncommaList :: FP.Parser a -> FP.Parser [a]\ncommaList p = try (FP.parens (sepBy p FP.comma)) <|> return []\n\nquals :: FP.Parser [F.Qualifier]\nquals = try ((:) <$> between annL annR qual <*> quals)\n <|> pure []\n\nqual ::FP.Parser F.Qualifier\nqual = FP.reserved \"qualif\" >> FP.qualifierP (rTypeSort <$> rtype)\n\nexpr :: FP.Parser SrcExpr\nexpr = try funExpr\n <|> try letExpr\n <|> try ifExpr\n <|> try switchExpr\n <|> try (FP.braces (expr <* FP.spaces))\n <|> try appExpr\n <|> try binExp\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try (FP.parens expr)\n <|> immExpr\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> immExpr <*> FP.parens (sepBy1 imm FP.comma)\n\nbinExp :: FP.Parser SrcExpr\nbinExp = withSpan' $ do\n x <- imm\n o <- op\n y <- imm\n return (bop o x y)\n\nop :: FP.Parser PrimOp\nop = (FP.reservedOp \"*\" >> pure BTimes)\n <|> (FP.reservedOp \"+\" >> pure BPlus )\n <|> (FP.reservedOp \"-\" >> pure BMinus)\n <|> (FP.reservedOp \"<\" >> pure BLt )\n <|> (FP.reservedOp \"<=\" >> pure BLe )\n <|> (FP.reservedOp \"==\" >> pure BEq )\n <|> (FP.reservedOp \">\" >> pure BGt )\n <|> (FP.reservedOp \">=\" >> pure BGe )\n <|> (FP.reservedOp \"&&\" >> pure BAnd )\n <|> (FP.reservedOp \"||\" >> pure BOr )\n\nbop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr\nbop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nifExpr :: FP.Parser SrcExpr\nifExpr = withSpan' $ do\n FP.reserved \"if\"\n v <- FP.parens imm\n e1 <- expr\n FP.reserved \"else\"\n e2 <- expr\n return (EIf v e1 e2)\n\nswitchExpr :: FP.Parser SrcExpr\nswitchExpr = withSpan' $ do\n FP.reserved \"switch\"\n x <- FP.parens FP.lowerIdP\n alts <- FP.braces (many altP)\n return (ECase x alts)\n\naltP :: FP.Parser SrcAlt\naltP = withSpan' $ Alt\n <$> (FP.spaces *> mid *> FP.upperIdP)\n -- <*> pure Nothing\n <*> commaList binder\n <*> (FP.reservedOp \"=>\" *> expr)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = immInt <|> immBool <|> immId\n\nimmInt :: FP.Parser SrcImm\nimmInt = withSpan' (ECon . PInt <$> FP.natural)\n\nimmBool :: FP.Parser SrcImm\nimmBool = withSpan' (ECon . PBool <$> bool)\n\nimmId :: FP.Parser SrcImm\nimmId = withSpan' (EVar <$> identifier')\n\nbool :: FP.Parser Bool\nbool = (FP.reserved \"true\" >> pure True)\n <|>(FP.reserved \"false\" >> pure False)\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- FP.parens (sepBy1 binder FP.comma)\n _ <- FP.reservedOp \"=>\"\n -- _ <- FP.reservedOp \"{\"\n body <- FP.braces (expr <* FP.spaces)\n -- _ <- FP.reservedOp \"}\"\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = mkDecl <$> ann <*> plainDecl\n where\n ann = (annL >> (Just <$> tyBindP \"val\")) <|> pure Nothing\n\ntype Ann = Maybe (F.Symbol, RType)\n\nannL, annR :: FP.Parser ()\nannL = FP.reservedOp \"/*@\"\nannR = FP.reservedOp \"*/\"\n\ntyBindP :: String -> FP.Parser (F.Symbol, RType)\ntyBindP kw = do\n FP.reserved kw\n x <- identifier\n FP.colon\n t <- rtype\n annR\n return (x, t)\n\n{-\nbetween :: FP.Parser () -> FP.Parser () -> FP.Parser a -> FP.Parser a\nbetween lP rP xP = do\n lP\n x <- xP\n rP\n return x\n -}\nmkDecl :: Ann -> SrcDecl -> SrcDecl\nmkDecl (Just (x, t)) (Decl b e l)\n | x == bindId b = Decl b (EAnn e (generalize t) (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl (Just (x, t)) (RDecl b e l)\n | x == bindId b = RDecl b (EAnn e (generalize t) (label e)) l\n | otherwise = error $ \"bad annotation: \" ++ show (x, bindId b)\nmkDecl Nothing d = d\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n ctor <- (FP.reserved \"let rec\" >> pure RDecl) <|>\n (FP.reserved \"let\" >> pure Decl)\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (ctor b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = (FP.reserved \"forall\" >> rall)\n <|> try rfun\n <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = FP.parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArgP <*> (FP.reservedOp \"=>\" *> rtype)\n\nrall :: FP.Parser RType\nrall = TRAll <$> FP.parens refVar <*> (FP.dot *> rtype)\n\nrefVar :: FP.Parser RVar\nrefVar = mkRVar <$> FP.lowerIdP <*> (FP.colon *> rtype)\n\nmkRVar :: F.Symbol -> RType -> RVar\nmkRVar p t\n | isBool out = RVar p [ const () <$> s | (_, s) <- xs ]\n | otherwise = error \"Refinement variable must have `bool` as output type\"\n where\n (xs, out) = bkFun t\n\nisBool :: RType -> Bool\nisBool t = rTypeSort t == F.boolSort\n\nfunArgP :: FP.Parser FunArg\nfunArgP = try ((,) <$> FP.lowerIdP <*> (FP.colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = try (TBase <$> tbase <*> refTop)\n <|> TCon <$> identifier' <*> commaList rtype <*> tConARefs <*> refTop\n\n\ntbase :: FP.Parser Base\ntbase = (FP.reserved \"int\" >> pure TInt)\n <|> (FP.reserved \"bool\" >> pure TBool)\n <|> (tvarP >>= return . TVar. TV)\n\ntConARefs :: FP.Parser [RARef]\ntConARefs = try (commaList aRef)\n <|> pure []\n\ntvarP :: FP.Parser F.Symbol\ntvarP = FP.reservedOp \"'\" >> FP.lowerIdP -- >>= return . TVar . TV\n\nrefTop :: FP.Parser Reft\nrefTop = FP.brackets reftB <|> pure mempty\n\nreftB :: FP.Parser Reft\nreftB = (question >> pure Unknown)\n <|> concReftB\n\nconcReftB :: FP.Parser Reft\nconcReftB = KReft <$> (FP.lowerIdP <* mid) <*> myPredP\n\naRef :: FP.Parser (ARef Reft)\naRef = ARef <$> commaList aRefArg <* FP.reservedOp \"=>\" <*> aRefBody\n where\n aRefArg :: FP.Parser (F.Symbol, RSort)\n aRefArg = (,) <$> FP.lowerIdP <* FP.colon <*> rSortP\n\naRefBody :: FP.Parser Reft\naRefBody = predReft <$> myPredP\n\npredReft :: F.Pred -> Reft\npredReft = Known F.dummySymbol . H.Reft\n\nrSortP :: FP.Parser RSort\nrSortP = rTypeToRSort <$> rtype0\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\nquestion :: FP.Parser ()\nquestion = FP.reservedOp \"?\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))\n" }, { "path": "src/Language/Sprite/L6/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L6.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.L6.Types \nimport Language.Sprite.L6.Parse\n\n-- | \"Prelude\" Environment --------------------------------------------\n\nprelude :: [(F.Symbol, RType)]\nprelude = \n [ (\"diverge\" , mkTy \"x:int => 'a\")\n , (\"impossible\", mkTy \"x:int[v|false] => 'a\")\n ]\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n)) \nconstTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)\nconstTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)\nconstTy l (PBin o) = binOpTy l o\n\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n\n , (BLt , mkTy \"x:'a => y:'a => bool[v|v <=> (x < y)]\")\n , (BLe , mkTy \"x:'a => y:'a => bool[v|v <=> (x <= y)]\")\n , (BGt , mkTy \"x:'a => y:'a => bool[v|v <=> (x > y)]\")\n , (BGe , mkTy \"x:'a => y:'a => bool[v|v <=> (x >= y)]\")\n , (BEq , mkTy \"x:'a => y:'a => bool[v|v <=> (x == y)]\")\n\n , (BAnd , mkTy \"x:bool => y:bool => bool[v|v <=> (x && y)]\")\n , (BOr , mkTy \"x:bool => y:bool => bool[v|v <=> (x || y)]\")\n , (BNot , mkTy \"x:bool => bool[v|v <=> not x]\")\n ]\n\nmkTy :: String -> RType\nmkTy = {- Misc.traceShow \"mkTy\" . -} rebind . generalize . parseWith rtype \"prims\" \n\n\nrebind :: RType -> RType\nrebind t@(TBase {}) = t \nrebind (TAll a t) = TAll a (rebind t) \nrebind (TRAll p t) = TRAll p (rebind t) \nrebind (TCon c ts ps r) = TCon c (rebind <$> ts) ps r\nrebind (TFun x s t) = TFun x' s' t' \n where \n x' = F.mappendSym \"spec#\" x\n s' = subst (rebind s) x x'\n t' = subst (rebind t) x x'" }, { "path": "src/Language/Sprite/L6/Types.hs", "content": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n{-# LANGUAGE FlexibleInstances #-}\n\n\nmodule Language.Sprite.L6.Types where \n\nimport qualified Language.Fixpoint.Misc as Misc\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Horn.Transformations as H\nimport qualified Language.Fixpoint.Types as F\n-- import qualified Language.Sprite.Common.Misc as Misc \nimport qualified Language.Sprite.Common.UX as UX \nimport Language.Sprite.Common\nimport qualified Data.Set as S\nimport qualified Data.List as L\n\n-- | Basic types --------------------------------------------------------------\nnewtype TVar = TV F.Symbol\n deriving (Eq, Ord, Show)\n\ninstance F.Symbolic TVar where \n symbol (TV a) = a\n\ndata Base = TInt | TBool | TVar TVar\n deriving (Eq, Ord, Show)\n\ninstance F.PPrint Base where \n pprintTidy _ = UX.tshow\n\n-- | Refinement Variables -----------------------------------------------------\ndata RVar = RVar \n { rvName :: F.Symbol \n , rvArgs :: ![RSort]\n } \n deriving (Eq, Show)\n\n-- | Abstract Refinements -----------------------------------------------------\ndata ARef r = ARef \n { arArgs :: ![(F.Symbol, RSort)] \n , arPred :: r\n }\n deriving (Eq, Show, Functor)\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r \n = TBase !Base r -- ^ Int{r} \n | TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t \n | TAll !TVar !(Type r) -- ^ all a. t\n | TCon !TyCon ![Type r] ![ARef r] r -- ^ C t1...tn p1...pm\n | TRAll !RVar !(Type r) -- ^ rall r. t\n deriving (Eq, Show, Functor)\n\nrVar :: F.Symbol -> RType\nrVar a = TBase (TVar (TV a)) mempty\n\nrInt :: RType \nrInt = TBase TInt mempty\n\nrBool :: RType \nrBool = TBase TBool mempty \n\ndata Reft \n = Known !F.Symbol !H.Pred -- ^ Known refinement\n | Unknown -- ^ Unknown, to-be-synth refinement\n deriving (Show)\n\nknown :: F.Reft -> Reft\nknown (F.Reft (v, r)) = KReft v r\n\npattern KReft v p = Known v (H.Reft p)\n\ninstance Semigroup Reft where \n Unknown <> r = r\n r <> Unknown = r\n-- KReft v1 r1 <> KReft v2 r2 = KReft v r where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)\n Known v p <> Known v' p' \n | v == v' = Known v (p <> p')\n | v == F.dummySymbol = Known v' (p' <> (p `F.subst1` (v , F.EVar v')))\n | otherwise = Known v (p <> (p' `F.subst1` (v', F.EVar v )))\n-- _ <> _ = error \"Semigroup Reft: TBD\"\n \ninstance Monoid Reft where \n mempty = KReft v r where F.Reft (v, r) = mempty\n\n-- | Proper refinement Types --------------------------------------------------\ntype RType = Type Reft\ntype RARef = ARef Reft\n\n-- | Sorts: types decorated with unit refinements -----------------------------\ntype RSort = Type ()\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp \n = BPlus \n | BMinus \n | BTimes\n | BLt\n | BLe\n | BEq \n | BGt\n | BGe\n | BAnd\n | BOr\n | BNot\n deriving (Eq, Ord, Show)\n\ndata Prim \n = PInt !Integer -- 0,1,2,... \n | PBool !Bool -- true, false\n | PBin !PrimOp -- +,-,==,<=,...\n deriving (Eq, Ord, Show)\n\n---------------------------------------------------------------------------------\n-- | Terms ----------------------------------------------------------------------\n---------------------------------------------------------------------------------\n\n-- | Bindings -------------------------------------------------------------------\n\ndata Bind a \n = Bind !Ident a\n deriving (Eq, Ord, Show, Functor)\n\ninstance F.Symbolic (Bind a) where\n symbol = bindId\n\nbindId :: Bind a -> F.Symbol \nbindId (Bind x _) = x\n\njunkSymbol :: F.Symbol\njunkSymbol = \"_\"\n\n-- | Names of things ------------------------------------------------------------ \ntype Ident = F.Symbol -- ^ Identifiers \ntype DaCon = F.Symbol -- ^ Data constructors\ntype TyCon = F.Symbol -- ^ Type constructors\n \n-- | \"Immediate\" terms (can appear as function args & in refinements) -----------\n\ndata Imm a\n = EVar !Ident a\n | ECon !Prim a\n deriving (Show, Functor)\n\n-- | Variable definition ---------------------------------------------------------\ndata Decl a \n = Decl (Bind a) (Expr a) a -- ^ plain \"let\" \n | RDecl (Bind a) (Expr a) a -- ^ recursive \"let rec\"\n deriving (Show, Functor)\n\n-- | Case-Alternatives -----------------------------------------------------------\n\ndata Alt a = Alt \n { altDaCon :: !DaCon -- ^ Data constructor\n , altBinds :: ![Bind a] -- ^ Binders x1...xn\n , altExpr :: !(Expr a) -- ^ Body-expr\n , altLabel :: a -- ^ Label\n } \n deriving (Show, Functor)\n\n-- | Terms -----------------------------------------------------------------------\ndata Expr a \n = EImm !(Imm a) a -- ^ x,y,z,... 1,2,3...\n | EFun !(Bind a) !(Expr a) a -- ^ \\x -> e\n | EApp !(Expr a) !(Imm a) a -- ^ e v\n | ELet !(Decl a) !(Expr a) a -- ^ let/rec x = e1 in e2\n | EAnn !(Expr a) !RType a -- ^ e:t\n | EIf !(Imm a) !(Expr a) !(Expr a) a -- ^ if v e1 e2\n | ETLam !TVar !(Expr a) a -- ^ Λ a. e (type abstraction)\n | ETApp !(Expr a) !RType a -- ^ e [t] (type application)\n | ERApp !(Expr a) a -- ^ e [?] (reft application)\n | ECase !Ident ![Alt a] a -- ^ switch (x) { a1 ... }\n deriving (Show, Functor)\n\ninstance Label Bind where \n label (Bind _ l) = l\n\ninstance Label Alt where \n label = altLabel \n\ninstance Label Imm where \n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where \n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ l) = l\n label (EIf _ _ _ l) = l\n label (ETLam _ _ l) = l\n label (ETApp _ _ l) = l\n label (ERApp _ l) = l\n label (ECase _ _ l) = l\n \ninstance Label Decl where \n label (Decl _ _ l) = l\n label (RDecl _ _ l) = l\n\n------------------------------------------------------------------------------\n-- | Top-level `Program` datatype \n------------------------------------------------------------------------------\ndata Prog a = Prog \n { prQuals :: ![F.Qualifier]\n , prMeas :: ![(F.Symbol, F.Sort)]\n , prExpr :: !(Expr a)\n , prData :: ![Data a]\n }\n deriving (Show, Functor)\n\ndata Data a = Data \n { dcName :: !Ident -- ^ name of the datatype\n , dcVars :: ![Ident] -- ^ type variables\n , dcRVars :: ![RVar] -- ^ refinement variables\n , dcCtors :: ![(Bind a, RType)] -- ^ constructors\n } \n deriving (Show, Functor)\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d \ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d \ndeclsExpr _ = error \"impossible\"\n\nintExpr :: Integer -> a -> Expr a \nintExpr i l = EImm (ECon (PInt i) l) l\n\nboolExpr :: Bool -> a -> Expr a\nboolExpr b l = EImm (ECon (PBool b) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\ntype ElbDecl = Decl F.SrcSpan\ntype ElbExpr = Expr F.SrcSpan \ntype SrcProg = Prog F.SrcSpan\ntype SrcData = Data F.SrcSpan\ntype SrcAlt = Alt F.SrcSpan\n------------------------------------------------------------------------------\n\n-- | should/need only be defined on \"Known\" variants. TODO:LIQUID\ninstance F.Subable Reft where \n syms (Known v r) = v : F.syms r\n syms Unknown = []\n substa f (Known v r) = Known (f v) (F.substa f r)\n substa _ (Unknown) = Unknown\n substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r) \n substf _ (Unknown) = Unknown\n subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)\n subst _ (Unknown) = Unknown\n subst1 (Known v r) su = Known v (F.subst1Except [v] r su)\n subst1 (Unknown) _ = Unknown\n\n-- instance F.Subable ARef where \ninstance F.Subable r => F.Subable (ARef r) where \n syms (ARef _ p) = F.syms p\n substa f (ARef xts p) = ARef xts (F.substa f p)\n substf f (ARef xts p) = ARef xts (F.substf f p)\n subst f (ARef xts p) = ARef xts (F.subst f p)\n\ninstance F.Subable r => F.Subable (Type r) where \n -- syms :: a -> [Symbol] \n syms (TBase _ r) = F.syms r\n syms (TAll _ t) = F.syms t\n syms (TRAll _ t) = F.syms t\n syms (TFun _ s t) = F.syms s ++ F.syms t\n syms (TCon _ ts ps r) = concatMap F.syms ts ++ concatMap F.syms ps ++ F.syms r\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r \n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n substa f (TAll a t) = TAll a (F.substa f t)\n substa f (TRAll p t) = TRAll p (F.substa f t)\n substa f (TCon c ts ps r) = TCon c (F.substa f <$> ts) (F.substa f <$> ps) (F.substa f r)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n substf f (TAll a t) = TAll a (F.substf f t)\n substf f (TRAll p t) = TRAll p (F.substf f t)\n substf f (TCon c ts ps r) = TCon c (F.substf f <$> ts) (F.substf f <$> ps) (F.substf f r)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n subst f (TAll a t) = TAll a (F.subst f t)\n subst f (TRAll p t) = TRAll p (F.subst f t)\n subst f (TCon c ts ps r) = TCon c (F.subst f <$> ts) (F.subst f <$> ps) (F.subst f r)\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where \n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\nsubsts :: (F.Subable a) => a -> [(F.Symbol, F.Symbol)] -> a\nsubsts thing xys = L.foldl' (\\t (x, y) -> subst t x y) thing xys\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\nimmExpr (ECon (PBool True) _) = F.PTrue\nimmExpr (ECon (PBool False) _) = F.PFalse\nimmExpr _ = error \"impossible\"\n\n--------------------------------------------------------------------------------\n-- | Normalizing types by generalizing tyvars, refactoring ref-var applications \n--------------------------------------------------------------------------------\ngeneralize :: RType -> RType\ngeneralize = refactorApp . generalizeTVar\n\n--------------------------------------------------------------------------------\n-- | Substituting Type Variables -----------------------------------------------\n--------------------------------------------------------------------------------\ntsubst :: TVar -> RType -> RType -> RType\ntsubst a t = go \n where \n go (TAll b s) \n | a == b = TAll b s \n | otherwise = TAll b (go s)\n go (TRAll p t) = TRAll (goP p) (go t)\n go (TFun x s1 s2) = TFun x (go s1) (go s2) \n go (TBase b r) = bsubst a t b r\n go (TCon c ts ps r) = TCon c (go <$> ts) (goA <$> ps) r\n goP p = p { rvArgs = [ asRType go t | t <- rvArgs p ] }\n goA a = a { arArgs = [ (x, asRType go t) | (x, t) <- arArgs a ] }\n\ntsubsts :: [(TVar, RType)] -> RType -> RType\ntsubsts ats s = L.foldl' (\\s (a, t) -> tsubst a t s) s ats\n\nbsubst :: TVar -> RType -> Base -> Reft -> RType \nbsubst a t (TVar v) r \n | v == a = strengthenTop t r \nbsubst _ _ b r = TBase b r\n\nrTypeReft :: RType -> Maybe Reft\nrTypeReft (TBase _ r) = Just r\nrTypeReft (TCon _ _ _ r) = Just r\nrTypeReft _ = Nothing\n\nstrengthenTop :: RType -> Reft -> RType\nstrengthenTop t@(TFun {}) _ = t\nstrengthenTop t@(TAll {}) _ = t\nstrengthenTop t@(TRAll {}) _ = t\nstrengthenTop (TBase b r) r' = TBase b (r <> r')\nstrengthenTop (TCon c ts ps r) r' = TCon c ts ps (r <> r')\n\ngeneralizeTVar :: RType -> RType\ngeneralizeTVar t = foldr TAll t (freeTVars t) \n\nfreeTVars :: Type a -> [TVar]\nfreeTVars = Misc.sortNub . S.toList . go\n where\n goP = S.fromList . concatMap freeTVars . rvArgs \n go (TAll a t) = S.delete a (go t) \n go (TRAll p t) = S.union (goP p) (go t)\n go (TFun _ s t) = S.union (go s) (go t)\n go (TCon _ ts _ _) = S.unions ((go <$> ts)) \n go (TBase b _) = goB b \n goB (TVar a) = S.singleton a\n goB _ = S.empty\n\n-------------------------------------------------------------------------------\n-- | Types and Sorts\n-------------------------------------------------------------------------------\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\nbaseSort TBool = F.boolSort\nbaseSort (TVar a) = F.FObj (F.symbol a)\n\nrTypeSort :: RType -> F.Sort\nrTypeSort (TBase b _) = baseSort b\nrTypeSort (TCon c ts _ _) = F.fAppTC (fTyCon c) (rTypeSort <$> ts)\nrTypeSort t@(TFun {}) = rTypeSortFun t \nrTypeSort t@(TAll {}) = rTypeSortAll t \nrTypeSort (TRAll _ t) = rTypeSort t \n\nrTypeSortFun :: RType -> F.Sort\nrTypeSortFun = F.mkFFunc 0 . fmap rTypeSort . go []\n where \n go ts (TFun _ t1 t2) = go (t1:ts) t2\n go ts t = reverse (t:ts)\n\nrTypeSortAll :: RType -> F.Sort\nrTypeSortAll s = genSort (rTypeSort t)\n where\n genSort t = L.foldl' (flip F.FAbs) (F.sortSubst su t) [0..n-1]\n (as, t) = bkAll s\n su = F.mkSortSubst $ zip sas (F.FVar <$> [0..])\n sas = F.symbol <$> as\n n = length as\n\nbkAll :: RType -> ([TVar], RType)\nbkAll (TAll a s) = (a:as, t) where (as, t) = bkAll s\nbkAll t = ([] , t)\n\nbkRAll :: RType -> ([RVar], RType)\nbkRAll (TRAll p s) = (p:ps, t) where (ps, t) = bkRAll s\nbkRAll t = ([] , t)\n\nfTyCon :: TyCon -> F.FTycon\nfTyCon = F.symbolFTycon . F.dummyLoc\n\nbkFun :: RType -> ([(F.Symbol, RType)], RType)\nbkFun (TFun x s t) = ((x, s) : ins, out) where (ins, out) = bkFun t\nbkFun out = ([] , out)\n\n\n-- | See [NOTE:RefactorApp] ---------------------------------------------------\nrefactorApp :: RType -> RType\nrefactorApp s = tAlls as ps (refactorAppR isRV <$> t) \n where \n (as,ps,t) = bkAlls s\n pvs = S.fromList (rvName <$> ps)\n isRV p = S.member p pvs\n \ntAlls :: [TVar] -> [RVar] -> RType -> RType \ntAlls as ps = tAll as . tRAll ps\n\ntAll :: [TVar] -> Type a -> Type a\ntAll as t = foldr TAll t as\n\ntRAll :: [RVar] -> Type a -> Type a\ntRAll ps t = foldr TRAll t ps \n\nbkAlls :: RType -> ([TVar], [RVar], RType)\nbkAlls s = (as, ps, t)\n where \n (as, s') = bkAll s\n (ps, t) = bkRAll s'\n\nrefactorAppR :: (F.Symbol -> Bool) -> Reft -> Reft\nrefactorAppR isRV (Known v p) = Known v (refactorAppP isRV p)\nrefactorAppR _ r = r\n\n-- | See [NOTE:RefactorApp] ---------------------------------------------------\nrefactorAppP :: (F.Symbol -> Bool) -> H.Pred -> H.Pred\nrefactorAppP isRV p = H.PAnd (H.Reft (F.pAnd fs) : rs)\n where \n es = predExprs p\n (rs, fs) = Misc.mapEither (isRVarApp isRV) es\n\nisRVarApp :: (F.Symbol -> Bool) -> F.Expr -> Either H.Pred F.Expr\nisRVarApp isRV e@(F.EApp {}) \n | (F.EVar k, args) <- F.splitEApp e \n , isRV k = Left (H.Var k (rvarArgSymbol msg <$> args)) where msg = F.showpp e\nisRVarApp _ e = Right e\n\nrvarArgSymbol :: String -> F.Expr -> F.Symbol \nrvarArgSymbol _ (F.EVar x) = x\nrvarArgSymbol msg e = error $ \"Unexpected argument in ref-variable: \" ++ msg ++ \" \" ++ show e \n\npredExprs :: H.Pred -> [F.Expr]\npredExprs p = case H.flatten p of \n H.PAnd ps -> concatMap go ps\n q -> go q\n where \n go (H.Reft e) = F.conjuncts e \n go _ = error \"unexpected H.Pred in predExprs\"\n\n{- | [NOTE:RefactorApp] The parser cannot distinguish between \n * plain applications (f x y z) and \n * ref-var applications (p x y z) using \n `H.Var !F.Symbol ![F.Symbol] -- ^ $k(y1..yn)`\n So, post-parsing, we traverse the refinements with an `isRV` \n test to pull the ref-var applications out.\n -}\n\nasRType :: (RType -> RType) -> RSort -> RSort\nasRType f = rTypeToRSort . f . rSortToRType \n\nrTypeToRSort :: RType -> RSort\nrTypeToRSort = fmap (const ())\n\nrSortToRType :: RSort -> RType\nrSortToRType = fmap (const mempty)\n\nrSortToFSort :: RSort -> F.Sort\nrSortToFSort = rTypeSort . rSortToRType\n\nrVarARef :: RVar -> RARef\nrVarARef (RVar p ts) = ARef xts (Known F.dummySymbol pred)\n where \n xts = zipWith (\\t i -> (F.intSymbol \"kvTmp\" i, t)) ts [0..] \n pred = H.Var p (fst <$> xts)\n\n-------------------------------------------------------------------------------\n-- | Substituting Refinement Variables -----------------------------------------------\n-------------------------------------------------------------------------------\nclass SubsARef a where \n subsAR :: F.Symbol -> RARef -> a -> a\n\ninstance SubsARef H.Pred where\n subsAR p (ARef yts (Known _ pr)) = go \n where \n go (H.Var k xs) \n | k == p = substs pr (zipWith (\\(y,_) x -> (y, x)) yts xs) \n go (H.PAnd ps ) = H.PAnd (go <$> ps)\n go pred = pred\n\ninstance SubsARef Reft where\n subsAR p ar (Known v pr) = Known v (subsAR p ar pr)\n subsAR p ar r = r \n\ninstance SubsARef RType where\n subsAR p ar t = subsAR p ar <$> t\n\nrsubsts :: (SubsARef a) => [(RVar, RARef)] -> a -> a\nrsubsts rps z = L.foldl' (\\x (p, ar) -> rsubst1 p ar x) z rps \n\nrsubst1 :: (SubsARef a) => RVar -> RARef -> a -> a\nrsubst1 (RVar p _) ar z = subsAR p ar z\n\n\n" }, { "path": "src/Language/Sprite/L6.hs", "content": "module Language.Sprite.L6 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.L6.Check\nimport Language.Sprite.L6.Parse\nimport Language.Sprite.Common\n\n--------------------------------------------------------------------------------\nsprite :: FilePath -> IO ()\n--------------------------------------------------------------------------------\nsprite f = do\n src <- parseFile f\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValid f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "src/Language/Sprite/L8/Check.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Use uncurry\" #-}\n{-# HLINT ignore \"Eta reduce\" #-}\n\nmodule Language.Sprite.L8.Check (vcgen) where\n\nimport Data.Maybe (isJust)\nimport Control.Monad (void)\nimport Control.Monad.Except (throwError, catchError)\nimport qualified Data.HashMap.Strict as M\nimport Text.PrettyPrint.HughesPJ (Doc, (<+>), text )\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Horn.Transformations as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common\nimport Language.Sprite.L8.Types\nimport Language.Sprite.L8.Reflect\nimport Language.Sprite.L8.Prims ( bTrue, constTy )\nimport Language.Sprite.L8.Constraints\nimport Language.Sprite.L8.Elaborate ( elaborate )\n-- import Debug.Trace (trace)\n\n-------------------------------------------------------------------------------\nvcgen:: SrcProg -> Either [UX.UserError] SrcQuery\n-------------------------------------------------------------------------------\nvcgen (Prog qs ms e typs) = do\n let env = empEnv ms typs\n let eL = elaborate env e\n let ps = [(pappSym n, pappSort n) | n <- [1..3]]\n let pqs = pappQual <$> [1..3]\n (cI, _) <- run (H.CAnd <$> mapM (checkData env) typs)\n (c,cgi) <- run (check env eL (bTrue TInt))\n let rfls = cgiConsts cgi\n let syms = M.fromList (ps ++ ms ++ rfls)\n let c' = strengthenInv env c\n let decs = reflectData <$> {- Misc.traceShow \"data-typs\" -} typs\n return $ mkQuery (qs ++ pqs) (cgiKVars cgi) (H.flatten (cAnd cI c')) syms (cgiDefs cgi) decs\n\n\nmkQuery :: [F.Qualifier]\n -> [H.Var a]\n -> H.Cstr a\n -> M.HashMap F.Symbol F.Sort\n -> [F.Equation]\n -> [F.DataDecl]\n -> H.Query a\nmkQuery qs ks c syms defs ddecls = H.Query\n { H.qQuals = qs\n , H.qVars = ks\n , H.qCstr = c\n , H.qCon = syms\n , H.qDis = mempty\n , H.qEqns = defs\n , H.qMats = mempty\n , H.qData = ddecls\n , H.qOpts = []\n }\n\n-------------------------------------------------------------------------------\n-- | Add Inv assumptions for all data-type binders in SrcCstr\n-------------------------------------------------------------------------------\nsimplCstr :: SrcCstr -> SrcCstr\nsimplCstr = go\n where\n go (H.CAnd cs) = H.CAnd (go <$> cs)\n go (H.All b c) = H.All (goB b) (go c)\n go c = c\n goB (H.Bind x t p z) = H.Bind x t p z\n\nstrengthenInv :: Env -> SrcCstr -> SrcCstr\nstrengthenInv g = go\n where\n go (H.CAnd cs) = H.CAnd (go <$> cs)\n go (H.All b c) = H.All (strengthenBind g b) (go c)\n go c = c\n\nstrengthenBind :: Env -> H.Bind a -> H.Bind a\nstrengthenBind g b@(H.Bind x t p z) = case getInv g x t of\n Nothing -> b\n Just p' -> H.Bind x t (p <> p') z\n\n\n-------------------------------------------------------------------------------\nsub :: F.SrcSpan -> RType -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\nsub l s t = sub' l s t `catchError` (\\es -> throwError (UX.mkError msg l : es))\n where\n msg = text $ \"Invalid Subtyping: \" ++ show (s, t)\n\n{- | [Sub-Base]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <= b{w:q}\n -}\n\nsub' :: F.SrcSpan -> RType -> RType -> CG SrcCstr\nsub' l s@(TBase b1 (Known v _)) (TBase b2 (Known w q))\n | b1 == b2 = return (cAll l v s (cHead l (subst q w v)))\n | otherwise = failWith (\"Invalid Subtyping: \" <+> F.pprint (b1, b2)) l\n\n{- | [Sub-Fun]\n\n (v::t) => q[w := v]\n -------------------\n b{v:p} <: b{w:q}\n\n s2 <: s1 x2:s2 |- t1[x1:=x2] <: t2\n -------------------------------------\n x1:s1 -> t1 <: x2:s2 -> t2\n\n -}\nsub' l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n cI <- sub l s2 s1\n cO <- cAll l x2 s2 <$> sub l t1' t2\n return (cAnd cI cO)\n where\n t1' = subst t1 x1 x2\n\n{- | [Sub-TCon]\n\n G,v:int{p} |- q[w:=v] G |- si <: ti\n -----------------------------------------\n G |- (C s1...)[v|p] <: (C t1...)[w|q]\n\n -}\n\nsub' l s@(TCon c1 t1s p1s (Known v _)) (TCon c2 t2s p2s (Known w q)) | c1 == c2 = do\n let cTop = cAll l v s (cHead l (subst q w v))\n cIns <- subs l t1s t2s\n cARefs <- subPs l p1s p2s\n return (cAnd cTop (cAnd cIns cARefs))\n\nsub' l t1 t2 = failWith (\"sub: cannot handle:\" <+> UX.tshow (t1, t2)) l\n\nsubs :: F.SrcSpan -> [RType] -> [RType] -> CG SrcCstr\nsubs _ [] [] = return cTrue\nsubs l (t1:t1s) (t2:t2s) = cAnd <$> sub l t1 t2 <*> subs l t1s t2s\nsubs l _ _ = failWith \"subs: invalid args\" l\n\nsubPs :: F.SrcSpan -> [RARef] -> [RARef] -> CG SrcCstr\nsubPs l (p1:p1s) (p2:p2s) = cAnd (subP l p1 p2) <$> subPs l p1s p2s\nsubPs l [] [] = pure cTrue\nsubPs l _ _ = error \"subPs: mismatch\"\n\n\n{- | [Sub-ARef]\n\n G; x1:t... |- p1 => p2[x2 := x1]\n ---------------------------------\n G |- \\x1:t. p1 <: \\x2:t. p2\n\n -}\n\nsubP :: F.SrcSpan -> RARef -> RARef -> SrcCstr\nsubP l (ARef xts1 (Known _ p1)) (ARef xts2 (Known _ p2))\n = cImpl l xts1 p1 (substs p2 su)\n where\n su = Misc.safeZip \"subP\" (fst <$> xts2) (fst <$> xts1)\n\n-------------------------------------------------------------------------------\n-- | Checking Invariants\n-------------------------------------------------------------------------------\ncheckData :: Env -> SrcData -> CG SrcCstr\ncheckData g d = H.CAnd <$> mapM (checkCtor g (dcInv d)) (dcCtors d)\n\ncheckCtor :: Env -> Reft -> (SrcBind, RType) -> CG SrcCstr\ncheckCtor g inv (dc, t) = checkInv (label dc) g inv t\n\ncheckInv :: F.SrcSpan -> Env -> Reft -> RType -> CG SrcCstr\ncheckInv l g inv = go\n where\n go (TFun x s t) = cAll l x s' <$> go t where s' = getInv' g s\n go (TAll a t) = go t\n go (TRAll r t) = cAllF l kf kt <$> go t where (kf, kt) = predBind r\n go t = sub l t t' where t' = tTrue t `strengthenTop` inv\n\ntTrue :: RType -> RType\ntTrue = go\n where\n go (TBase b _) = TBase b mempty\n go (TFun b s t) = TFun b (go s) (go t)\n go (TCon c ts ps _) = TCon c (go <$> ts) (goP <$> ps) mempty\n go (TAll a t) = TAll a (go t)\n go (TRAll a t) = TRAll a (go t)\n goP (ARef xts _) = ARef xts mempty\n\n-------------------------------------------------------------------------------\n-- | 'Checking' constraints\n-------------------------------------------------------------------------------\ncheck :: Env -> SrcExpr -> RType -> CG SrcCstr\n-------------------------------------------------------------------------------\n{- [Chk-Lam]\n\n G, x:s[y:=x] |- e <== t[y:=x]\n -----------------------------\n G |- \\x.e <== y:s -> t\n\n -}\ncheck g (EFun bx e l) (TFun y s t) = do\n c <- check (extEnv g x s') e t'\n return $ cAll l x s c\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n\n{- [Chk-Let]\n\n G |- e ==> s G, x:s |- e' <== t'\n -------------------------------------------\n G |- let x = e in e' <== t'\n\n-}\ncheck g (ELet (Let (Bind x l) e _) e' _) t' = do\n (c, s) <- synth g e\n c' <- check (extEnv g x s) e' t'\n return $ cAnd c (cAll l x s c')\n\n{- [Chk-Refl]\n\n t := fresh(G, s) == forall a*. (y:s)* -> tb e == \\a*.\\y*. eb\n G' = G,a*,(y:s)*, x:lim(G, m, t) |- eb <== tb G, x:reflect(e,t) |- e' <= t'\n ^^^^^^^^^^^^\n -------------------------------------------------------------------------------\n G |- def x = e:s/m in e' <= t'\n\n -}\n\n{- [Chk-Rec]\n\n t := fresh(G, s) == forall a*. (y:s)* -> tb e == \\a*.\\y*. eb\n G' = G,a*,(y:s)*, x:lim(G, m, t) |- eb <== tb G, x:t |- e' <= t'\n -------------------------------------------------------------------\n G |- let rec x = (e : s / m) in e' <= t'\n\n -}\ncheck g (ELet (Rec (Bind x l) (EAnn e ann (_, s, mMb) _) sp) e' _) t' = do\n m <- fromMaybeM l \"Missing termination metric!\" mMb\n let (s', m') = renameTy e s m\n t <- fresh l g s'\n let (bs, tb, eb) = introEnv t e\n let g' = foldr (\\(x, s) g -> extEnv g x s) g bs\n let tlim = limit sp g m' t\n c <- check (extEnv g' x tlim) eb tb\n tx <- case ann of\n Val -> pure t\n Refl -> reflect x e t\n c' <- check (extEnv g x tx) e' t'\n return $ cAnd (cAlls l bs c) c'\n\n{- [Chk-If]\n G |- v <== bool\n G, _:{v} |- e1 <== t\n G, _:{not v} |- e2 <== t\n ----------------------------- [Chk-If]\n G |- if v e1 e2 <== t\n -}\ncheck g (EIf v e1 e2 l) t = do\n _ <- check g (EImm v l) rBool\n c1 <- cAll l xv tT <$> check g e1 t\n c2 <- cAll l xv tF <$> check g e2 t\n return (cAnd c1 c2)\n where\n tT = predRType pv\n tF = predRType (F.PNot pv)\n pv = immExpr v\n xv = grdSym g\n\n{- [Chk-Switch]\n\n G | y |- a_i <== t\n ---------------------------\n G |- switch y {a_1...} <== t\n-}\n\ncheck g (ECase y alts _) t = do\n H.CAnd <$> mapM (checkAlt g y t) alts\n\n\n{- [Chk-TLam]\n\n G, a |- e <== t\n ------------------------ [Chk-TLam]\n G |- Λ a. e <== all a. t\n-}\ncheck g (ETLam a e _) (TAll b t) | a == b = do\n check g e t\n\n{- [Chk-RAbs]\n\n ρ = κ:t -> Bool s' = s[κ := fκ] G; fκ : t → Bool ⊢ e <== s'\n ----------------------------------------------------------------[Chk-RAbs]\n G |- e <== all ρ. s\n\n-}\ncheck g e (TRAll r s) = do\n c <- check g' e s'\n return (cAllF l kf kt c)\n where\n l = label e\n g' = extEnv g kf kt\n s' = hvarPred kf <$> s\n (kf, kt) = predBind r\n\n{- [Chk-Syn]\n\n G |- e ==> s G |- s <: t\n ----------------------------------[Chk-Syn]\n G |- e <== t\n\n-}\ncheck g e t = do\n let l = label e\n (c, s) <- synth g e\n c' <- sub l s t\n return (cAnd c c')\n\n{- [Chk-Syn-Imm] -}\ncheckImm :: Env -> SrcImm -> RType -> CG SrcCstr\ncheckImm g i t = do\n s <- synthImm g i\n sub (label i) s t\n\n\n\n{- [Chk-Alt]\n\n unfold(G, c, y) === s G | y + z... * s ~~> G' G' |- e <== t\n ---------------------------------------------------------------\n G | y |- C z... -> e <== t\n\n-}\ncheckAlt :: Env -> Ident -> RType -> SrcAlt -> CG SrcCstr\ncheckAlt g y t (Alt c zs e l) = do\n let al = mconcat (label <$> zs)\n case unfoldEnv g y c zs of\n Nothing -> failWith \"checkAlt: incompatible pattern\" al\n Just zts -> cAlls l zts <$> check (extEnvs g zts) e t\n\ncAlls :: F.SrcSpan -> [(F.Symbol, RType)] -> SrcCstr -> SrcCstr\ncAlls l xts c = foldr (\\(x, t) -> cAll l x t) c (reverse xts)\n\nfromMaybeM :: F.SrcSpan -> Doc -> Maybe a -> CG a\nfromMaybeM l msg (Just x) = pure x\nfromMaybeM l msg Nothing = failWith msg l\n\n--------------------------------------------------------------------\n-- | 'Synthesis' constraints\n--------------------------------------------------------------------\nsingleton :: F.Symbol -> RType -> RType\nsingleton x (TBase b (Known v p)) = TBase b (Known v (pAnd [p, v `peq` x]))\nsingleton x (TCon c ts ps (Known v p)) = TCon c ts ps (Known v (pAnd [p, v `peq` x]))\nsingleton _ t = t\n\npeq :: (F.Expression a, F.Expression b) => a -> b -> H.Pred\npeq x y = H.Reft (F.PAtom F.Eq (F.expr x) (F.expr y))\n\nsynthImm :: Env -> SrcImm -> CG RType\n{- [Syn-Var]\n\n -----------------\n G |- x ==> G(x)\n\n-}\nsynthImm g (EVar x l)\n | Just t <- getEnv g x = return (singleton x t)\n | otherwise = failWith (\"Unbound variable:\" <+> F.pprint x) l\n\n{- [Syn-Con]\n\n -----------------\n G |- x ==> ty(c)\n\n -}\nsynthImm _ (ECon c l) = return (constTy l c)\n\nsynth :: Env -> SrcExpr -> CG (SrcCstr, RType)\n{- [Syn-Con], [Syn-Var] -}\nsynth g (EImm i _) = do\n t <- synthImm g i\n return (cTrue, t)\n\n{- [Syn-Ann]\n\n G |- e <== t t := fresh(s)\n ---------------------------\n G |- e:s => t\n\n-}\nsynth g (EAnn e a (_,s,_) l) = do\n t <- fresh l g s\n c <- check g e t\n return (c, t)\n\n\n{- [Syn-App]\n\n G |- e ==> x:s -> t\n G |- y <== s\n -----------------------\n G |- e y ==> t[x := y]\n\n-}\nsynth g (EApp e y l) = do\n (ce, te) <- synth g e\n case te of\n TFun x s t -> do cy <- checkImm g y s\n return (cAnd ce cy, substImm t x y)\n _ -> failWith \"Application to non-function\" l\n\n\n{- [Syn-TApp]\n\n G |- e ==> all a. s\n ---------------------------\n G |- e[t] ==> s [ a := t]\n\n-}\nsynth g (ETApp e t l) = do\n (ce, te) <- synth g e\n case te of\n TAll a s -> do tt <- {- Misc.traceShow \"REFRESH\" <$> -} refresh l g t\n return (ce, {- Misc.traceShow \"SYN-TApp: \" $ -} tsubst a tt s)\n _ -> failWith \"Type Application to non-forall\" l\n\n{- [Syn-RApp]\n\n G |- e => forall r.s r = K:t... -> bool p = fresh(G, t...-> bool)\n ----------------------------------------------------------------------\n G |- e[?] => s [ r := p ]\n -}\n\nsynth g (ERApp e l) = do\n (c, s) <- synth g e\n s' <- Misc.traceShow (\"SYN-RApp: \" ++ show (void e, void s)) <$> rinst l s\n return (c, s')\n\nsynth _ e =\n failWith (\"synth: cannot handle: \" <+> text (show (void e))) (label e)\n\n-------------------------------------------------------------------------------\n-- | Fresh templates for `Unknown` refinements\n-------------------------------------------------------------------------------\nrefresh :: F.SrcSpan -> Env -> RType -> CG RType\nrefresh l g = fresh l g . go\n where\n go (TBase b _) = TBase b Unknown\n go (TFun b s t) = TFun b (go s) (go t)\n go (TCon c ts ps _) = TCon c (go <$> ts) ps Unknown\n go (TAll a t) = TAll a (go t)\n\nfresh :: F.SrcSpan -> Env -> RType -> CG RType\nfresh l g t@(TBase b r) = TBase b <$> freshR l g (rTypeSort t) r\nfresh l g (TFun b s t) = TFun b <$> fresh l g s <*> fresh l (extEnv g b s) t\nfresh l g t@(TCon c ts ps r) = TCon c <$> mapM (fresh l g) ts <*> pure ps <*> freshR l g (rTypeSort t) r\nfresh l g (TAll a t) = TAll a <$> fresh l g t\nfresh l g (TRAll r t) = TRAll r <$> fresh l g t\n\nfreshR :: F.SrcSpan -> Env -> F.Sort -> Reft -> CG Reft\nfreshR _ _ _ r@(Known {}) = pure r\nfreshR l g t Unknown = freshK l g t\n\n\nrinst :: F.SrcSpan -> RType -> CG RType\nrinst l (TRAll (RVar p ts) s) = do\n ar <- freshKVarReft l ts\n return (subsAR p ar s)\nrinst _ s =\n return s\n\nfreshKVarReft :: F.SrcSpan -> [RSort] -> CG RARef\nfreshKVarReft l ts = do\n k <- freshKVar l (rSortToFSort <$> ts)\n return $ rVarARef (RVar k ts)\n\n\n---------------------------------------------------------------------------------\n-- | Termination: Limiting a Type with a Metric ---------------------------------\n---------------------------------------------------------------------------------\nlimit :: F.SrcSpan -> Env -> Metric -> RType -> RType\nlimit sp g m t = lim sp g m m t\n\nlim :: F.SrcSpan -> Env -> Metric -> Metric -> RType -> RType\nlim sp g mO m (TFun x s t)\n | isBase s && wfMetric sp (extEnv g x s) mO\n = TFun x' s' t'\n where\n s' = subst s x x' `strengthenTop` Known x' (H.Reft (wfr mO m'))\n m' = subst m x x'\n t' = subst t x x'\n x' = F.suffixSymbol x \"next\"\n\nlim sp g mO m (TFun x s t)\n = TFun x' s' t''\n where\n t'' = lim sp (extEnv g x s) mO m' t'\n m' = subst m x x'\n s' = subst s x x'\n t' = subst t x x'\n x' = F.suffixSymbol x \"next\"\n\nlim sp g mO m (TAll a t)\n = TAll a (lim sp g mO m t)\n\nlim sp g mO m (TRAll a t)\n = TRAll a (lim sp g mO m t)\n\nlim sp g mO _ t\n = error $ \"Malformed Metric\" ++ show (envSorts g, mO, t)\n\n-- Well-foundedness Refinement --------------------------------------------------\nwfr :: Metric -> Metric -> F.Expr\nwfr [pO] [p] = F.pAnd [nat p, p `lt` pO ]\nwfr (pO:mO) (p:m) = F.pAnd [nat p, F.pOr [ p `lt` pO, r ]]\n where\n r = F.pAnd [p `eq` pO, wfr mO m ]\n\n\n-- | Replaces the types in a signature with those in the function definition\nrenameTy :: SrcExpr -> RType -> Metric -> (RType, Metric)\nrenameTy (ETLam _ e _) (TAll a t) m = (TAll a t', m')\n where\n (t', m') = renameTy e t m\nrenameTy (EFun bx e l) (TFun y s t) m = (TFun x s' t'', m')\n where\n x = bindId bx\n s' = subst s y x\n t' = subst t y x\n (t'', m') = renameTy e t' m\nrenameTy _ t m = (t, m)\n\n-- | Assumes that the binders in `RType` and `SrcExpr` have been unified\nintroEnv :: RType -> SrcExpr -> ([(F.Symbol, RType)] , RType, SrcExpr)\nintroEnv = go []\n where\n go bs (TFun x s t) (EFun _ e l) = go ((x, s) : bs) t e\n go bs tb eb = (reverse bs, tb, eb)\n\n-- | Abstract Refinement Substitutions (sec 7.2.1) ------------------------------------\n\n{-\nrinst :: F.SrcSpan -> RType -> CG RType\nrinst l (TRAll (RVar p ts) s) = do\n s' <- rinst l s\n k <- freshKVar l (rSortToFSort <$> ts)\n return (substKVar p k <$> s')\nrinst _ s =\n return s\n\n\n-- | @substK f k@ replaces all occurences of `H.Var f xs` with `H.Var k xs`\nsubstKVar :: F.Symbol -> F.Symbol -> Reft -> Reft\nsubstKVar _ _ Unknown = Unknown\nsubstKVar f k (Known v p) = Known v (go p)\n where\n go pred = case pred of\n H.Var g xs | f == g -> H.Var k xs\n H.PAnd preds -> H.PAnd (go <$> preds)\n _ -> pred\n-}\n\n-- | @hvarPred f r@ converts all occurrences of `H.Var f xs` in `r` to `H.Reft (EApp f xs)`\nhvarPred :: F.Symbol -> Reft -> Reft\nhvarPred _ Unknown = Unknown\nhvarPred f (Known v p) = Known v (go p)\n where\n go (H.Var g xs)\n | f == g = H.Reft (predApp f xs)\n go (H.PAnd ps) = H.PAnd (go <$> ps)\n go r = r\n\npredBind :: RVar -> (F.Symbol, RType)\npredBind (RVar p ts) = (p, TCon (tc \"Pred\") (rSortToRType <$> ts) mempty mempty)" }, { "path": "src/Language/Sprite/L8/Constraints.hs", "content": "-- | This module has the kit needed to do constraint generation:\n-- namely, @Env@ironments, @SrcCstr@ manipulation, and @subst@itution.\n\n{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n{-# HLINT ignore \"Eta reduce\" #-}\n\nmodule Language.Sprite.L8.Constraints\n ( -- * Constraints\n cTrue, cAnd, cHead, cAll, cAllF, cImpl, pAnd\n\n -- * Substitutions\n , subst, substImm\n\n -- * Conversions\n , predRType, rTypeSort\n\n -- * Environments\n , Env, empEnv, getEnv, extEnv, extEnvs\n , extEnvTV, grdSym, envSorts\n , getInv, getInv'\n\n -- * Case-Related manipulation\n , unfoldEnv, unfoldEnv'\n\n -- * Constraint Generation Monad\n , CG, run, failWith, freshK, freshKVar, freshValueSym\n , addReflectVar\n , CGInfo (..)\n\n -- * well-formedness\n , wfMetric\n ) where\n\nimport qualified Data.List as L\nimport qualified Data.Maybe as Mb\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.SortCheck as F\nimport qualified Language.Sprite.Common.UX as UX\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common ( SrcCstr, SrcHVar, bind )\nimport Language.Sprite.L8.Types\nimport Language.Sprite.L8.Prims ( prelude )\nimport qualified Data.HashMap.Internal.Strict as M\n\n--------------------------------------------------------------------------------\n-- | Constraints ---------------------------------------------------------------\n--------------------------------------------------------------------------------\ncTrue :: SrcCstr\ncTrue = H.CAnd []\n\ncAnd :: SrcCstr -> SrcCstr -> SrcCstr\ncAnd (H.CAnd []) c = c\ncAnd c (H.CAnd []) = c\ncAnd c1 c2 = H.CAnd [c1, c2]\n\ncHead :: F.SrcSpan -> H.Pred -> SrcCstr\ncHead _ (H.Reft p)\n | F.isTautoPred p = cTrue\ncHead l (H.PAnd ps) = case filter (not . pTrivial) ps of\n [] -> cTrue\n [p] -> mkHead l p\n qs -> mkHead l (H.PAnd qs)\ncHead l p = mkHead l p\n\n{-@ ListNE a = {v:_ | len v > 0} @-}\ntype ListNE a = [a]\n\ncImpl :: F.SrcSpan -> ListNE (F.Symbol, RSort) -> H.Pred -> H.Pred -> SrcCstr\ncImpl l xts p1 p2 = go [ (x, rSortToFSort t) | (x, t) <- xts]\n where\n go [(x,t)] = H.All (bind l x t p1) (cHead l p2)\n go ((x,t):xts) = H.All (bind l x t mempty) (go xts)\n\n\nmkHead :: F.SrcSpan -> H.Pred -> SrcCstr\nmkHead l p = case smash p of\n [] -> cTrue\n [q] -> mk1 l q\n qs -> H.CAnd (mk1 l <$> qs)\n\nmk1 :: F.SrcSpan -> H.Pred -> SrcCstr\nmk1 l p = H.Head p (UX.mkError \"Subtype error\" l)\n\nsmash :: H.Pred -> [H.Pred]\nsmash (H.PAnd ps) = concatMap smash ps\nsmash p = [p]\n\ncAll :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAll sp x t c = case sortPred x t of\n Just (so, p) -> H.All (bind sp x so p) c\n _ -> c\n\n-- | @cAllF@ is a variant of @cAll@ used when the binder is a function, e.g. in [Chk-RAbs]\ncAllF :: F.SrcSpan -> F.Symbol -> RType -> SrcCstr -> SrcCstr\ncAllF sp f t c = H.All (bind sp f (rTypeSort t) mempty) c\n\npAnd :: [H.Pred] -> H.Pred\npAnd ps = case filter (not . pTrivial) ps of\n [p] -> p\n ps' -> H.PAnd ps'\n\npTrivial :: H.Pred -> Bool\npTrivial (H.PAnd []) = True\npTrivial (H.Reft p) = F.isTautoPred p\npTrivial _ = False\n\nsortPred :: F.Symbol -> RType -> Maybe (F.Sort, H.Pred)\nsortPred x t@(TBase _ (Known v p)) = Just (rTypeSort t, subst p v x)\nsortPred x t@(TCon _ _ _ (Known v p)) = Just (rTypeSort t, subst p v x)\nsortPred _ _ = Nothing\n\n--------------------------------------------------------------------------------\n-- | Environments --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\ndata Env = Env\n { eBinds :: !(F.SEnv RType) -- ^ value binders\n , eSize :: !Integer -- ^ number of binders?\n , eTVars :: !(F.SEnv ()) -- ^ type variables\n , eSorts :: !(F.SEnv F.Sort) -- ^ sort-environment (for WF checks)\n , eInv :: !(F.SEnv Reft) -- ^ (partial) map from tycon to invariant\n }\n\ninstance Show Env where\n show = show . F.toListSEnv . eBinds\n\nextEnv :: Env -> F.Symbol -> RType -> Env\nextEnv env x t\n | x == junkSymbol = env\n | otherwise = env { eBinds = F.insertSEnv x t (eBinds env)\n , eSize = 1 + eSize env\n , eSorts = F.insertSEnv x (rTypeSort t) (eSorts env)\n }\n\nextEnvs :: Env -> [(F.Symbol, RType)] -> Env\nextEnvs = L.foldl' (\\g (x, t) -> extEnv g x t)\n\nextEnvTV :: Env -> TVar -> Env\nextEnvTV env (TV a) = env { eTVars = F.insertSEnv a () (eTVars env) }\n\ngrdSym :: Env -> F.Symbol\ngrdSym env = F.tempSymbol \"grd\" (eSize env)\n\npredRType :: F.Pred -> RType\npredRType p = TBase TBool (known $ F.predReft p)\n\ngetEnv :: Env -> F.Symbol -> Maybe RType\ngetEnv env x = F.lookupSEnv x (eBinds env)\n\ngetInv :: Env -> F.Symbol -> F.Sort -> Maybe H.Pred\ngetInv env x t = case F.unFApp t of\n F.FTC tc : _ -> case F.lookupSEnv (F.symbol tc) (eInv env) of\n Just (Known v p) -> Just (subst p v x)\n _ -> Nothing\n _ -> Nothing\n\ngetInv' :: Env -> RType -> RType\ngetInv' env t@(TCon c _ _ _) = case F.lookupSEnv (F.symbol c) (eInv env) of\n Nothing -> t\n Just r -> strengthenTop t r\ngetInv' _ t = t\n\nempEnv :: [(F.Symbol, F.Sort)] -> [SrcData] -> Env\nempEnv ms typs = foldr (\\(x, t) g -> extEnv g x t) env0 prelSigs\n where\n env0 = Env mempty 0 mempty (F.fromListSEnv ms) (tcInvs typs)\n prelSigs = prelude ++ concatMap dataSigs typs\n\ntcInvs :: [SrcData] -> F.SEnv Reft\ntcInvs tcs = F.fromListSEnv\n [ (F.symbol (dcName d), inv) | d <- tcs, let inv@(Known v p) = dcInv d, p /= mempty ]\n\ndataSigs :: SrcData -> [(F.Symbol, RType)]\ndataSigs dc = [(F.symbol b, t) | (b, t) <- dcCtors dc]\n\nenvSorts :: Env -> [(F.Symbol, F.Sort)]\nenvSorts env = [ (x, t) | (x, s) <- F.toListSEnv (eBinds env)\n , (t, _) <- Mb.maybeToList (sortPred x s) ]\n\n--------------------------------------------------------------------------------\n-- | Well-formedness ------------------------------------------------------------\n--------------------------------------------------------------------------------\nwfExpr :: F.SrcSpan -> Env -> F.Expr -> F.Sort -> Bool\nwfExpr sp g e t = F.checkSortExpr sp (eSorts g) e == Just t\n\nwfMetric :: F.SrcSpan -> Env -> Metric -> Bool\nwfMetric sp g m = all (\\e -> wfExpr sp g e F.FInt) m\n\n--------------------------------------------------------------------------------\n-- | Case-Related Environment Manipulation -------------------------------------\n--------------------------------------------------------------------------------\nunfoldEnv' :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe Env\nunfoldEnv' g y c zs = extEnvs g <$> unfoldEnv g y c zs\n\nunfoldEnv :: Env -> Ident -> DaCon -> [SrcBind] -> Maybe [(F.Symbol, RType)]\nunfoldEnv g y c zs = unfold g c y >>= extCase y zs\n\nunfold:: Env -> DaCon -> Ident -> Maybe (RType, RType)\nunfold g c y = do\n (as, ps, t) <- bkAlls <$> getEnv g c\n ty@(TCon _ ts rs _) <- getEnv g y\n prs <- Misc.safeZip ps rs\n ats <- Misc.safeZip as ts\n return (ty, rsubsts prs . tsubsts ats $ t)\n\nextCase :: Ident -> [SrcBind] -> (RType, RType) -> Maybe [(F.Symbol, RType)]\nextCase y zs (ty, t) = go [] (F.symbol <$> zs) t\n where\n go acc (z:zs) (TFun x s t) = go ((z, s) : acc) zs (subst t x z)\n go acc [] t = Just ((y, meet ty t) : acc)\n go _ _ _ = Nothing\n\nmeet :: RType -> RType -> RType\nmeet t1 t2 = case rTypeReft t2 of\n Just r2 -> strengthenTop t1 r2\n Nothing -> t1\n\n\n\n-------------------------------------------------------------------------------\n-- | CG Monad -----------------------------------------------------------------\n-------------------------------------------------------------------------------\n\ntype CG a = StateT CGState (Either [UX.UserError]) a\n\ndata CGState = CGState\n { cgCount :: !Integer -- ^ monotonic counter, to get fresh things\n , cgInfo :: !CGInfo -- ^ extra bits needed for constraints\n }\n\ndata CGInfo = CGInfo\n { cgiKVars :: [SrcHVar]\n , cgiConsts :: [(F.Symbol, F.Sort)]\n , cgiDefs :: [F.Equation]\n }\n\ns0 :: CGState\ns0 = CGState 0 (CGInfo [] [] [])\n\nrun :: CG a -> Either [UX.UserError] (a, CGInfo)\nrun act = do\n (x, s) <- runStateT act s0\n return (x, cgInfo s)\n\nfailWith :: UX.Text -> F.SrcSpan -> CG a\nfailWith msg l = throwError [UX.mkError msg l]\n\nfreshK :: F.SrcSpan -> Env -> F.Sort -> CG Reft\nfreshK l g t = do\n v <- freshValueSym\n k <- freshKVar l (t:ts)\n return $ Known v (H.Var k (v:xs))\n where\n -- t = baseSort b\n (xs,ts) = unzip (envSorts g)\n\nfreshKVar :: F.SrcSpan -> [F.Sort] -> CG F.Symbol\nfreshKVar l ts = do\n k <- F.kv . F.intKvar <$> freshInt\n _ <- addSrcKVar (H.HVar k ts (UX.mkError \"fake\" l))\n return k\n\naddSrcKVar :: SrcHVar -> CG ()\naddSrcKVar k = modify $ \\s ->\n let cgi = cgInfo s\n kvs = cgiKVars cgi\n in\n s { cgInfo = cgi { cgiKVars = k : kvs } }\n\nfreshValueSym :: CG F.Symbol\nfreshValueSym = F.vv . Just <$> freshInt\n\nfreshInt :: CG Integer\nfreshInt = do\n s <- get\n let n = cgCount s\n put s { cgCount = 1 + n}\n return n\n\naddReflectVar :: Ident -> RType -> [(F.Symbol, F.Sort)] -> F.Sort -> F.Expr -> CG ()\naddReflectVar f t xts ot e = modify $ \\s ->\n let cgi = cgInfo s\n fDef = {- Misc.traceShow \"mkEquation\" $ -} F.mkEquation f xts e ot\n in\n s { cgInfo = cgi { cgiConsts = (f, rTypeSort t) : cgiConsts cgi\n , cgiDefs = fDef : cgiDefs cgi\n }\n }\n" }, { "path": "src/Language/Sprite/L8/Elaborate.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n\nmodule Language.Sprite.L8.Elaborate (elaborate) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.List as L\nimport Control.Exception (throw)\nimport Control.Monad.State\nimport Control.Monad.Except (throwError)\nimport Text.PrettyPrint.HughesPJ\n-- import Text.Printf (printf)\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.Common\nimport qualified Language.Sprite.Common.Misc as Misc\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.L8.Prims\nimport Language.Sprite.L8.Types\nimport Language.Sprite.L8.Constraints\nimport Debug.Trace (trace)\nimport Control.Monad (void)\n\n-------------------------------------------------------------------------------\nelaborate :: Env -> SrcExpr -> ElbExpr\n-------------------------------------------------------------------------------\nelaborate g e = {- trace _msg -} e''\n where\n _msg = \"elaborate: \" ++ show (F.toListSEnv su, void e, void e'')\n e'' = subsTy su e'\n (su, e') = runElabM act\n act = elabC g e (bTrue TInt)\n\nrunElabM :: ElabM a -> (TvSub, a)\nrunElabM act = case runStateT act s0 of\n Left errs -> throw errs\n Right (v, s) -> (eSub s, v)\n where s0 = ElabS mempty 0\n\ntype TvSub = F.SEnv RType\ndata ElabS = ElabS { eSub :: !TvSub, eNum :: !Int }\ntype ElabM a = StateT ElabS (Either [UX.UserError]) a\n\nunifyV :: F.SrcSpan -> TVar -> RType -> ElabM RType\nunifyV _ a t@(TBase (TVar b) r)\n | a == b\n = return t\n | nonRigid a\n = assign a t >> return t\n | nonRigid b\n = assign b t' >> return t' where t' = TBase (TVar a) r\n\nunifyV l a t\n | a `elem` freeTVars t\n = occurError l a t\n | nonRigid a\n = assign a t >> return t\n | otherwise\n = rigidError l a t\n\nunify :: F.SrcSpan -> RType -> RType -> ElabM RType\nunify l (TBase (TVar a) _) t =\n unifyV l a t\nunify l t (TBase (TVar a) _) =\n unifyV l a t\nunify _ t1@(TBase b1 _) (TBase b2 _) | b1 == b2 =\n return t1\nunify l (TFun x1 s1 t1) (TFun x2 s2 t2) = do\n x <- pure (unifyX l x1 x2)\n s <- unify l s1 s2\n t1' <- subsTyM t1\n t2' <- subsTyM t2\n t <- unify l t1' t2'\n return (TFun x s t)\nunify l (TCon c1 t1s _ _) (TCon c2 t2s _ _) | c1 == c2 = do\n ts <- unifys l t1s t2s\n return (TCon c1 ts mempty mempty)\n\nunify l t1 t2 =\n unifyError l t1 t2\n\nunifys :: F.SrcSpan -> [RType] -> [RType] -> ElabM [RType]\nunifys _ [] [] =\n return []\nunifys l (t1:t1s) (t2:t2s) = do\n t <- unify l t1 t2\n t1s' <- mapM subsTyM t1s\n t2s' <- mapM subsTyM t2s\n ts <- unifys l t1s' t2s'\n return (t:ts)\nunifys l _ _ =\n throwError [UX.mkError \"unifys-mismatched args\" l]\n\n\nunifyX :: F.SrcSpan -> F.Symbol -> F.Symbol -> F.Symbol\nunifyX _ x _ = x\n\nunifyError :: F.SrcSpan -> RType -> RType -> ElabM a\nunifyError l t1 t2 = throwError [UX.mkError msg l]\n where msg = \"type error: cannot unify\" <+> UX.tshow t1 <+> \"and\" <+> UX.tshow t2\n\nrigidError :: F.SrcSpan -> TVar -> RType -> ElabM a\nrigidError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: cannot assign rigid\" <+> UX.tshow a <+> \"the type\" <+> UX.tshow t\n\noccurError :: F.SrcSpan -> TVar -> RType -> ElabM a\noccurError l a t = throwError [UX.mkError msg l]\n where msg = \"type error: occurs check\" <+> UX.tshow a <+> \"occurs in\" <+> UX.tshow t\n\nmatchError :: F.SrcSpan -> Doc -> ElabM a\nmatchError l msg = throwError [UX.mkError (\"case-alt error:\" <+> msg) l]\n\n-------------------------------------------------------------------------------\nelabC :: Env -> SrcExpr -> RType -> ElabM ElbExpr\nelabC g (EFun b e l) (TFun _ s t) = do\n e' <- elabC (extEnv g (bindId b) s) e t\n return $ EFun b e' l\n\n-- let rec x:s = e1 in e2\nelabC g (ELet (Rec (Bind x l) (EAnn e1 a (bx, s1, m) l1) ld) e2 l2) t2 = do\n let g' = extEnv g x s1\n let (as, _, t1) = bkAlls s1\n e1' <- elabC (extEnvTVs g' as) e1 t1\n e2' <- elabC g' e2 t2\n return $ ELet (Rec (Bind x l) (EAnn (mkTLam e1' as) a (bx, s1, m) l1) ld) e2' l2\n\n-- let x = e in e'\nelabC g (ELet (Let (Bind x l) e1 l1) e2 l2) t2 = do\n (e1', s) <- elabS g e1\n e2' <- elabC (extEnv g x s) e2 t2\n return $ ELet (Let (Bind x l) e1' l1) e2' l2\n\n-- if b e1 e2\nelabC g (EIf b e1 e2 l) t = do\n e1' <- elabC g e1 t\n e2' <- elabC g e2 t\n return $ EIf b e1' e2' l\n\n-- switch (y) { | C(z..) => e | ... }\nelabC g (ECase y alts l) t = do\n alts' <- mapM (elabAlt g y t) alts\n return $ ECase y alts' l\n\nelabC g e t = do\n (e', t') <- elabS g e\n unify (label e) t t'\n return e'\n\nelabAlt :: Env -> Ident -> RType -> SrcAlt -> ElabM SrcAlt\nelabAlt g y t (Alt c zs e l) = do\n let al = mconcat (label <$> zs)\n case unfoldEnv' g y c zs of\n Nothing -> matchError al \"bad pattern match\"\n Just g' -> (\\e' -> Alt c zs e' l) <$> elabC g' e t\n\nextEnvTVs :: Env -> [TVar] -> Env\nextEnvTVs = foldr (flip extEnvTV)\n\n-------------------------------------------------------------------------------\nelabS :: Env -> SrcExpr -> ElabM (ElbExpr, RType)\nelabS g e@(EImm i _) = do\n (ts, n, t') <- {- Misc.traceShow (\"elabS: \" ++ show i) <$> -} immS g i\n return (mkTApp e ts n, t')\n\nelabS g (EAnn e a (x, s, m) l) = do\n let (as, _, t) = bkAlls s\n e' <- elabC (extEnvTVs g as) e t\n return (EAnn (mkTLam e' as) a (x, s, m) l, s)\n\nelabS g (EApp e y l) = do\n (e', te) <- elabS g e\n case te of\n TFun _ s t -> do (\\(_,_,yt) -> unify l s ({- Misc.traceShow (\"elabS1 \" ++ show s) -} yt) ) =<< immS g y\n t' <- subsTyM t\n return (EApp e' y l, t')\n _ -> elabErr (\"elabS: Application to non-function; caller type = \" <+> UX.tshow te) l\n\nelabS _ e =\n elabErr (\"elabS unexpected:\" <+> UX.tshow (void e)) (label e)\n\n\n-------------------------------------------------------------------------------\n\nelabErr :: UX.Text -> F.SrcSpan -> ElabM a\nelabErr msg l = throwError [UX.mkError msg l]\n\ninstantiate :: RType -> ElabM ([RType], Int, RType)\ninstantiate = go [] 0\n where\n go ts n (TAll a s) = do v <- fresh\n let vt = TBase (TVar v) mempty\n go (vt:ts) n (tsubst a vt s)\n go ts n (TRAll _ s) = go ts (n+1) s\n go ts n s = return (reverse ts, n, s)\n\nfresh :: ElabM TVar\nfresh = do\n s <- get\n let n = eNum s\n put s { eNum = n + 1 }\n return (nonRigidTV n)\n\nnonRigidTV :: Int -> TVar\nnonRigidTV = TV . F.intSymbol \"fv\"\n\nnonRigid :: TVar -> Bool\nnonRigid (TV a) = F.isPrefixOfSym \"fv\" a\n\nimmS :: Env -> SrcImm -> ElabM ([RType], Int, RType)\nimmS g i = instantiate =<< immTy g i\n where\n immTy :: Env -> SrcImm -> ElabM RType\n immTy g (EVar x l)\n | Just t <- getEnv g x = return t\n | otherwise = elabErr (\"Unbound variable:\" <+> F.pprint x) l\n immTy _ (ECon c l) = return (constTy l c)\n\nmkTLam :: SrcExpr -> [TVar] -> ElbExpr\nmkTLam = foldr (\\a e -> ETLam a e (label e))\n\nmkTApp :: SrcExpr -> [RType] -> Int -> ElbExpr\nmkTApp e ts n = mkRApps n (mkTApps e ts)\n where\n mkRApps 0 e = e\n mkRApps k e = mkRApps (k-1) (ERApp e (label e))\n mkTApps = L.foldl' (\\e t -> ETApp e t (label e))\n\n-- | Type Substitutions --------------------------------------------------------------\n\nclass SubsTy a where\n subsTy :: TvSub -> a -> a\n subsTy1 :: TVar -> RType -> a -> a\n subsTy1 a t x = subsTy (singTvSub a t) x\n\nsingTvSub :: TVar -> RType -> TvSub\nsingTvSub a t = F.fromListSEnv [(F.symbol a, t)]\n\ninstance SubsTy RARef where\n subsTy su (ARef xts p) = ARef xts' p\n where\n xts' = [(x, subsTy su t) | (x, t) <- xts ]\n\ninstance SubsTy RType where\n subsTy su t@(TBase (TVar a) _) = Mb.fromMaybe t t'\n where\n t' = F.lookupSEnv (F.symbol a) su\n\n subsTy _su t@(TBase {}) = t\n\n subsTy su (TCon c ts ps r) = TCon c (subsTy su <$> ts) (subsTy su <$> ps) r\n\n subsTy su (TFun x s t) = TFun x s' t'\n where\n s' = subsTy su s\n t' = subsTy su t\n\n subsTy su (TAll a t) = TAll a t'\n where\n t' = subsTy su' t\n su' = F.deleteSEnv (F.symbol a) su\n\n subsTy su (TRAll p t) = TRAll p' t'\n where\n t' = subsTy su t\n p' = subsTy su p\n\ninstance SubsTy RVar where\n subsTy su (RVar p args) = RVar p (subsTy su <$> args)\n\ninstance SubsTy RSort where\n subsTy su = asRType (subsTy su)\n\ninstance SubsTy TvSub where\n subsTy = F.mapSEnv . subsTy\n\n-- applies the substs to the ETApp types\ninstance SubsTy ElbExpr where\n subsTy = subsTyExpr\n\ninstance SubsTy ElbDecl where\n subsTy su (Let b e l) = Let b (subsTy su e) l\n subsTy su (Rec b e l) = Rec b (subsTy su e) l\n\nsubsTyExpr :: TvSub -> ElbExpr -> ElbExpr\nsubsTyExpr su = go\n where\n go (EFun b e l) = EFun b (go e) l\n go (EApp e i l) = EApp (go e) i l\n go (ELet d e l) = ELet d' (go e) l where d' = subsTy su d\n go (EAnn e a s l) = EAnn (go e) a (goS s) l\n go (EIf i e1 e2 l) = EIf i (go e1) (go e2) l\n go (ETLam a e l) = ETLam a (go e) l\n go (ETApp e t l) = ETApp (go e) (subsTy su t) l\n go (ERApp e l) = ERApp (go e) l\n go (ECase x as l) = ECase x (goA <$> as) l\n go e@(EImm {}) = e\n goS (x, t, m) = (x, subsTy su t, m)\n goA alt = alt { altExpr = go $ altExpr alt }\n\n\n\n\nsubsTyM :: (SubsTy a) => a -> ElabM a\nsubsTyM x = do\n su <- gets eSub\n return (subsTy su x)\n\nassign :: TVar -> RType -> ElabM ()\nassign a t = modify $ \\s -> s { eSub = updSub a t (eSub s)}\n\nupdSub :: TVar -> RType -> TvSub -> TvSub\nupdSub a t su = F.insertSEnv (F.symbol a) t (subsTy1 a t su)\n" }, { "path": "src/Language/Sprite/L8/Parse.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Language.Sprite.L8.Parse\n (\n -- * Parsing programs\n parseFile\n , parseWith\n\n -- * Parsing combinators\n , measureP\n , rtype\n , expr\n , typP\n , switchExpr\n , altP\n ) where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport Control.Monad.Combinators.Expr\nimport Text.Megaparsec hiding (State, label)\nimport Text.Megaparsec.Char\n\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Fixpoint.Parse as FP\nimport qualified Language.Fixpoint.Horn.Types as H\nimport Language.Sprite.Common\nimport qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.Common.Parse\n\nimport Language.Sprite.L8.Types hiding (rVarARef, immExpr)\n-- import Language.Sprite.L8.Constraints\n\nparseFile :: FilePath -> IO SrcProg\nparseFile = FP.parseFromFile prog\n\nparseWith :: FP.Parser a -> FilePath -> String -> a\nparseWith = FP.doParse'\n\n--------------------------------------------------------------------------------\n-- | Top-Level Expression Parser\n--------------------------------------------------------------------------------\nprog :: FP.Parser SrcProg\nprog = do\n qs <- quals\n ms <- try (many measureP) <|> return []\n typs <- many typP\n src <- declsExpr <$> many decl\n return (Prog qs ms src typs)\n\nmeasureP :: FP.Parser (F.Symbol, F.Sort)\nmeasureP = annL >> (Misc.mapSnd (rTypeSort . generalize) <$> tyBindP \"measure\")\n\ntypP :: FP.Parser SrcData\ntypP = do\n FP.reserved \"type\"\n tyc <- tc <$> FP.lowerIdP\n tvars <- typArgs\n rvars <- commaList refVar\n inv <- refTop\n FP.reservedOp \"=\" >> FP.spaces\n ctors <- fmap (mkCtor tyc tvars rvars) <$> ctorsP\n return (Data tyc tvars rvars ctors inv)\n\ndata Ctor = Ctor SrcBind [FunArg] (Maybe Reft)\ntype FunArg = (F.Symbol, RType)\n\nctorsP :: FP.Parser [Ctor]\nctorsP = try (FP.semi >> return [])\n <|> (:) <$> ctorP <*> ctorsP\n\nctorP :: FP.Parser Ctor\nctorP = Ctor <$> (FP.spaces *> mid *> cbind) <*> commaList funArgP <*> ctorResP\n\ncbind :: FP.Parser SrcBind\ncbind = withSpan' (Bind <$> FP.upperIdP)\n\ntypArgs :: FP.Parser [F.Symbol]\ntypArgs = commaList tvarP\n\nctorResP :: FP.Parser (Maybe Reft)\nctorResP = Just <$> (FP.reservedOp \"=>\" *> FP.brackets concReftB)\n <|> return Nothing\n\nmkCtor :: TyCon -> [Ident] -> [RVar] -> Ctor -> (SrcBind, RType)\nmkCtor tyc tvs rvs c = (dc, closeType rvs xts dcRes)\n where\n dcRes = TCon tyc (rVar <$> tvs) (rVarARef <$> rvs) dcReft\n Ctor dc xts r = c\n dcReft = Mb.fromMaybe mempty r\n\ncloseType :: [RVar] -> [(F.Symbol, RType)] -> RType -> RType\ncloseType rvs xts = tyParams\n . rvarParams\n . valParams\n where\n tyParams = generalize\n rvarParams t = foldr TRAll t rvs\n valParams ty = foldr (\\(x, t) s -> TFun x t s) ty xts\n\nrVarARef :: RVar -> RARef\nrVarARef (RVar p ts) = ARef xts (predReft pred)\n where\n xts = zipWith (\\t i -> (F.intSymbol \"rvTmp\" i, t)) ts [0..]\n pred = F.eApps (F.expr p) (F.expr . fst <$> xts)\n\ncommaList :: FP.Parser a -> FP.Parser [a]\ncommaList p = try (FP.parens (sepBy p FP.comma)) <|> return []\n\nquals :: FP.Parser [F.Qualifier]\nquals = try ((:) <$> between annL annR qual <*> quals)\n <|> pure []\n\nqual ::FP.Parser F.Qualifier\nqual = FP.reserved \"qualif\" >> FP.qualifierP (rTypeSort <$> rtype)\n\nexpr :: FP.Parser SrcExpr\nexpr = try funExpr\n <|> try letExpr\n <|> try ifExpr\n <|> try switchExpr\n <|> try (FP.braces (expr <* FP.spaces))\n <|> try appExpr\n <|> try binExp\n <|> expr0\n\nexpr0 :: FP.Parser SrcExpr\nexpr0 = try (FP.parens expr)\n <|> immExpr\n\nappExpr :: FP.Parser SrcExpr\nappExpr = mkEApp <$> immExpr <*> FP.parens (sepBy1 imm FP.comma)\n\nbinExp :: FP.Parser SrcExpr\nbinExp = withSpan' $ do\n x <- imm\n o <- op\n y <- imm\n return (bop o x y)\n\nop :: FP.Parser PrimOp\nop = (FP.reservedOp \"*\" >> pure BTimes)\n <|> (FP.reservedOp \"+\" >> pure BPlus )\n <|> (FP.reservedOp \"-\" >> pure BMinus)\n <|> (FP.reservedOp \"<\" >> pure BLt )\n <|> (FP.reservedOp \"<=\" >> pure BLe )\n <|> (FP.reservedOp \"==\" >> pure BEq )\n <|> (FP.reservedOp \">\" >> pure BGt )\n <|> (FP.reservedOp \">=\" >> pure BGe )\n <|> (FP.reservedOp \"&&\" >> pure BAnd )\n <|> (FP.reservedOp \"||\" >> pure BOr )\n\nbop :: PrimOp -> SrcImm -> SrcImm -> F.SrcSpan -> SrcExpr\nbop o x y l = mkEApp (EImm (ECon (PBin o) l) l) [x, y]\n\nmkEApp :: SrcExpr -> [SrcImm] -> SrcExpr\nmkEApp = L.foldl' (\\e y -> EApp e y (label e <> label y))\n\nletExpr :: FP.Parser SrcExpr\nletExpr = withSpan' (ELet <$> decl <*> expr)\n\nifExpr :: FP.Parser SrcExpr\nifExpr = withSpan' $ do\n FP.reserved \"if\"\n v <- FP.parens imm\n e1 <- expr\n FP.reserved \"else\"\n e2 <- expr\n return (EIf v e1 e2)\n\nswitchExpr :: FP.Parser SrcExpr\nswitchExpr = withSpan' $ do\n FP.reserved \"switch\"\n x <- FP.parens FP.lowerIdP\n alts <- FP.braces (many altP)\n return (ECase x alts)\n\naltP :: FP.Parser SrcAlt\naltP = withSpan' $ Alt\n <$> (FP.spaces *> mid *> FP.upperIdP)\n <*> commaList binder\n <*> (FP.reservedOp \"=>\" *> expr)\n\nimmExpr :: FP.Parser SrcExpr\nimmExpr = do\n i <- imm\n return (EImm i (label i))\n\nimm :: FP.Parser SrcImm\nimm = immInt <|> immBool <|> immId\n\nimmInt :: FP.Parser SrcImm\nimmInt = withSpan' (ECon . PInt <$> FP.natural)\n\nimmBool :: FP.Parser SrcImm\nimmBool = withSpan' (ECon . PBool <$> bool)\n\nimmId :: FP.Parser SrcImm\nimmId = withSpan' (EVar <$> identifier')\n\nbool :: FP.Parser Bool\nbool = (FP.reserved \"true\" >> pure True)\n <|>(FP.reserved \"false\" >> pure False)\n\nfunExpr :: FP.Parser SrcExpr\nfunExpr = withSpan' $ do\n xs <- FP.parens (sepBy1 binder FP.comma)\n _ <- FP.reservedOp \"=>\"\n -- _ <- FP.reservedOp \"{\"\n body <- FP.braces (expr <* FP.spaces)\n -- _ <- FP.reservedOp \"}\"\n return $ mkEFun xs body\n\nmkEFun :: [SrcBind] -> SrcExpr -> F.SrcSpan -> SrcExpr\nmkEFun bs e0 l = foldr (\\b e -> EFun b e l) e0 bs\n\n-- | Annotated declaration\ndecl :: FP.Parser SrcDecl\ndecl = do\n sig <- try (Just <$> ann) <|> pure Nothing\n decl <- plainDecl\n case sig of\n Just (a, s) -> return (mkDecl a s decl)\n Nothing -> return decl\n\nann :: FP.Parser (Ann, Sig)\nann = annL >> (((Val,) <$> sigP \"val\")\n <|>\n ((Refl,) <$> sigP \"reflect\"))\n\nannL, annR :: FP.Parser ()\nannL = FP.reservedOp \"/*@\"\nannR = FP.reservedOp \"*/\"\n\nsigP :: String -> FP.Parser Sig\nsigP kw = do\n FP.reserved kw\n x <- identifier\n FP.colon\n t <- rtype\n m <- try (Just <$> metricP) <|> pure Nothing\n annR\n return (x, t, m)\n\nmetricP :: FP.Parser Metric\nmetricP = reserved \"/\" *> sepBy myExprP FP.comma\n\n\ntyBindP :: String -> FP.Parser (F.Symbol, RType)\ntyBindP kw = do\n (x, t, _) <- sigP kw\n return (x, t)\n\ngenSig :: Sig -> Sig\ngenSig (x, t, y) = (x, generalize t, y)\n\nsigId :: Sig -> Ident\nsigId (x, _, _) = x\n\nmkDecl :: Ann -> Sig -> SrcDecl -> SrcDecl\nmkDecl a s (Let b e l)\n | sigId s == bindId b = Let b (EAnn e a (genSig s) (label e)) l\nmkDecl a s (Rec b e l)\n | sigId s == bindId b = Rec b (EAnn e a (genSig s) (label e)) l\nmkDecl _ s d\n | otherwise = error $ \"bad annotation: \" ++ show (sigId s, bindId (declBind d))\n\n\nplainDecl :: FP.Parser SrcDecl\nplainDecl = withSpan' $ do\n ctor <- (FP.reserved \"let rec\" >> pure Rec) <|>\n (FP.reserved \"let\" >> pure Let)\n b <- binder\n FP.reservedOp \"=\"\n e <- expr\n FP.semi\n return (ctor b e)\n\n-- | `binder` parses SrcBind, used for let-binds and function parameters.\nbinder :: FP.Parser SrcBind\nbinder = withSpan' (Bind <$> identifier)\n\n--------------------------------------------------------------------------------\n-- | Top level Rtype parser\n--------------------------------------------------------------------------------\nrtype :: FP.Parser RType\nrtype = (FP.reserved \"forall\" >> rall)\n <|> try rfun\n <|> rtype0\n\nrtype0 :: FP.Parser RType\nrtype0 = FP.parens rtype\n <|> rbase\n\nrfun :: FP.Parser RType\nrfun = mkTFun <$> funArgP <*> (FP.reservedOp \"=>\" *> rtype)\n\nrall :: FP.Parser RType\nrall = TRAll <$> FP.parens refVar <*> (FP.dot *> rtype)\n\nrefVar :: FP.Parser RVar\nrefVar = mkRVar <$> FP.lowerIdP <*> (FP.colon *> rtype)\n\nmkRVar :: F.Symbol -> RType -> RVar\nmkRVar p t\n | isBool out = RVar p [ const () <$> s | (_, s) <- xs ]\n | otherwise = error \"Refinement variable must have `bool` as output type\"\n where\n (xs, out) = bkFun t\n\nisBool :: RType -> Bool\nisBool t = rTypeSort t == F.boolSort\n\nfunArgP :: FP.Parser FunArg\nfunArgP = try ((,) <$> FP.lowerIdP <*> (FP.colon *> rtype0))\n <|> ((,) <$> freshArgSymbolP <*> rtype0)\n\nfreshArgSymbolP :: FP.Parser F.Symbol\nfreshArgSymbolP = do\n n <- FP.freshIntP\n return $ F.symbol (\"_arg\" ++ show n)\n\nmkTFun :: (F.Symbol, RType) -> RType -> RType\nmkTFun (x, s) = TFun x s\n\nrbase :: FP.Parser RType\nrbase = try (TBase <$> tbase <*> refTop)\n <|> (TCon . tc <$> identifier') <*> commaList rtype <*> tConARefs <*> refTop\n\ntbase :: FP.Parser Base\ntbase = (FP.reserved \"int\" >> pure TInt)\n <|> (FP.reserved \"bool\" >> pure TBool)\n <|> (tvarP >>= return . TVar. TV)\n\ntConARefs :: FP.Parser [RARef]\ntConARefs = try (commaList aRef)\n <|> pure []\n\ntvarP :: FP.Parser F.Symbol\ntvarP = FP.reservedOp \"'\" >> FP.lowerIdP\n\nrefTop :: FP.Parser Reft\nrefTop = FP.brackets reftB <|> pure mempty\n\nreftB :: FP.Parser Reft\nreftB = (question >> pure Unknown)\n <|> concReftB\n\nconcReftB :: FP.Parser Reft\nconcReftB = KReft <$> (FP.lowerIdP <* mid) <*> myPredP\n\naRef :: FP.Parser (ARef Reft)\naRef = ARef <$> commaList aRefArg <* FP.reservedOp \"=>\" <*> aRefBody\n where\n aRefArg :: FP.Parser (F.Symbol, RSort)\n aRefArg = (,) <$> FP.lowerIdP <* FP.colon <*> rSortP\n\naRefBody :: FP.Parser Reft\naRefBody = predReft <$> myPredP\n\npredReft :: F.Pred -> Reft\npredReft = Known F.dummySymbol . H.Reft\n\nrSortP :: FP.Parser RSort\nrSortP = rTypeToRSort <$> rtype0\n\nmid :: FP.Parser ()\nmid = FP.reservedOp \"|\"\n\nquestion :: FP.Parser ()\nquestion = FP.reservedOp \"?\"\n\n-- >>> (parseWith rtype \"\" \"int{v|v = 3}\")\n-- TBase TInt (v = 3)\n\n-- >>> (parseWith rtype \"\" \"int{v|v = x + y}\")\n-- TBase TInt (v = (x + y))\n\n-- >>> (parseWith rtype \"\" \"int\")\n-- TBase TInt true\n\n-- >>> parseWith funArg \"\" \"x:int\"\n-- (\"x\",TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"int => int\"\n-- TFun \"_\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt true)\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 < v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 < v))\n\n-- >>> parseWith rfun \"\" \"x:int => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt true) (TBase TInt (0 <= v))\n\n-- >>> parseWith rfun \"\" \"x:int{v|0 <= v} => int{v|0 <= v}\"\n-- TFun \"x\" (TBase TInt (0 <= v)) (TBase TInt (0 <= v))\n" }, { "path": "src/Language/Sprite/L8/Prims.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nmodule Language.Sprite.L8.Prims where\n\nimport qualified Data.Maybe as Mb\nimport qualified Data.Map as M\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\n-- import qualified Language.Sprite.Common.Misc as Misc\nimport Language.Sprite.L8.Types \nimport Language.Sprite.L8.Parse\n\n-- | \"Prelude\" Environment --------------------------------------------\n\nprelude :: [(F.Symbol, RType)]\nprelude = \n [ (\"diverge\" , mkTy \"x:int => 'a\")\n , (\"impossible\", mkTy \"x:int[v|false] => 'a\")\n , (\"Set_empty\" , mkTy \"x:int => 'a\")\n , (\"Set_add\" , mkTy \"s:Set_Set('a) => x:'a => Set_Set('a)\")\n ]\n\n-- | Primitive Types --------------------------------------------------\n\nconstTy :: F.SrcSpan -> Prim -> RType\nconstTy _ (PInt n) = TBase TInt (known $ F.exprReft (F.expr n)) \nconstTy _ (PBool True) = TBase TBool (known $ F.propReft F.PTrue)\nconstTy _ (PBool False) = TBase TBool (known $ F.propReft F.PFalse)\nconstTy l (PBin o) = binOpTy l o\n\n\nbinOpTy :: F.SrcSpan -> PrimOp -> RType \nbinOpTy l o = Mb.fromMaybe err (M.lookup o binOpEnv) \n where \n err = UX.panicS (\"Unknown PrimOp: \" ++ show o) l\n\nbTrue :: Base -> RType\nbTrue b = TBase b mempty\n\n\n\nbinOpEnv :: M.Map PrimOp RType\nbinOpEnv = M.fromList \n [ (BPlus , mkTy \"x:int => y:int => int[v|v=x+y]\")\n , (BMinus, mkTy \"x:int => y:int => int[v|v=x-y]\") \n , (BTimes, mkTy \"x:int => y:int => int[v|v=x*y]\") \n\n , (BLt , mkTy \"x:'a => y:'a => bool[v|v <=> (x < y)]\")\n , (BLe , mkTy \"x:'a => y:'a => bool[v|v <=> (x <= y)]\")\n , (BGt , mkTy \"x:'a => y:'a => bool[v|v <=> (x > y)]\")\n , (BGe , mkTy \"x:'a => y:'a => bool[v|v <=> (x >= y)]\")\n , (BEq , mkTy \"x:'a => y:'a => bool[v|v <=> (x == y)]\")\n\n , (BAnd , mkTy \"x:bool => y:bool => bool[v|v <=> (x && y)]\")\n , (BOr , mkTy \"x:bool => y:bool => bool[v|v <=> (x || y)]\")\n , (BNot , mkTy \"x:bool => bool[v|v <=> not x]\")\n ]\n\nmkTy :: String -> RType\nmkTy = {- Misc.traceShow \"mkTy\" . -} rebind . generalize . parseWith rtype \"prims\" \n\n\nrebind :: RType -> RType\nrebind t@(TBase {}) = t \nrebind (TAll a t) = TAll a (rebind t) \nrebind (TRAll p t) = TRAll p (rebind t) \nrebind (TCon c ts ps r) = TCon c (rebind <$> ts) ps r\nrebind (TFun x s t) = TFun x' s' t' \n where \n x' = F.mappendSym \"spec#\" x\n s' = subst (rebind s) x x'\n t' = subst (rebind t) x x'" }, { "path": "src/Language/Sprite/L8/Reflect.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeSynonymInstances #-}\n{-# LANGUAGE FlexibleInstances #-}\n\nmodule Language.Sprite.L8.Reflect (reflectData, reflect) where\n\nimport Control.Monad (void)\nimport qualified Data.HashMap.Strict as M\nimport qualified Language.Fixpoint.Horn.Types as H \nimport qualified Language.Fixpoint.Types as F \nimport qualified Language.Fixpoint.Misc as Misc \nimport qualified Language.Sprite.Common.UX as UX \nimport Language.Sprite.Common (eq)\nimport Language.Sprite.L8.Types \nimport Language.Sprite.L8.Constraints \n-- import Debug.Trace (trace)\n\n\n---------------------------------------------------------------------------------\nreflectData :: SrcData -> F.DataDecl\n---------------------------------------------------------------------------------\nreflectData (Data tc as _ ctors _) = F.DDecl (fTyCon tc) (length as) fCtors\n where\n tvM = zipWith (\\a i -> (a, F.FVar i)) as [0..]\n fCtors = reflectCtor tvM <$> ctors\n\ntype TvSub = [(Ident, F.Sort)] \n\nreflectCtor :: TvSub -> (SrcBind, RType) -> F.DataCtor\nreflectCtor tvM (Bind dc sp, s) = F.DCtor fDc fFields\n where\n fDc = F.atLoc sp dc\n fFields = zipWith mkFld fldTs [0..] \n fldTs = fmap snd . fsParams . funSig $ s \n mkFld t i = F.DField (fldName i) (fldSort t)\n fldName i = F.atLoc sp (selDataCon dc i)\n fldSort = F.sortSubst tvSub . rTypeSort\n tvSub = F.mkSortSubst tvM\n\n---------------------------------------------------------------------------------\n-- | Reflection -----------------------------------------------------------------\n---------------------------------------------------------------------------------\nreflect :: Ident -> SrcExpr -> RType -> CG RType\nreflect f e s = do \n v <- freshValueSym\n reflectTy f v e s\n\nreflectTy :: F.Symbol -> F.Symbol -> SrcExpr -> RType -> CG RType\nreflectTy f v e0 s0 = go [] e0 s0\n where \n go xs (ETLam _ e _) (TAll a t) = do \n TAll a <$> go xs e t\n go xs (EFun b e _) (TFun x s t) = do\n let x' = bindId b \n let s' = subst s x x'\n let t' = subst t x x'\n TFun x' s' <$> go ((x', rTypeSort s') : xs) e t' \n go xs e t = do \n let body = embed e \n let rbody = Known v (H.Reft (eq v body))\n addReflectVar f s0 (reverse xs) (rTypeSort t) body\n pure (strengthenTop t rbody) \n\n---------------------------------------------------------------------------------\nembed :: SrcExpr -> F.Expr\n---------------------------------------------------------------------------------\nembed = go\n where \n go (EImm i _) = embedImm i\n go e@(EApp {}) = embedApp e\n go (ELet d e _) = F.subst1 (go e) (goD d) \n go (EIf i e1 e2 _) = F.EIte (embedImm i) (go e1) (go e2)\n go (ETLam _ e _) = go e\n go (ETApp e t _) = go e -- F.ETApp (go e) (rTypeSort t)\n go (ECase x as _) = embedAlts x as\n go e = error (\"embed: not handled\" ++ show (void e))\n goD (Let b e1 _) = (bindId b, go e1)\n\n-------------------------------------------------------------------------------\n-- | Applications ------------------------------------------------------------- \n-------------------------------------------------------------------------------\n\nembedApp :: SrcExpr -> F.Expr \nembedApp e = case f of\n EImm (ECon (PBin o) _) _ -> embedPrim o args'\n _ -> F.eApps (embed f) args'\n where \n ((f, _), args) = {- Misc.traceShow \"bkApp\" $ -} bkApp e\n args' = embedImm <$> args\n\nbkApp :: SrcExpr -> ((SrcExpr, [RType]), [SrcImm])\nbkApp = go []\n where\n go vArgs (EApp f e _) = go (e:vArgs) f\n go vArgs e = (goT [] e, vArgs)\n goT tArgs (ETApp f t _) = goT (t:tArgs) f\n goT tArgs e = (e, tArgs)\n\n-------------------------------------------------------------------------------\n-- | Primitives --------------------------------------------------------------- \n-------------------------------------------------------------------------------\n\nembedPrim :: PrimOp -> [F.Expr] -> F.Expr\nembedPrim BPlus [e1, e2] = F.EBin F.Plus e1 e2 \nembedPrim BMinus [e1, e2] = F.EBin F.Minus e1 e2 \nembedPrim BTimes [e1, e2] = F.EBin F.Times e1 e2 \nembedPrim BLt [e1, e2] = F.PAtom F.Lt e1 e2 \nembedPrim BLe [e1, e2] = F.PAtom F.Le e1 e2\nembedPrim BEq [e1, e2] = F.PAtom F.Eq e1 e2 \nembedPrim BGt [e1, e2] = F.PAtom F.Gt e1 e2 \nembedPrim BGe [e1, e2] = F.PAtom F.Ge e1 e2\nembedPrim BAnd es = F.PAnd es\nembedPrim BOr es = F.POr es \nembedPrim BNot [e] = F.PNot e \nembedPrim o es = error $ \"embedPrim: cannot handle\" ++ show (o, es)\n\nembedImm :: SrcImm -> F.Expr\nembedImm (EVar x _) = F.expr x\nembedImm (ECon (PInt n) _) = F.expr n\nembedImm (ECon (PBool b) _) = F.expr b\nembedImm i = error (\"embedImm: \" ++ show i)\n\ninstance F.Expression Bool where \n expr True = F.PTrue\n expr False = F.PFalse \n\n-------------------------------------------------------------------------------\n-- | Data types --------------------------------------------------------------- \n-------------------------------------------------------------------------------\n\nembedAlts :: Ident -> [SrcAlt] -> F.Expr\nembedAlts x as = go as\n where\n go [a] = embedAlt x a\n go (a:as) = F.EIte (isAlt a x) (embedAlt x a) (go as) \n\nisAlt :: SrcAlt -> Ident -> F.Expr\nisAlt a x = mkEApp (isDataCon (altDaCon a)) x\n\nembedAlt :: Ident -> SrcAlt -> F.Expr\nembedAlt x a@(Alt d ys e _) = F.subst su (embed e)\n where \n su = F.mkSubst $ zipWith sub ys [0..]\n sub y i = (bindId y, mkEApp (selDataCon d i) x)\n yis = zipWith\n\nmkEApp :: F.Symbol -> F.Symbol -> F.Expr\nmkEApp f xs = F.eApps (F.expr f) [F.expr xs]\n\nisDataCon :: DaCon -> F.Symbol\nisDataCon = F.testSymbol \n\nselDataCon :: DaCon -> Int -> F.Symbol \nselDataCon d i = F.intSymbol d i\n\n" }, { "path": "src/Language/Sprite/L8/Types.hs", "content": "{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleInstances #-}\n\n\nmodule Language.Sprite.L8.Types where\n\nimport qualified Language.Fixpoint.Misc as Misc\nimport qualified Language.Fixpoint.Horn.Types as H\nimport qualified Language.Fixpoint.Horn.Transformations as H\nimport qualified Language.Fixpoint.Types as F\nimport qualified Language.Sprite.Common.UX as UX\nimport Language.Sprite.Common ( Label(..) )\nimport qualified Data.Set as S\nimport qualified Data.List as L\nimport qualified Data.Char as Char\n-- | Basic types --------------------------------------------------------------\nnewtype TVar = TV F.Symbol\n deriving (Eq, Ord, Show)\n\n\n\ninstance F.Symbolic TVar where\n symbol (TV a) = a\n\ndata Base = TInt | TBool | TVar TVar\n deriving (Eq, Ord, Show)\n\ninstance F.PPrint Base where\n pprintTidy _ = UX.tshow\n\n-- | Refinement Variables -----------------------------------------------------\ndata RVar = RVar\n { rvName :: F.Symbol\n , rvArgs :: ![RSort]\n }\n deriving (Eq, Show)\n\n-- | Abstract Refinements -----------------------------------------------------\ndata ARef r = ARef\n { arArgs :: ![(F.Symbol, RSort)]\n , arPred :: r\n }\n deriving (Eq, Show, Functor)\n\n-- | Refined Types ------------------------------------------------------------\n\ndata Type r\n = TBase !Base r -- ^ Int{r}\n | TFun !F.Symbol !(Type r) !(Type r) -- ^ x:s -> t\n | TAll !TVar !(Type r) -- ^ all a. t\n | TCon !TyCon ![Type r] ![ARef r] r -- ^ C t1...tn p1...pm\n | TRAll !RVar !(Type r) -- ^ rall r. t\n deriving (Eq, Show, Functor)\n\nrVar :: F.Symbol -> RType\nrVar a = TBase (TVar (TV a)) mempty\n\nrInt :: RType\nrInt = TBase TInt mempty\n\nrBool :: RType\nrBool = TBase TBool mempty\n\ndata Reft\n = Known !F.Symbol !H.Pred -- ^ Known refinement\n | Unknown -- ^ Unknown, to-be-synth refinement\n deriving (Show)\n\nknown :: F.Reft -> Reft\nknown (F.Reft (v, r)) = KReft v r\n\npattern KReft :: F.Symbol -> F.Expr -> Reft\npattern KReft v p = Known v (H.Reft p)\n\nisBase :: RType -> Bool\nisBase (TBase {}) = True\nisBase (TCon {}) = True\nisBase _ = False\n\ninstance Semigroup Reft where\n Unknown <> r = r\n r <> Unknown = r\n-- KReft v1 r1 <> KReft v2 r2 = KReft v r where F.Reft (v, r) = F.Reft (v1, r1) <> F.Reft (v2, r2)\n Known v p <> Known v' p'\n | v == v' = Known v (p <> p')\n | v == F.dummySymbol = Known v' (p' <> (p `F.subst1` (v , F.EVar v')))\n | otherwise = Known v (p <> (p' `F.subst1` (v', F.EVar v )))\n-- _ <> _ = error \"Semigroup Reft: TBD\"\n\ninstance Monoid Reft where\n mempty = KReft v r where F.Reft (v, r) = mempty\n\n-- | Proper refinement Types --------------------------------------------------\ntype RType = Type Reft\ntype RARef = ARef Reft\n\n-- | Sorts: types decorated with unit refinements -----------------------------\ntype RSort = Type ()\n\n-- | Primitive Constants ------------------------------------------------------\n\ndata PrimOp\n = BPlus\n | BMinus\n | BTimes\n | BLt\n | BLe\n | BEq\n | BGt\n | BGe\n | BAnd\n | BOr\n | BNot\n deriving (Eq, Ord, Show)\n\ndata Prim\n = PInt !Integer -- 0,1,2,...\n | PBool !Bool -- true, false\n | PBin !PrimOp -- +,-,==,<=,...\n deriving (Eq, Ord, Show)\n\n---------------------------------------------------------------------------------\n-- | Terms ----------------------------------------------------------------------\n---------------------------------------------------------------------------------\n\n-- | Bindings -------------------------------------------------------------------\n\ndata Bind a\n = Bind !Ident a\n deriving (Eq, Ord, Show, Functor)\n\ninstance F.Symbolic (Bind a) where\n symbol = bindId\n\nbindId :: Bind a -> F.Symbol\nbindId (Bind x _) = x\n\njunkSymbol :: F.Symbol\njunkSymbol = \"_\"\n\n-- | Names of things ------------------------------------------------------------\ntype Ident = F.Symbol -- ^ Identifiers\ntype DaCon = F.Symbol -- ^ Data constructors\n\n-- | Names of TyCon -------------------------------------------------------------\nnewtype TyCon = TC F.Symbol -- ^ Type constructors\n deriving (Eq, Ord, Show)\n\ninstance F.Symbolic TyCon where\n symbol (TC s) = s\n\ntc :: F.Symbol -> TyCon\ntc = TC . upperSym\n where\n upperSym s\n | isUpperSym s = s\n | otherwise = F.mappendSym \"T\" s\n\n isUpperSym s = case F.symbolString s of\n [] -> False\n (c:_) -> Char.isUpper c\n\n-- | \"Immediate\" terms (can appear as function args & in refinements) -----------\n\ndata Imm a\n = EVar !Ident a\n | ECon !Prim a\n deriving (Show, Functor)\n\n-- | Termination Metric ----------------------------------------------------------\ntype Metric = [F.Expr] -- ^ lexic.sequence of int-refinements\n\n-- | Variable definition ---------------------------------------------------------\ndata Decl a\n = Let (Bind a) (Expr a) a -- ^ plain \"let\"\n | Rec (Bind a) (Expr a) a -- ^ recursive \"let rec\"\n deriving (Show, Functor)\n\ndeclBind :: Decl a -> Bind a\ndeclBind (Let b _ _) = b\ndeclBind (Rec b _ _) = b\n\n-- | Case-Alternatives -----------------------------------------------------------\n\ndata Alt a = Alt\n { altDaCon :: !DaCon -- ^ Data constructor\n , altBinds :: ![Bind a] -- ^ Binders x1...xn\n , altExpr :: !(Expr a) -- ^ Body-expr\n , altLabel :: a -- ^ Label\n }\n deriving (Show, Functor)\n\n-- | Signatures ------------------------------------------------------------------\n\ntype Sig = (F.Symbol, RType, Maybe Metric)\n\ndata Ann = Val | Refl deriving (Show)\n\n-- | Terms -----------------------------------------------------------------------\ndata Expr a\n = EImm !(Imm a) a -- ^ x,y,z,... 1,2,3...\n | EFun !(Bind a) !(Expr a) a -- ^ \\x -> e\n | EApp !(Expr a) !(Imm a) a -- ^ e v\n | ELet !(Decl a) !(Expr a) a -- ^ let/rec x = e1 in e2\n | EAnn !(Expr a) !Ann !Sig a -- ^ e:t\n | EIf !(Imm a) !(Expr a) !(Expr a) a -- ^ if v e1 e2\n | ETLam !TVar !(Expr a) a -- ^ Λ a. e (type abstraction)\n | ETApp !(Expr a) !RType a -- ^ e [t] (type application)\n | ERApp !(Expr a) a -- ^ e [?] (reft application)\n | ECase !Ident ![Alt a] a -- ^ switch (x) { a1 ... }\n deriving (Show, Functor)\n\ninstance Label Bind where\n label (Bind _ l) = l\n\ninstance Label Alt where\n label = altLabel\n\ninstance Label Imm where\n label (EVar _ l) = l\n label (ECon _ l) = l\n\ninstance Label Expr where\n label (EImm _ l) = l\n label (EFun _ _ l) = l\n label (EApp _ _ l) = l\n label (ELet _ _ l) = l\n label (EAnn _ _ _ l) = l\n label (EIf _ _ _ l) = l\n label (ETLam _ _ l) = l\n label (ETApp _ _ l) = l\n label (ERApp _ l) = l\n label (ECase _ _ l) = l\n\ninstance Label Decl where\n label (Let _ _ l) = l\n label (Rec _ _ l) = l\n\n------------------------------------------------------------------------------\n-- | Top-level `Program` datatype\n------------------------------------------------------------------------------\ndata Prog a = Prog\n { prQuals :: ![F.Qualifier]\n , prMeas :: ![(F.Symbol, F.Sort)]\n , prExpr :: !(Expr a)\n , prData :: ![Data a]\n }\n deriving (Show, Functor)\n\ndata Data a = Data\n { dcName :: !TyCon -- ^ name of the datatype\n , dcVars :: ![Ident] -- ^ type variables\n , dcRVars :: ![RVar] -- ^ refinement variables\n , dcCtors :: ![(Bind a, RType)] -- ^ constructors\n , dcInv :: !Reft -- ^ data invariant\n }\n deriving (Show, Functor)\n\n------------------------------------------------------------------------------\ndeclsExpr :: [Decl a] -> Expr a\n------------------------------------------------------------------------------\ndeclsExpr [d] = ELet d (intExpr 0 l) l where l = label d\ndeclsExpr (d:ds) = ELet d (declsExpr ds) l where l = label d\ndeclsExpr _ = error \"impossible\"\n\nintExpr :: Integer -> a -> Expr a\nintExpr i l = EImm (ECon (PInt i) l) l\n\nboolExpr :: Bool -> a -> Expr a\nboolExpr b l = EImm (ECon (PBool b) l) l\n\n------------------------------------------------------------------------------\ntype SrcImm = Imm F.SrcSpan\ntype SrcBind = Bind F.SrcSpan\ntype SrcDecl = Decl F.SrcSpan\ntype SrcExpr = Expr F.SrcSpan\ntype ElbDecl = Decl F.SrcSpan\ntype ElbExpr = Expr F.SrcSpan\ntype SrcProg = Prog F.SrcSpan\ntype SrcData = Data F.SrcSpan\ntype SrcAlt = Alt F.SrcSpan\n------------------------------------------------------------------------------\n\n-- | should/need only be defined on \"Known\" variants. TODO:LIQUID\ninstance F.Subable Reft where\n syms (Known v r) = v : F.syms r\n syms Unknown = []\n substa f (Known v r) = Known (f v) (F.substa f r)\n substa _ (Unknown) = Unknown\n substf f (Known v r) = Known v (F.substf (F.substfExcept f [v]) r)\n substf _ (Unknown) = Unknown\n subst su (Known v r) = Known v (F.subst (F.substExcept su [v]) r)\n subst _ (Unknown) = Unknown\n subst1 (Known v r) su = Known v (F.subst1Except [v] r su)\n subst1 (Unknown) _ = Unknown\n\n-- instance F.Subable ARef where\ninstance F.Subable r => F.Subable (ARef r) where\n syms (ARef _ p) = F.syms p\n substa f (ARef xts p) = ARef xts (F.substa f p)\n substf f (ARef xts p) = ARef xts (F.substf f p)\n subst f (ARef xts p) = ARef xts (F.subst f p)\n\ninstance F.Subable r => F.Subable (Type r) where\n -- syms :: a -> [Symbol]\n syms (TBase _ r) = F.syms r\n syms (TAll _ t) = F.syms t\n syms (TRAll _ t) = F.syms t\n syms (TFun _ s t) = F.syms s ++ F.syms t\n syms (TCon _ ts ps r) = concatMap F.syms ts ++ concatMap F.syms ps ++ F.syms r\n\n -- substa :: (Symbol -> Symbol) -> Type r -> Type r\n substa f (TBase b r) = TBase b (F.substa f r)\n substa f (TFun x s t) = TFun x (F.substa f s) (F.substa f t)\n substa f (TAll a t) = TAll a (F.substa f t)\n substa f (TRAll p t) = TRAll p (F.substa f t)\n substa f (TCon c ts ps r) = TCon c (F.substa f <$> ts) (F.substa f <$> ps) (F.substa f r)\n\n -- substf :: (Symbol -> Expr) -> Type r -> Type r\n substf f (TBase b r) = TBase b (F.substf f r)\n substf f (TFun x s t) = TFun x (F.substf f s) (F.substf f t)\n substf f (TAll a t) = TAll a (F.substf f t)\n substf f (TRAll p t) = TRAll p (F.substf f t)\n substf f (TCon c ts ps r) = TCon c (F.substf f <$> ts) (F.substf f <$> ps) (F.substf f r)\n\n -- subst :: Subst -> a -> a\n subst f (TBase b r) = TBase b (F.subst f r)\n subst f (TFun x s t) = TFun x (F.subst f s) (F.subst f t)\n subst f (TAll a t) = TAll a (F.subst f t)\n subst f (TRAll p t) = TRAll p (F.subst f t)\n subst f (TCon c ts ps r) = TCon c (F.subst f <$> ts) (F.subst f <$> ps) (F.subst f r)\n\n--------------------------------------------------------------------------------\n-- | Substitution --------------------------------------------------------------\n--------------------------------------------------------------------------------\n\nsubstImm :: (F.Subable a) => a -> F.Symbol -> Imm b -> a\nsubstImm thing x y = F.subst su thing\n where\n su = F.mkSubst [(x, immExpr y)]\n\nsubst :: (F.Subable a) => a -> F.Symbol -> F.Symbol -> a\nsubst thing x y = substImm thing x (EVar y ())\n\nsubsts :: (F.Subable a) => a -> [(F.Symbol, F.Symbol)] -> a\nsubsts thing xys = L.foldl' (\\t (x, y) -> subst t x y) thing xys\n\nimmExpr :: Imm b -> F.Expr\nimmExpr (EVar x _) = F.expr x\nimmExpr (ECon (PInt n) _) = F.expr n\nimmExpr (ECon (PBool True) _) = F.PTrue\nimmExpr (ECon (PBool False) _) = F.PFalse\nimmExpr _ = error \"impossible\"\n\n--------------------------------------------------------------------------------\n-- | Normalizing types by generalizing tyvars, refactoring ref-var applications\n--------------------------------------------------------------------------------\ngeneralize :: RType -> RType\ngeneralize = refactorApp . generalizeTVar\n\n--------------------------------------------------------------------------------\n-- | Substituting Type Variables -----------------------------------------------\n--------------------------------------------------------------------------------\ntsubst :: TVar -> RType -> RType -> RType\ntsubst a t = go\n where\n go (TAll b s)\n | a == b = TAll b s\n | otherwise = TAll b (go s)\n go (TRAll p t) = TRAll (goP p) (go t)\n go (TFun x s1 s2) = TFun x (go s1) (go s2)\n go (TBase b r) = bsubst a t b r\n go (TCon c ts ps r) = TCon c (go <$> ts) (goA <$> ps) r\n goP p = p { rvArgs = [ asRType go t | t <- rvArgs p ] }\n goA a = a { arArgs = [ (x, asRType go t) | (x, t) <- arArgs a ] }\n\ntsubsts :: [(TVar, RType)] -> RType -> RType\ntsubsts ats s = L.foldl' (\\s (a, t) -> tsubst a t s) s ats\n\nbsubst :: TVar -> RType -> Base -> Reft -> RType\nbsubst a t (TVar v) r\n | v == a = strengthenTop t r\nbsubst _ _ b r = TBase b r\n\nrTypeReft :: RType -> Maybe Reft\nrTypeReft (TBase _ r) = Just r\nrTypeReft (TCon _ _ _ r) = Just r\nrTypeReft _ = Nothing\n\nstrengthenTop :: RType -> Reft -> RType\nstrengthenTop t@(TFun {}) _ = t\nstrengthenTop t@(TAll {}) _ = t\nstrengthenTop t@(TRAll {}) _ = t\nstrengthenTop (TBase b r) r' = TBase b (r <> r')\nstrengthenTop (TCon c ts ps r) r' = TCon c ts ps (r <> r')\n\n\ngeneralizeTVar :: RType -> RType\ngeneralizeTVar t = foldr TAll t (freeTVars t)\n\nfreeTVars :: Type a -> [TVar]\nfreeTVars = Misc.sortNub . S.toList . go\n where\n goP = S.fromList . concatMap freeTVars . rvArgs\n go (TAll a t) = S.delete a (go t)\n go (TRAll p t) = S.union (goP p) (go t)\n go (TFun _ s t) = S.union (go s) (go t)\n go (TCon _ ts _ _) = S.unions ((go <$> ts))\n go (TBase b _) = goB b\n goB (TVar a) = S.singleton a\n goB _ = S.empty\n\n-------------------------------------------------------------------------------\n-- | Types and Sorts\n-------------------------------------------------------------------------------\n\nbaseSort :: Base -> F.Sort\nbaseSort TInt = F.intSort\nbaseSort TBool = F.boolSort\nbaseSort (TVar a) = F.FObj (F.symbol a)\n\nrTypeSort :: RType -> F.Sort\nrTypeSort (TBase b _) = baseSort b\nrTypeSort (TCon c ts _ _) = F.fAppTC (fTyCon c) (rTypeSort <$> ts)\nrTypeSort t@(TFun {}) = rTypeSortFun t\nrTypeSort t@(TAll {}) = rTypeSortAll t\nrTypeSort (TRAll _ t) = rTypeSort t\n\nrTypeSortFun :: RType -> F.Sort\nrTypeSortFun = F.mkFFunc 0 . fmap rTypeSort . go []\n where\n go ts (TFun _ t1 t2) = go (t1:ts) t2\n go ts t = reverse (t:ts)\n\nrTypeSortAll :: RType -> F.Sort\nrTypeSortAll s = genSort (rTypeSort t)\n where\n genSort t = L.foldl' (flip F.FAbs) (F.sortSubst su t) [0..n-1]\n (as, t) = bkAll s\n su = F.mkSortSubst $ zip sas (F.FVar <$> [0..])\n sas = F.symbol <$> as\n n = length as\n\nbkAll :: RType -> ([TVar], RType)\nbkAll (TAll a s) = (a:as, t) where (as, t) = bkAll s\nbkAll t = ([] , t)\n\nbkRAll :: RType -> ([RVar], RType)\nbkRAll (TRAll p s) = (p:ps, t) where (ps, t) = bkRAll s\nbkRAll t = ([] , t)\n\nfTyCon :: TyCon -> F.FTycon\nfTyCon = F.symbolFTycon . F.dummyLoc . F.symbol\n\n\ndata FunSig = FunSig\n { fsTVars :: [TVar] -- ^ type variables\n , fsRVars :: [RVar] -- ^ refinement variables\n , fsParams :: [(Ident, RType)] -- ^ input binders\n , fsOut :: RType -- ^ output type\n }\n\nfunSig :: RType -> FunSig\nfunSig t = FunSig as rs xts ot\n where\n (as, rs, t') = bkAlls t\n (xts, ot) = bkFun t'\n\nbkFun :: RType -> ([(F.Symbol, RType)], RType)\nbkFun (TFun x s t) = ((x, s) : ins, out) where (ins, out) = bkFun t\nbkFun out = ([] , out)\n\n\n-- | See [NOTE:RefactorApp] ---------------------------------------------------\nrefactorApp :: RType -> RType\nrefactorApp s = tAlls as ps (refactorAppR isRV <$> t)\n where\n (as,ps,t) = bkAlls s\n pvs = S.fromList (rvName <$> ps)\n isRV p = S.member p pvs\n\ntAlls :: [TVar] -> [RVar] -> RType -> RType\ntAlls as ps = tAll as . tRAll ps\n\ntAll :: [TVar] -> Type a -> Type a\ntAll as t = foldr TAll t as\n\ntRAll :: [RVar] -> Type a -> Type a\ntRAll ps t = foldr TRAll t ps\n\nbkAlls :: RType -> ([TVar], [RVar], RType)\nbkAlls s = (as, ps, t)\n where\n (as, s') = bkAll s\n (ps, t) = bkRAll s'\n\nrefactorAppR :: (F.Symbol -> Bool) -> Reft -> Reft\nrefactorAppR isRV (Known v p) = Known v (refactorAppP isRV p)\nrefactorAppR _ r = r\n\n-- | See [NOTE:RefactorApp] ---------------------------------------------------\nrefactorAppP :: (F.Symbol -> Bool) -> H.Pred -> H.Pred\nrefactorAppP isRV p = H.PAnd (H.Reft (F.pAnd fs) : rs)\n where\n es = predExprs p\n (rs, fs) = Misc.mapEither (isRVarApp isRV) es\n\nisRVarApp :: (F.Symbol -> Bool) -> F.Expr -> Either H.Pred F.Expr\nisRVarApp isRV e@(F.EApp {})\n | (F.EVar k, args) <- F.splitEApp e\n , isRV k = Left (H.Var k (rvarArgSymbol msg <$> args)) where msg = F.showpp e\nisRVarApp _ e = Right e\n\nrvarArgSymbol :: String -> F.Expr -> F.Symbol\nrvarArgSymbol _ (F.EVar x) = x\nrvarArgSymbol msg e = error $ \"Unexpected argument in ref-variable: \" ++ msg ++ \" \" ++ show e\n\npredExprs :: H.Pred -> [F.Expr]\npredExprs p = case H.flatten p of\n H.PAnd ps -> concatMap go ps\n q -> go q\n where\n go (H.Reft e) = F.conjuncts e\n go _ = error \"unexpected H.Pred in predExprs\"\n\n{- | [NOTE:RefactorApp] The parser cannot distinguish between\n * plain applications (f x y z) and\n * ref-var applications (p x y z) using\n `H.Var !F.Symbol ![F.Symbol] -- ^ $k(y1..yn)`\n So, post-parsing, we traverse the refinements with an `isRV`\n test to pull the ref-var applications out.\n -}\n\nasRType :: (RType -> RType) -> RSort -> RSort\nasRType f = rTypeToRSort . f . rSortToRType\n\nrTypeToRSort :: RType -> RSort\nrTypeToRSort = fmap (const ())\n\nrSortToRType :: RSort -> RType\nrSortToRType = fmap (const mempty)\n\nrSortToFSort :: RSort -> F.Sort\nrSortToFSort = rTypeSort . rSortToRType\n\nrVarARef :: RVar -> RARef\nrVarARef (RVar p ts) = ARef xts (Known F.dummySymbol pred)\n where\n xts = zipWith (\\t i -> (F.intSymbol \"kvTmp\" i, t)) ts [0..]\n pred = H.Var p (fst <$> xts)\n\n-------------------------------------------------------------------------------\n-- | Substituting Refinement Variables -----------------------------------------------\n-------------------------------------------------------------------------------\nclass SubsARef a where\n subsAR :: F.Symbol -> RARef -> a -> a\n\ninstance SubsARef H.Pred where\n subsAR p (ARef yts (Known _ pr)) = go\n where\n go (H.Var k xs)\n | k == p = substs pr (zipWith (\\(y,_) x -> (y, x)) yts xs)\n go (H.PAnd ps ) = H.PAnd (go <$> ps)\n go pred = pred\n\ninstance SubsARef Reft where\n subsAR p ar (Known v pr) = Known v (subsAR p ar pr)\n subsAR p ar r = r\n\ninstance SubsARef RType where\n subsAR p ar t = subsAR p ar <$> t\n\nrsubsts :: (SubsARef a) => [(RVar, RARef)] -> a -> a\nrsubsts rps z = L.foldl' (\\x (p, ar) -> rsubst1 p ar x) z rps\n\nrsubst1 :: (SubsARef a) => RVar -> RARef -> a -> a\nrsubst1 (RVar p _) ar z = subsAR p ar z\n" }, { "path": "src/Language/Sprite/L8.hs", "content": "module Language.Sprite.L8 ( sprite ) where\n\nimport System.Exit\nimport qualified Language.Fixpoint.Types as F\nimport Language.Sprite.L8.Check\nimport Language.Sprite.L8.Parse\nimport Language.Sprite.Common\n\n--------------------------------------------------------------------------------\nsprite :: FilePath -> IO ()\n--------------------------------------------------------------------------------\nsprite f = do\n src <- parseFile f\n res <- case vcgen src of\n Left errs -> pure (crash errs \"VCGen failure\")\n Right vc -> checkValidPLE f vc\n ec <- resultExit res\n exitWith ec\n" }, { "path": "stack.yaml", "content": "resolver: nightly-2024-01-26\n\npackages:\n - '.'\n\nextra-deps:\n- store-0.7.18@sha256:af32079e0d31413b97a1759f8ad8555507857cd4ac4015e195fb5b0a27a3ce9f,8159\n- store-core-0.4.4.7@sha256:a2ea427ff0dde30252474dcb0641cb6928cb8a93cd5ee27d4c22adba8e729683,1489\n- rest-rewrite-0.4.3\n- smtlib-backends-0.3@rev:2\n- smtlib-backends-process-0.3@rev:2\n- git: https://github.com/ucsd-progsys/liquid-fixpoint\n commit: 794aed1388442e64ced07a7f53c5aba14ce01a24\n\nallow-newer: true\n" }, { "path": "stack.yaml.github", "content": "# resolver: lts-13.20\nresolver: lts-16.10\n\npackages:\n - '.'\n\nextra-deps:\n- intern-0.9.2\n- located-base-0.1.1.1\n- text-format-0.3.2\n- tasty-rerun-1.1.14\n- git: https://github.com/ucsd-progsys/liquid-fixpoint\n commit: 5501659ccb6dbbd53a859cdda8e4a76d62fc31df\n\ncompiler: ghc-8.10.2\nallow-newer: true\n" }, { "path": "test/L1/neg/inc00.re", "content": "\n\n/*@ val inc: x:int => int[v|v = x + 1] */\nlet inc = (x) => {\n x - 1\n};\n\nlet bar = inc(10);\n" }, { "path": "test/L1/neg/inc01.re", "content": "/*@ val inc: x:int[v|0<=v] => int[v|0<=v] */\nlet inc = (x) => {\n x + 1\n};\n\n/*@ val dec : x:int => int[v | v == x - 1] */\nlet dec = (x) => {\n x - 1\n};\n\n/*@ val inc2: x:int[v|0<=v] => int[v|0<=v] */\nlet inc2 = (x) => {\n let tmp = inc(x);\n dec(tmp)\n};\n\n" }, { "path": "test/L1/neg/inc02.re", "content": "/*@ val dec : x:int => int[v|v==x-1] */\nlet dec = (x) => {\n x - 1\n};\n\n/*@ val incf: x:int[v|0<=v] => int[v|0<=v] */\nlet incf = (x) => {\n /*@ val tmp : f:(int[v|0<=v] => int[v|0<=v]) => int[v|0<=v] */\n let tmp = (f) => {\n f(x)\n };\n tmp(dec)\n};\n" }, { "path": "test/L1/neg/int01.re", "content": "let v1 = 1;\n\nlet v2 = 2;\n\n/*@ val top : int[v|v = 30] */ \nlet top = v1 + v2;\n\n\n\n" }, { "path": "test/L1/pos/inc00.re", "content": "\n\n/*@ val inc: x:int => int[v|v = x + 1] */\nlet inc = (x) => {\n x + 1\n};\n\nlet bar = inc(10);\n" }, { "path": "test/L1/pos/inc01.re", "content": "\n/*@ val inc: x:int => int[v | v == x + 1] */\nlet inc = (x) => {\n x + 1\n};\n\n/*@ val inc2: x:int[v|0<=v] => int[v|0<=v] */\nlet inc2 = (x) => {\n let tmp = inc(x);\n inc(tmp)\n};\n\n" }, { "path": "test/L1/pos/inc02.re", "content": "\n\n/*@ val inc: x:int => int[v|v=x+1] */\nlet inc = (x) => {\n x + 1\n};\n\n/*@ val incf: x:int[v|0<=v] => int[v|0<=v] */\nlet incf = (x) => {\n /*@ val tmp : f:(int[v|0<=v] => int[v|0<=v]) => int[v|0<=v] */\n let tmp = (f) => {\n f(x)\n };\n tmp(inc)\n};\n" }, { "path": "test/L1/pos/int00.re", "content": "let v1 = 1;\n\nlet v2 = 2;\n\nlet top = v1 + v2;\n\n\n\n" }, { "path": "test/L1/pos/int01.re", "content": "let v1 = 1;\n\nlet v2 = 2;\n\n/*@ val top : int[v|v = 3] */ \nlet top = v1 + v2;" }, { "path": "test/L2/neg/abs00.re", "content": "/*@ val abs : x:int => int[v|0<=v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n 0 - x\n } else {\n x\n }\n};\n" }, { "path": "test/L2/neg/abs01.re", "content": "/*@ val abs : x:int => int[v| 0<=v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/*@ val test : a:int => b:int => int[v|0<=v && a + b <= v] */\nlet test = (a, b) => {\n let t1 = abs(a);\n let t2 = abs(b);\n t1 + t2\n};\n" }, { "path": "test/L2/neg/cmp00.re", "content": "/*@ val cmp : x:int => bool[b|b <=> (x < 0)] */\nlet cmp = (x) => {\n let cond = x < 10;\n if (cond) {\n true\n } else {\n false\n }\n};\n" }, { "path": "test/L2/neg/cmp01.re", "content": "/*@ val cmp : x:int => y:int => bool[b|b <=> (x < y)] */\nlet cmp = (x, y) => {\n let cond = x > y;\n if (cond) {\n true\n } else {\n false\n }\n};\n" }, { "path": "test/L2/neg/sum00.re", "content": "/*@ val sum : n:int => int[v|0 <= v && n <= v] */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n t1\n }\n};\n" }, { "path": "test/L2/pos/abs00.re", "content": "/*@ val abs : x:int => int[v|0<=v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n" }, { "path": "test/L2/pos/abs01.re", "content": "/*@ val abs : x:int => int[v| 0<=v && x <= v] */\nlet abs = (x) => { \n let pos = x >= 0; \n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/*@ val test : a:int => b:int => int[v|0<=v && a + b <= v] */\nlet test = (a, b) => {\n let t1 = abs(a);\n let t2 = abs(b);\n t1 + t2\n};\n" }, { "path": "test/L2/pos/cmp00.re", "content": "/*@ val cmp : x:int => bool[b|b <=> (x < 10)] */\nlet cmp = (x) => {\n let cond = x < 10;\n if (cond) {\n true\n } else {\n false\n }\n};\n" }, { "path": "test/L2/pos/cmp01.re", "content": "/*@ val cmp : x:int => y:int => bool[b|b <=> (x < y)] */\nlet cmp = (x, y) => {\n let cond = x < y;\n if (cond) {\n true\n } else {\n false\n }\n};\n" }, { "path": "test/L2/pos/sum00.re", "content": "/*@ val sum : n:int => int[v|0 <= v && n <= v] */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n};\n" }, { "path": "test/L3/neg/abs01.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n let pos = x >= 0;\n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/*@ val main : int => int */\nlet main = (y) => {\n let fails = 0 <= y;\n cassert(fails)\n};\n" }, { "path": "test/L3/neg/abs02-bad.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n let pos = x >= 0;\n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/* SAFE : val wrap : (int => int[v|v>=0]) => int[?] */\n/* UNSAFE : val wrap : (int => int[?]) => int[?] */\n\n/*@ val incf: int => int */\nlet incf = (z) => {\n /*@ val wrap : (int => int[v|v>=0]) => int[?] */\n let wrap = (f) => {\n let r = f(z);\n r + 1\n };\n let res = wrap(abs);\n let ok = 6660 <= res;\n cassert (ok)\n};\n" }, { "path": "test/L3/neg/abs02.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n let pos = 0 <= x;\n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/*@ val incf: int => int */\nlet incf = (x) => {\n /*@ val wrap : (int => int[?]) => int[?] */\n let wrap = (f) => {\n let r = f(x);\n r \n };\n let res = wrap(abs);\n let ok = 0 < res;\n cassert (ok)\n};\n" }, { "path": "test/L3/neg/assert00.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val main : int => int */\nlet main = (x) => {\n let x1 = x - 1;\n let cond = x < x1;\n cassert(cond)\n};\n" }, { "path": "test/L3/neg/rebind.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val check : int => int */\nlet check = (y) => {\n let y1 = y-1;\n let ok = y <= y1;\n cassert(ok)\n};\n" }, { "path": "test/L3/neg/sum01.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val sum : n:int => int[?] */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n};\n\n/*@ val check2 : int => int */\nlet check2 = (y) => {\n let y1 = y-1;\n let res = sum(y1); \n let ok = y <= res;\n cassert(ok)\n};\n" }, { "path": "test/L3/pos/abs01.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n let pos = x >= 0;\n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/*@ val main : int => int */\nlet main = (y) => {\n let ya = abs(y); \n let ok = 0 <= ya;\n cassert(ok)\n};\n" }, { "path": "test/L3/pos/abs02-debug.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[v1|v1>=0] */\nlet abs = (x) => { 10 };\n\n/*@ val incf: int => int */\nlet incf = (z) => {\n /*@ val wrap : (y:int => int[?]) => int[v2|v2>=0] */\n let wrap = (f) => {\n let r = f(z);\n r \n };\n wrap(abs)\n};\n" }, { "path": "test/L3/pos/abs02.re", "content": "/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val abs : x:int => int[?] */\nlet abs = (x) => {\n let pos = x >= 0;\n if (pos) {\n x\n } else {\n 0 - x\n }\n};\n\n/*@ val incf: int => int */\nlet incf = (z) => {\n /*@ val wrap : (int => int[?]) => int[?] */\n let wrap = (f) => {\n let r = f(z);\n r + 1\n };\n let res = wrap(abs);\n let ok = 0 <= res;\n cassert (ok)\n};\n" }, { "path": "test/L3/pos/assert00.re", "content": "\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val main : int => int */\nlet main = (x) => {\n let x1 = x + 1;\n let cond = x < x1;\n cassert(cond)\n};" }, { "path": "test/L3/pos/sum01.re", "content": "/*@ qualif Pos(v:int): (0 <= v) */\n/*@ qualif Geq(v:int, n:int): (n <= v) */\n\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { 0 };\n\n/*@ val sum : n:int => int[?] */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n};\n\n/*@ val check1 : int => int */\nlet check1 = (y) => {\n let res = sum(y); \n let ok = 0 <= res;\n cassert(ok)\n};\n\n/*@ val check2 : int => int */\nlet check2 = (y) => {\n let res = sum(y); \n let ok = y <= res;\n cassert(ok)\n};\n" }, { "path": "test/L4/neg/choose00.re", "content": "\n/*@ val choose : 'a => 'b => 'a */\nlet choose = (x, y) => { x };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */\nlet check = (a, b) => {\n let aM = a - 1;\n let res = choose(aM, a); \n res\n};\n" }, { "path": "test/L4/neg/choose01.re", "content": "\n/*@ val choose : 'a => 'b => 'b */\nlet choose = (x, y) => { y };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */\nlet check = (a, b) => {\n let aM = a - 1;\n let res = choose(a, aM); \n res\n};\n" }, { "path": "test/L4/neg/foldn00.re", "content": "/*@ val foldn : ('a => int => 'a) => 'a => int => int => 'a */\nlet rec foldn = (f, acc, i, n) => {\n let leq = i < n;\n if (leq) {\n let ip = i + 1;\n let accp = f (acc, i);\n foldn(f, accp, ip, n)\n } else { \n acc\n }\n};\n\n/*@ val add : x:int => y:int => int[v|v = x + y] */\nlet add = (x, y) => {\n x + y\n};\n\n/*@ val main : m:int[v|0<=v] => int[v|0<=v] */\nlet main = (m) => {\n foldn(add, 0, 0, m)\n};\n" }, { "path": "test/L4/neg/foldn01.re", "content": "// No quals!\n\n/*@ val foldn : ('a => int[?] => 'a) => 'a => i:int[?] => n:int[?] => 'a */\nlet rec foldn = (f, acc, i, n) => {\n let leq = i < n;\n if (leq) {\n let ip = i + 1;\n let accp = f (acc, i);\n foldn(f, accp, ip, n)\n } else { \n acc\n }\n};\n\n/*@ val add : x:int => y:int => int[v|v = x + y] */\nlet add = (x, y) => {\n x + y\n};\n\n/*@ val main : m:int[v|0<=v] => int[v|0<=v] */\nlet main = (m) => {\n foldn(add, 0, 0, m)\n};\n" }, { "path": "test/L4/neg/id00.re", "content": "/*@ val id : 'a => 'a */\nlet id = (x) => { x };\n\n/*@ val check1 : x:int[v|0<=v] => int[v|0<=v] */\nlet check1 = (y) => {\n let y1 = y - 1;\n let res = id(y1); \n res\n};\n" }, { "path": "test/L4/pos/choose00.re", "content": "\n/*@ val choose : 'a => 'b => 'a */\nlet choose = (x, y) => { x };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */\nlet check = (a, b) => {\n let aP = a + 1;\n let aM = a - 1;\n let res = choose(aP, aM); \n res\n};\n" }, { "path": "test/L4/pos/choose01.re", "content": "\n/*@ val choose : 'a => 'b => 'b */\nlet choose = (x, y) => { y };\n\n/*@ val check : int[v|0<=v] => int[v|0<=v] => int[v|0<=v] */\nlet check = (a, b) => {\n let aM = a - 1;\n let res = choose(aM, a); \n res\n};\n" }, { "path": "test/L4/pos/foldn00.re", "content": "/*@ qualif Pos(v:int): (0 <= v) */\n\n/*@ val foldn : ('a => int[v|0<=v] => 'a) => 'a => i:int[v|0 <= v] => n:int[v|i<=v] => 'a */\nlet rec foldn = (f, acc, i, n) => {\n let leq = i < n;\n if (leq) {\n let ip = i + 1;\n let accp = f(acc, i);\n foldn(f, accp, ip, n)\n } else { \n acc\n }\n};\n\n/*@ val add : x:int => y:int => int[v|v = x + y] */\nlet add = (x, y) => {\n x + y\n};\n\n/*@ val main : m:int[v|0<=v] => int[v|0<=v] */\nlet main = (m) => {\n foldn(add, 0, 0, m)\n};\n" }, { "path": "test/L4/pos/foldn01.re", "content": "/*@ qualif Pos(v:int): (0 <= v) */\n/*@ qualif Geq(v:int, n:int): (n <= v) */\n\n/*@ val foldn : ('a => int[?] => 'a) => 'a => i:int[?] => n:int[?] => 'a */\nlet rec foldn = (f, acc, i, n) => {\n let leq = i < n;\n if (leq) {\n let ip = i + 1;\n let accp = f(acc, i);\n foldn(f, accp, ip, n)\n } else {\n acc\n }\n};\n\n/*@ val add : x:int => y:int => int[v|v = x + y] */\nlet add = (x, y) => {\n x + y\n};\n\n/* the zero is an ANF thing as fixpoint kvetches about non-symbol args for kvars sigh */\n/*@ val main : m:int[v|0<=v] => int[v|0<=v] */\nlet main = (m) => {\n let zero = 0;\n foldn(add, zero, zero, m)\n};\n" }, { "path": "test/L4/pos/id00.re", "content": "/*@ val id : 'a => 'a */\nlet id = (x) => { x };\n\n/*@ val check1 : x:int[v|0<=v] => int[v|0<=v] */\nlet check1 = (y) => {\n let res = id(y); \n res\n};\n" }, { "path": "test/L5/neg/append00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val append : xs:list('a) => ys:list('a) => list('a)[v|len v = len(xs) + len(ys)] */\nlet rec append = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => append(t, ys)\n }\n}; \n" }, { "path": "test/L5/neg/cons00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val singleton : 'a => list('a)[v|len v = 10] */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n" }, { "path": "test/L5/neg/head00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n\n/*@ val singleton : 'a => list('a) */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n\n/*@ val head : list('a) => 'a */\nlet head = (xs) => {\n switch(xs){\n | Cons(h,t) => h\n | Nil => diverge(0)\n }\n}; \n\n/*@ val check : x:int[v|0 <= v] => int[v|10 <= v] */ \nlet check = (z) => {\n let l = singleton(z);\n head(l)\n};\n" }, { "path": "test/L5/neg/head01.re", "content": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val head : list('a)[v|len v > 0] => 'a */\nlet head = (xs) => {\n switch(xs){\n | Cons(h, t) => h\n | Nil => impossible(0)\n }\n};\n\n/*@ val singleton : 'a => list('a)[v|len v = 1] */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n\n/*@ val check : x:int => int */ \nlet check = (z) => {\n let l = Nil; \n head(l)\n};\n" }, { "path": "test/L5/neg/isort00.re", "content": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n\n/*@ val insert : x:'a => ys:list('a) => list('a) */ \nlet rec insert = (x, ys) => {\n switch (ys) {\n | Nil => let t = Nil;\n Cons(x, t)\n | Cons(y0, ys') => let cmp = x <= y0;\n if (cmp){\n let tl = Cons(y0, ys');\n Cons(x, tl)\n } else {\n let tl = insert(x, ys');\n Cons(y0, tl)\n }\n }\n};\n\n/*@ val isort : xs:list('a) => list('a)[v|len(v) = len(xs)] */ \nlet rec isort = (xs) => {\n switch (xs){\n | Nil => Nil\n | Cons (h, t) => let ot = isort(t); \n insert(h, ot)\n }\n};\n" }, { "path": "test/L5/neg/isort01.re", "content": "type list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x <= v])) \n ;\n\n/*@ val insert : x:'a => ys:olist('a) => olist('a) */ \nlet rec insert = (x, ys) => {\n switch (ys) {\n | ONil => let t = ONil;\n OCons(x, t)\n | OCons(y0, ys') => let cmp = x > y0;\n if (cmp){\n let tl = OCons(y0, ys');\n OCons(x, tl)\n } else {\n let tl = insert(x, ys');\n OCons(y0, tl)\n }\n }\n};\n\n/*@ val isort : list('a) => olist('a) */ \nlet rec isort = (xs) => {\n switch (xs){\n | Nil => ONil\n | Cons (h, t) => let ot = isort(t); \n insert(h, ot)\n }\n};\n" }, { "path": "test/L5/neg/listSet.re", "content": "/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) =\n | Nil => [v| elts(v) = Set_empty(0)] \n | Cons (x:'a, xs:list('a)) => [v| elts(v) = Set_add(elts(xs), x)]\n ;\n\n/*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(xs))] */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};\n" }, { "path": "test/L5/neg/nil00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val singleton : 'a => list('a)[v|len v = 1] */\nlet singleton = (x) => {\n let t = Nil;\n t\n};\n" }, { "path": "test/L5/neg/olist00.re", "content": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val bar : apple:int => horse: olist(int) => olist(int) */\nlet bar = (apple, horse) => {\n OCons (apple, horse)\n};\n" }, { "path": "test/L5/neg/olist01.re", "content": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val foo : n:int => olist(int) */\nlet foo = (n) => {\n let n0 = n + 1;\n let n1 = n;\n let l2 = ONil;\n let l1 = OCons(n1, l2);\n let l0 = OCons(n0, l1);\n l0\n};\n" }, { "path": "test/L5/neg/olist02.re", "content": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val mkOList : lo:int => hi:int => olist(int[v|lo <= v && v < hi]) */\nlet rec mkOList = (lo, hi) => {\n let leq = lo < hi;\n if (leq) {\n let lo' = lo + 1;\n let tl = mkOList(lo', hi);\n OCons(lo', tl)\n } else {\n ONil\n }\n};\n" }, { "path": "test/L5/neg/single00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val singleton : int => list(int[v|0 <= v]) */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n" }, { "path": "test/L5/neg/tail01.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val tail: zs:list('a)[v|len v > 0] => list('a)[v|len v = len(zs) - 2] */\nlet tail = (zs) => {\n switch(zs){\n | Cons(h, t) => t\n | Nil => impossible(0)\n }\n};\n" }, { "path": "test/L5/neg/tuple00.re", "content": "\ntype coord = \n | C (x:int, y:int[v|x < v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val mk : n:int => coord */\nlet mk = (n) => { \n let n1 = n + 1;\n C(n1, n1) \n};\n\n/*@ val check : m:int => int */\nlet check = (m) => {\n let p = mk(m);\n switch (p){\n | C(px, py) => let ok = px < py;\n cassert(ok)\n }\n};\n" }, { "path": "test/L5/pos/append00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val append : xs:list('a) => ys:list('a) => list('a)[v|len v = len(xs) + len(ys)] */\nlet rec append = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = append(t, ys);\n Cons(h, rest) \n }\n}; " }, { "path": "test/L5/pos/cons00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val singleton : 'a => list('a)[v|len v = 1] */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n" }, { "path": "test/L5/pos/fold_right00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('alice => 'bob => 'bob) => 'bob => list('alice) => 'bob */\nlet rec fold_right = (f, b, xs) => {\n switch (xs) {\n | Nil => b\n | Cons(h, t) => let res = fold_right(f, b, t); \n f(h, res)\n }\n};\n" }, { "path": "test/L5/pos/head00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val singleton : 'a => list('a) */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n\n/*@ val head : list('a) => 'a */\nlet head = (xs) => {\n switch(xs){\n | Cons(h,t) => h\n | Nil => diverge(0)\n }\n}; \n\n/*@ val check : x:int[v|0 <= v] => int[v|0 <= v] */ \nlet check = (z) => {\n let l = singleton(z);\n head(l)\n};" }, { "path": "test/L5/pos/head01.re", "content": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val head : list('a)[v|len v > 0] => 'a */\nlet head = (xs) => {\n switch(xs){\n | Cons(h, t) => h\n | Nil => impossible(0)\n }\n};\n\n/*@ val singleton : 'a => list('a)[v|len v = 1] */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n\n/*@ val check : x:int => int */ \nlet check = (z) => {\n let l = singleton(z);\n head(l)\n};\n" }, { "path": "test/L5/pos/isort00.re", "content": "\n/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n\n/*@ val insert : x:'a => ys:list('a) => list('a)[v|len v = 1 + len(ys)] */ \nlet rec insert = (x, ys) => {\n switch (ys) {\n | Nil => let t = Nil;\n Cons(x, t)\n | Cons(y0, ys') => let cmp = x <= y0;\n if (cmp){\n let tl = Cons(y0, ys');\n Cons(x, tl)\n } else {\n let tl = insert(x, ys');\n Cons(y0, tl)\n }\n }\n};\n\n/*@ val isort : xs:list('a) => list('a)[v|len(v) = len(xs)] */ \nlet rec isort = (xs) => {\n switch (xs){\n | Nil => Nil\n | Cons (h, t) => let ot = isort(t); \n insert(h, ot)\n }\n};" }, { "path": "test/L5/pos/isort01.re", "content": "type list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x <= v])) \n ;\n\n/*@ val insert : x:'a => ys:olist('a) => olist('a) */ \nlet rec insert = (x, ys) => {\n switch (ys) {\n | ONil => let t = ONil;\n OCons(x, t)\n | OCons(y0, ys') => let cmp = x <= y0;\n if (cmp){\n let tl = OCons(y0, ys');\n OCons(x, tl)\n } else {\n let tl = insert(x, ys');\n OCons(y0, tl)\n }\n }\n};\n\n/*@ val isort : list('a) => olist('a) */ \nlet rec isort = (xs) => {\n switch (xs){\n | Nil => ONil\n | Cons (h, t) => let ot = isort(t); \n insert(h, ot)\n }\n};" }, { "path": "test/L5/pos/listSet.re", "content": "/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) =\n | Nil => [v| elts(v) = Set_empty(0)] \n | Cons (x:'a, xs:list('a)) => [v| elts(v) = Set_add(elts(xs), x)]\n ;\n\n/*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(ys))] */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};\n" }, { "path": "test/L5/pos/nil00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val emptylist : 'a => list('a)[v|len v = 0] */\nlet emptylist = (x) => {\n let t = Nil;\n t\n};\n" }, { "path": "test/L5/pos/olist00.re", "content": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val bar : apple:int => horse: olist(int[v|apple < v]) => olist(int) */\nlet bar = (apple, horse) => {\n OCons(apple, horse)\n};\n" }, { "path": "test/L5/pos/olist01.re", "content": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val foo : n:int => olist(int) */\nlet foo = (n) => {\n let n0 = n;\n let n1 = n0 + 1;\n let l2 = ONil;\n let l1 = OCons(n1, l2);\n let l0 = OCons(n0, l1);\n l0\n};\n" }, { "path": "test/L5/pos/olist02.re", "content": "\ntype olist('a) =\n | ONil\n | OCons (x:'a, xs:olist('a[v| x < v])) \n ;\n\n/*@ val mkOList : lo:int => hi:int => olist(int[v|lo <= v && v < hi]) */\nlet rec mkOList = (lo, hi) => {\n let leq = lo < hi;\n if (leq) {\n let lo' = lo + 1;\n let tl = mkOList(lo', hi);\n OCons(lo, tl)\n } else {\n ONil\n }\n};" }, { "path": "test/L5/pos/single00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val singleton : int[v|0 <= v] => list(int[v|0 <= v]) */\nlet singleton = (x) => {\n let t = Nil;\n Cons(x, t)\n};\n" }, { "path": "test/L5/pos/tail01.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val tail: zs:list('a)[v|len v > 0] => list('a)[v|len v = len(zs) - 1] */\nlet tail = (zs) => {\n switch(zs){\n | Cons(h, t) => t\n | Nil => impossible(0)\n }\n};" }, { "path": "test/L5/pos/tuple00.re", "content": "\ntype coord = \n | C (x:int, y:int[v|x < v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => { \n 0 \n};\n\n/*@ val mk : n:int => coord */\nlet mk = (n) => { \n let n1 = n + 1;\n C(n, n1) \n};\n\n/*@ val check : m:int => int */\nlet check = (m) => {\n let p = mk(m);\n switch (p){\n | C(px, py) => let ok = px < py;\n cassert(ok)\n }\n};\n" }, { "path": "test/L6/neg/deptup00.re", "content": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val check2 : x:int => pair(int, int)((x1:int, x2:int) => x1 > x2) */ \nlet check2 = (x) => {\n let y = x + 1;\n MkPair(x, y)\n};\n" }, { "path": "test/L6/neg/isort02.re", "content": "type list('a)(p : 'a => 'a => bool) =\n | Nil\n | Cons(x:'a, list('a[v|p x v])((x1:'a, x2:'a) => p x1 x2))\n ;\n\n/*@ val insert : x:'a => ys:list('a)((u1:'a, u2:'a) => u1 <= u2) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ \nlet rec insert = (x, ys) => {\n switch (ys) {\n | Nil => let t = Nil;\n Cons(x, t)\n | Cons(y0, ys') => let cmp = y0 <= x;\n if (cmp){\n let tl = Cons(y0, ys');\n Cons(x, tl)\n } else {\n let tl = insert(x, ys');\n Cons(y0, tl)\n }\n }\n};\n\n/*@ val isort : list('a)((u1:'a, u2:'a) => true) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ \nlet rec isort = (xs) => {\n switch (xs){\n | Nil => Nil\n | Cons (h, t) => let ot = isort(t); \n insert(h, ot)\n }\n};\n" }, { "path": "test/L6/neg/maxint1.re", "content": "/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val test1 : a:int[v|0 < v] => b:int[v|0 <= v] => int[v|0 < v] */\nlet test1 = (a, b) => {\n maxInt(a, b)\n};\n\n" }, { "path": "test/L6/neg/maxint2.re", "content": "/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val test2 : a:int[v|v < 0] => b:int[v|v <= 0] => int[v|v < 0] */\nlet test2 = (a, b) => {\n maxInt(a, b)\n};\n" }, { "path": "test/L6/neg/maxlist.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */\nlet rec fold_right = (f, b, xs) => {\n switch (xs) {\n | Nil => b\n | Cons(h, t) => let res = fold_right(f, b, t); \n f(h, res)\n }\n};\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val maxInts : forall (quxx: int => bool). list(int[v| quxx v]) => int[v| quxx v] */ \nlet maxInts = (xs) => {\n switch (xs){\n | Cons(h, t) => let maxInt_inst = maxInt; \n fold_right(maxInt_inst, h, t)\n | Nil => diverge(0)\n }\n};\n\n/*@ val maxPoss : list(int[v|0 <= v]) => int[v|0 < v] */ \nlet maxPoss = (xs) => {\n maxInts(xs)\n};\n\n/*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ \nlet maxNegs = (xs) => {\n maxInts(xs)\n};\n" }, { "path": "test/L6/neg/maxlist00_1.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/* val maxInts : forall (p : int => bool). int[v| p v] => list(int[v| p v]) => int[v| p v] */ \n/*@ val maxInts : int => list(int) => int */ \nlet rec maxInts = (cur, xs) => {\n switch (xs) {\n | Cons(h, t) => let newCur = maxInt(cur, h); \n maxInts(newCur, t)\n | Nil => (cur)\n }\n};\n\n/*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ \nlet maxPoss = (xs) => {\n maxInts(0, xs)\n};\n" }, { "path": "test/L6/neg/maxlist00_2.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/* val maxInts : forall (p : int => bool). int[v| p v] => list(int[v| p v]) => int[v| p v] */ \n/*@ val maxInts : int => list(int) => int */ \nlet rec maxInts = (cur, xs) => {\n switch (xs) {\n | Cons(h, t) => let newCur = maxInt(cur, h); \n maxInts(newCur, t)\n | Nil => (cur)\n }\n};\n\n/*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ \nlet maxNegs = (xs) => {\n maxInts(0, xs)\n};" }, { "path": "test/L6/neg/maxlist01.re", "content": "/*@ qualif Geq(v:int, n:int): (n <= v) */\n/*@ qualif AbsPred(v:int, f:int => bool): (f v) */\n\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */\nlet rec fold_right = (f, b, xs) => {\n switch (xs) {\n | Nil => b\n | Cons(h, t) => let res = fold_right(f, b, t); \n f(h, res)\n }\n};\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val maxInts : forall (quxx: int => bool). list(int[v| quxx v]) => int[v| quxx v] */ \nlet maxInts = (xs) => {\n switch (xs){\n | Cons(h, t) => let maxInt_inst = maxInt;\n fold_right(maxInt_inst, h, t)\n | Nil => diverge(0)\n }\n};\n\n/*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ \nlet maxPoss = (xs) => {\n maxInts(xs)\n};\n\n/*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ \nlet maxNegs = (xs) => {\n maxInts(xs)\n};" }, { "path": "test/L6/pos/apply00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */\nlet rec fold_right = (f, b, xs) => {\n switch (xs) {\n | Nil => b\n | Cons(h, t) => let res = fold_right(f, b, t); \n f(h, res)\n }\n};\n" }, { "path": "test/L6/pos/deptup00.re", "content": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val check1 : x:int => pair(int, int)((x1:int, x2:int) => x1 < x2) */ \nlet check1 = (x) => {\n let y = x + 1;\n MkPair(x, y)\n};\n\n/*@ val check2 : x:int => pair(int, int)((x1:int, x2:int) => x1 > x2) */ \nlet check2 = (x) => {\n let y = x + 1;\n MkPair(y, x)\n};\n" }, { "path": "test/L6/pos/deptup000.re", "content": "type pair()(pp : int => int => bool) =\n | MkPair(x:int, y:int[v|pp x v])\n ;\n\n/*@ val check1 : x:int => pair()((el1:int, el2:int) => el1 < el2) */ \nlet check1 = (x) => {\n let y = x + 1;\n MkPair(x, y)\n};\n" }, { "path": "test/L6/pos/deptup001.re", "content": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val check1 : x:int => pair(int, int)((x1:int, x2:int) => x1 < x2) */ \nlet check1 = (x) => {\n let y = x + 1;\n MkPair(x, y)\n};\n" }, { "path": "test/L6/pos/deptup002.re", "content": "type pair() =\n | MkPair(x:int, y:int[v|x < v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => {\n 0\n};\n\n/*@ val check1 : pair() => int */ \nlet check1 = (p) => {\n switch (p){\n | MkPair(z1, z2) => let cond = z1 < z2;\n cassert(cond) \n }\n};" }, { "path": "test/L6/pos/deptup002a.re", "content": "type pair()(zog : int => int => bool) =\n | MkPair(x:int, y:int[v|zog x v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => {\n 0\n};\n\n/*@ val check1 : pair()((x1:int, x2:int) => x1 < x2) => int */ \nlet check1 = (p) => {\n switch (p){\n | MkPair(z1, z2) => let cond = z1 < z2;\n cassert(cond) \n }\n};" }, { "path": "test/L6/pos/deptup003.re", "content": "type pair('a, 'b)(zog : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|zog x v])\n ;\n\n/*@ val cassert : bool[b|b] => int */\nlet cassert = (b) => {\n 0\n};\n\n/*@ val check1 : pair(int, int)((x1:int, x2:int) => x1 < x2) => int */ \nlet check1 = (p) => {\n switch (p){\n | MkPair(z1, z2) => let cond = z1 < z2;\n cassert(cond) \n }\n};\n" }, { "path": "test/L6/pos/deptup01.re", "content": "type pair('a, 'b)(p : 'a => 'b => bool) =\n | MkPair(x:'a, y:'b[v|p x v])\n ;\n\n/*@ val myTuple: junk:int => pair(int[v|0 < v], int[v|v < 0])((u:int, v:int) => u + v == 0) */\nlet myTuple = (junk) => {\n let x0 = 5;\n let y0 = 0-5;\n MkPair(x0, y0)\n};\n" }, { "path": "test/L6/pos/isort02.re", "content": "type list('a)(p : 'a => 'a => bool) =\n | Nil\n | Cons(x:'a, list('a[v|p x v])((x1:'a, x2:'a) => p x1 x2))\n ;\n\n/*@ val insert : x:'a => ys:list('a)((u1:'a, u2:'a) => u1 <= u2) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ \nlet rec insert = (x, ys) => {\n switch (ys) {\n | Nil => let t = Nil;\n Cons(x, t)\n | Cons(y0, ys') => let cmp = x <= y0;\n if (cmp){\n let tl = Cons(y0, ys');\n Cons(x, tl)\n } else {\n let tl = insert(x, ys');\n Cons(y0, tl)\n }\n }\n};\n\n/*@ val isort : list('a)((u1:'a, u2:'a) => true) => list('a)((u1:'a, u2:'a) => u1 <= u2) */ \nlet rec isort = (xs) => {\n switch (xs){\n | Nil => Nil\n | Cons (h, t) => let ot = isort(t); \n insert(h, ot)\n }\n};" }, { "path": "test/L6/pos/maxint.re", "content": "/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val test1 : a:int[v|0 < v] => b:int[v|0 < v] => int[v|0 < v] */\nlet test1 = (a, b) => {\n maxInt(a, b)\n};\n\n/*@ val test2 : a:int[v|v < 0] => b:int[v|v < 0] => int[v|v < 0] */\nlet test2 = (a, b) => {\n maxInt(a, b)\n};" }, { "path": "test/L6/pos/maxlist00.re", "content": "\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val maxInts : forall (p : int => bool). int[v| p v] => list(int[v| p v]) => int[v| p v] */ \nlet rec maxInts = (cur, xs) => {\n switch (xs) {\n | Cons(h, t) => let newCur = maxInt(cur, h); \n maxInts(newCur, t)\n | Nil => (cur)\n }\n};\n\n/*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ \nlet maxPoss = (xs) => {\n maxInts(0, xs)\n};\n\n/*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ \nlet maxNegs = (xs) => {\n maxInts(0, xs)\n};" }, { "path": "test/L6/pos/maxlist01.re", "content": "/*@ qualif Geq(v:int, n:int): (n <= v) */\n/*@ qualif AbsPred(v:int, f:int => bool): (f v) */\n\ntype list('a) =\n | Nil\n | Cons('a, list('a))\n ;\n\n/*@ val fold_right : ('a => 'b => 'b) => 'b => list('a) => 'b */\nlet rec fold_right = (f, b, xs) => {\n switch (xs) {\n | Nil => b\n | Cons(h, t) => let res = fold_right(f, b, t); \n f(h, res)\n }\n};\n\n/*@ val maxInt : forall (p : int => bool). x:int[v|p v] => y:int[v|p v] => int[v|p v] */\nlet maxInt = (x, y) => {\n let b = x < y;\n if (b){\n y\n } else {\n x\n }\n};\n\n/*@ val maxInts : forall (quxx: int => bool). list(int[v| quxx v]) => int[v| quxx v] */ \nlet maxInts = (xs) => {\n switch (xs){\n | Cons(h, t) => let maxInt_inst = maxInt;\n fold_right(maxInt_inst, h, t)\n | Nil => diverge(0)\n }\n};\n\n/*@ val maxPoss : list(int[v|0 <= v]) => int[v|0<=v] */ \nlet maxPoss = (xs) => {\n maxInts(xs)\n};\n\n/*@ val maxNegs : list(int[v|v<=0]) => int[v|v<=0] */ \nlet maxNegs = (xs) => {\n maxInts(xs)\n};" }, { "path": "test/L6/pos/maxpoly.re", "content": "/*@ val silly : forall (p : 'a => bool). x:'a[v|p v] => 'a[v|p v] */\nlet silly = (x) => {\n x\n};\n\n/*@ val test1 : a:int[v|0 < v] => int[v|0 < v] */\nlet test1 = (apple) => {\n silly(apple)\n};\n\n" }, { "path": "test/L6/pos/plaintup00.re", "content": "type pair('a, 'b) =\n | MkPair(x:'a, y:'b)\n ;\n\n/*@ val myTuple: junk:int => pair(int[v|0 < v], int[v|v < 0]) */\nlet myTuple = (junk) => {\n let x0 = 5;\n let y0 = 0-5;\n MkPair(x0, y0)\n};\n" }, { "path": "test/L7/neg/ack.re", "content": "/*@ val ack : m:int[v|0 <= v] => n:int[v|0 <= v] => int / m, n */\nlet rec ack = (m, n) => {\n let condm = m == 0;\n let condn = n == 0;\n if (condm) { \n n + 1 \n } else {\n let m1 = m - 1;\n if (condn) { \n ack (m1, 1) \n } else {\n let n1 = n - 1;\n let r = ack(m, n1);\n ack (m1, r)\n }\n }\n};\n" }, { "path": "test/L7/neg/list00.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) > 0] =\n | Nil => [v| len(v) = 0] \n | Cons (x:'a, xs:list('a)) => [v| len(v) = 1 + len(xs)]\n ;\n\n/*@ val app : xs:list('a) => list('a) => list('a) / len(xs) */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};\n" }, { "path": "test/L7/neg/listSet.re", "content": "/*@ measure len : list('a) => int */\n/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len(v) = 0 && elts(v) = Set_empty(0)] \n | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs) && elts(v) = Set_add(elts(xs), x)]\n ;\n\n/*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(ys))] / len(ys) */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};\n" }, { "path": "test/L7/neg/range.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val range : i:int => j:int => list(int) / (j - i) */\nlet rec range = (i, j) => {\n let cond = (i == j);\n if (cond) {\n let i1 = i + 1;\n let tl = range(i1, j);\n Cons(i, tl)\n } else {\n Nil\n }\n};\n" }, { "path": "test/L7/neg/sum.re", "content": "/*@ val sum : n:int => int[v|0 <= v] / n */\nlet rec sum = (n) => {\n let cond = n == 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n};" }, { "path": "test/L7/neg/sumAcc.re", "content": "/*@ val sumAcc : total:int => n:int => int / total */\nlet rec sumAcc = (total, n) => {\n let cond = n <= 0;\n if (cond) {\n total\n } else {\n let n1 = n - 1;\n let tot1 = total + n;\n sumAcc(tot1, n1)\n }\n};" }, { "path": "test/L7/pos/ack.re", "content": "/*@ val ack : m:int[v|0 <= v] => n:int[v|0 <= v] => int[v|0 <= v] / m, n */\nlet rec ack = (m, n) => {\n let condm = m == 0;\n let condn = n == 0;\n if (condm) { \n n + 1 \n } else {\n let m1 = m - 1;\n if (condn) { \n ack (m1, 1) \n } else {\n let n1 = n - 1;\n let r = ack(m, n1);\n ack (m1, r)\n }\n }\n};\n" }, { "path": "test/L7/pos/append.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| len(v) = 0]\n | Cons (x:'a, xs:list('a)) => [v| len(v) = 1 + len(xs)]\n ;\n\n/*@ val append : xs:list('a) => list('a) => list('a) / len(xs) */\nlet rec append = (xs, ys) => {\n switch (xs) {\n | Nil => ys\n | Cons(h, t) => let rest = append(t, ys);\n Cons(h, rest)\n }\n};\n" }, { "path": "test/L7/pos/braid.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) [v| len(v) >= 0] =\n | Nil => [v| len(v) = 0] \n | Cons (x:'a, xs:list('a)) => [v| len(v) = 1 + len(xs) ]\n ;\n\n/*@ val braid : xs:list('a) => ys:list('a) => list('a) / len(xs) + len(ys) */\nlet rec braid = (xs, ys) => {\n switch (xs) {\n | Nil => ys\n | Cons (x, xs') => { \n let tl = braid(ys, xs'); \n Cons(x, tl)\n }\n }\n};\n" }, { "path": "test/L7/pos/listSet.re", "content": "/*@ measure len : list('a) => int */\n/*@ measure elts : list('a) => Set_Set('a) */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len(v) = 0 && elts(v) = Set_empty(0)] \n | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs) && elts(v) = Set_add(elts(xs), x)]\n ;\n\n/*@ val app : xs:list('a) => ys:list('a) => list('a)[v|elts(v) = Set_cup(elts(xs), elts(ys))] / len(xs) */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};" }, { "path": "test/L7/pos/range.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) =\n | Nil => [v| len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| len v = 1 + len(xs)]\n ;\n\n/*@ val range : i:int => j:int => list(int) / (j - i) */\nlet rec range = (i, j) => {\n let cond = i < j;\n if (cond) {\n let i1 = i + 1;\n let tl = range(i1, j);\n Cons(i, tl)\n } else {\n Nil\n }\n};\n" }, { "path": "test/L7/pos/sum.re", "content": "/*@ val sum : n:int => int[v|0 <= v] / n */\nlet rec sum = (n) => {\n let cond = n <= 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n};" }, { "path": "test/L7/pos/sumAcc.re", "content": "/*@ val sumAcc : total:int => n:int => int / n */\nlet rec sumAcc = (total, n) => {\n let cond = n <= 0;\n if (cond) {\n total\n } else {\n let n1 = n - 1;\n let tot1 = total + n;\n sumAcc(tot1, n1)\n }\n};" }, { "path": "test/L7/pos/sumNat.re", "content": "/*@ val sum : n:int[v|0 <= v] => int[v|0 <= v] / n */\nlet rec sum = (n) => {\n let cond = n == 0;\n if (cond) {\n 0\n } else {\n let n1 = n-1;\n let t1 = sum(n1);\n n + t1\n }\n};" }, { "path": "test/L8/neg/append.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len v = 0] \n | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len v = 1 + len(xs)]\n ;\n\n/*@ reflect app : xs:list('a) => list('a) => list('a) / len(xs) */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};\n\n/*@ 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))))] */\nlet app_12_34 = (x) => {\n 0\n};\n\n/*@ val app_assoc : xs:list('a) => ys:list('a) => zs:list('a) => \n int[v|app(app(xs, ys), zs) = app(xs, app(ys, zs))] / len(xs) \n */\nlet rec app_assoc = (xs, ys, zs) => {\n switch (xs) {\n | Nil => 0\n | Cons(x, xs') => app_assoc(xs', ys, zs)\n }\n};\n" }, { "path": "test/L8/neg/listSet.re", "content": "/*@ measure len : list('a) => int */\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len(v) = 0] \n | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs)]\n ;\n\n/*@ reflect app : xs:list('a) => list('a) => list('a) / len(xs) */\nlet rec app = (xs, ys) => {\n switch (xs) {\n | Nil => ys \n | Cons(h, t) => let rest = app(t, ys);\n Cons(h, rest) \n }\n};\n\n/*@ reflect rev : xs:list('a) => list('a) / len(xs) */\nlet rec rev = (xs) => {\n switch (xs) {\n | Nil => Nil\n | Cons(h, t) => let rest = rev(t);\n let n0 = Nil;\n let hl = Cons(h, n0);\n app(rest, hl) \n }\n};\n\n/*@ reflect elts : l:list('a) => Set_Set('a) / len(l) */\nlet rec elts = (l) => {\n switch (l) {\n | Nil => Set_empty(0)\n | Cons(h, t) => let rest = elts(t); \n Set_add(rest, h)\n }\n};\n\n/*@ val app_elts : xs:list('a) => ys:list('a) => \n int[v|elts(app(xs, ys)) = Set_cup(elts(xs), elts(ys))] / len(xs) \n */\nlet rec app_elts = (xs, ys) => {\n switch (xs) {\n | Nil => 0\n | Cons(x, xs') => app_elts(xs', ys)\n }\n};\n\n/*@ val rev_elts : xs:list('a) => int[v|elts(rev(xs)) = elts(xs)] / len(xs) \n */\nlet rec rev_elts = (xs) => {\n switch (xs) {\n | Nil => 0\n | Cons(h, t) => let rest = rev(t);\n let n0 = Nil;\n let hl = Cons(h, n0);\n let pf1 = rev_elts(t); \n 0\n }\n};\n" }, { "path": "test/L8/neg/sum.re", "content": "/*@ reflect sum : n:int => int / n */\nlet rec sum = (n) => { \n let base = n <= 0;\n if (base) {\n 0\n } else {\n let n1 = n - 1;\n let t1 = sum(n1);\n n + t1\n }\n};\n\n/*@ val sum_3_eq_6 : int => int[v| sum(2) = 6] */\nlet sum_3_eq_6 = (x) => {\n 0\n};\n\n/*@ val thm_sum : n:int[v| 0 <= v] => int[v| 2 * sum(n) = n * (n+1)] / n */\nlet rec thm_sum = (n) => {\n let base = n <= 0;\n if (base) {\n 0\n } else {\n let n1 = n - 1;\n thm_sum(n1)\n }\n};\n\n" }, { "path": "test/L8/pos/adttup00.re", "content": "type pair('a, 'b) =\n | MkPair(x:'a, y:'b) => [v|v = MkPair(x, y)]\n ;\n\n/*@ val myTuple: junk:int => pair(int, int)[v| v = MkPair(5, -5)] */\nlet myTuple = (junk) => {\n let x0 = 5;\n let y0 = 0-5;\n MkPair(x0, y0)\n};\n" }, { "path": "test/L8/pos/append.re", "content": "/*@ measure len : list('a) => int */\n\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len v = 0]\n | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len v = 1 + len(xs)]\n ;\n\n/*@ reflect append : xs:list('a) => list('a) => list('a) / len(xs) */\nlet rec append = (xs, ys) => {\n switch (xs) {\n | Nil => ys\n | Cons(h, t) => let rest = append(t, ys);\n Cons(h, rest)\n }\n};\n\n/*@ 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))))] */\nlet append_12_34 = (x) => {\n 0\n};\n\n/*@ val append_assoc : xs:list('a) => ys:list('a) => zs:list('a) =>\n int[v|append(append(xs, ys), zs) = append(xs, append(ys, zs))] / len(xs)\n */\nlet rec append_assoc = (xs, ys, zs) => {\n switch (xs) {\n | Nil => 0\n | Cons(x, xs') => append_assoc(xs', ys, zs)\n }\n};\n" }, { "path": "test/L8/pos/listSet.re", "content": "\n\n\n/*@ measure len : list('a) => int */\ntype list('a) [v|len(v) >= 0] =\n | Nil => [v| v = Nil && len(v) = 0]\n | Cons (x:'a, xs:list('a)) => [v| v = Cons(x, xs) && len (v) = 1 + len(xs)]\n ;\n\n/*@ reflect append : xs:list('a) => list('a) => list('a) / len(xs) */\nlet rec append = (xs, ys) => {\n switch (xs) {\n | Nil => ys\n | Cons(h, t) => let rest = append(t, ys);\n Cons(h, rest)\n }\n};\n\n/*@ reflect rev : xs:list('a) => list('a) / len(xs) */\nlet rec rev = (xs) => {\n switch (xs) {\n | Nil => Nil\n | Cons(h, t) => let rest = rev(t);\n let n0 = Nil;\n let hl = Cons(h, n0);\n append(rest, hl)\n }\n};\n\n/*@ reflect elts : l:list('a) => Set_Set('a) / len(l) */\nlet rec elts = (l) => {\n switch (l) {\n | Nil => Set_empty(0)\n | Cons(h, t) => let rest = elts(t);\n Set_add(rest, h)\n }\n};\n\n/*@ val append_elts : xs:list('a) => ys:list('a) =>\n int[v|elts(append(xs, ys)) = Set_cup(elts(xs), elts(ys))] / len(xs)\n */\nlet rec append_elts = (xs, ys) => {\n switch (xs) {\n | Nil => 0\n | Cons(x, xs') => append_elts(xs', ys)\n }\n};\n\n\n// /*@ val rev_elts : xs:list('a) => int[v|elts(rev(xs)) = elts(xs)] / len(xs)\n// */\n// let rec rev_elts = (xs) => {\n// switch (xs) {\n// | Nil => 0\n// | Cons(h, t) => let rest = rev(t);\n// let n0 = Nil;\n// let hl = Cons(h, n0);\n// let pf1 = rev_elts(t);\n// let pf2 = append_elts(rest, hl);\n// 0\n// }\n// };" }, { "path": "test/L8/pos/poly.re", "content": "/*@ reflect cheq : 'a => 'a => bool / 0 */\nlet rec cheq = (x, y) => { \n x == y \n};\n\n/*@ val test_int : int => int[v| cheq(2, 2) ] */\nlet test_int = (x) => {\n 0\n};\n\n/*@ val test_bool : int => int[v| cheq(true, true) ] */\nlet test_bool = (x) => {\n 0\n};\n\n\n\n" }, { "path": "test/L8/pos/sum.re", "content": "/*@ reflect sum : n:int => int / n */\nlet rec sum = (n) => { \n let base = n <= 0;\n if (base) {\n 0\n } else {\n let n1 = n - 1;\n let t1 = sum(n1);\n n + t1\n }\n};\n\n/*@ val sum_3_eq_6 : int => int[v| sum(3) = 6] */\nlet sum_3_eq_6 = (x) => {\n 0\n};\n\n/*@ val thm_sum : n:int[v| 0 <= v] => int[v| 2 * sum(n) = n * (n+1)] / n */\nlet rec thm_sum = (n) => {\n let base = n <= 0;\n if (base) {\n 0\n } else {\n let n1 = n - 1;\n thm_sum(n1)\n }\n};\n\n" }, { "path": "test/Spec.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\nmodule Main where\n\nimport qualified Control.Concurrent.STM as STM\nimport qualified Data.Functor.Compose as Functor\nimport qualified Data.IntMap as IntMap\n-- import qualified Data.Map as Map\nimport qualified Control.Monad.State as State\nimport Control.Monad.Trans.Class (lift)\n\nimport Data.Char\nimport Data.Maybe (fromMaybe)\nimport Data.Monoid (Sum(..), (<>))\nimport Control.Applicative\nimport System.Directory\nimport System.Exit\nimport System.FilePath\n-- import System.Environment\nimport System.IO\nimport System.IO.Error\nimport System.Process\nimport Text.Printf\n\nimport Test.Tasty\nimport Test.Tasty.HUnit\nimport Test.Tasty.Ingredients.Rerun\n-- import Test.Tasty.Options\nimport Test.Tasty.Runners\nimport Test.Tasty.Runners.AntXML\nimport Paths_sprite\n\nmain :: IO ()\nmain = defaultMainWithIngredients [testRunner] =<< allTests\n\nallTests = group \"Tests\"\n [ l1Tests\n , l2Tests\n , l3Tests\n , l4Tests\n , l5Tests\n , l6Tests\n , l8Tests\n ]\n\nl1Tests :: IO TestTree\nl1Tests = group \"L1\" $ langTests \"L1\" 1\n\nl2Tests :: IO TestTree\nl2Tests = group \"L2\" $ langTests \"L1\" 2\n ++ langTests \"L2\" 2\n\nl3Tests :: IO TestTree\nl3Tests = group \"L3\" $ langTests \"L1\" 3\n ++ langTests \"L2\" 3\n ++ langTests \"L3\" 3\n\nl4Tests :: IO TestTree\nl4Tests = group \"L4\" $ langTests \"L1\" 4\n ++ langTests \"L2\" 4\n ++ langTests \"L3\" 4\n ++ langTests \"L4\" 4\n\nl5Tests :: IO TestTree\nl5Tests = group \"L5\" $ langTests \"L1\" 5\n ++ langTests \"L2\" 5\n ++ langTests \"L3\" 5\n ++ langTests \"L4\" 5\n ++ langTests \"L5\" 5\n\nl6Tests :: IO TestTree\nl6Tests = group \"L6\" $ langTests \"L1\" 6\n ++ langTests \"L2\" 6\n ++ langTests \"L3\" 6\n ++ langTests \"L4\" 6\n ++ langTests \"L5\" 6\n ++ langTests \"L6\" 6\n\nl8Tests :: IO TestTree\nl8Tests = group \"L8\" $ langTests \"L7\" 8\n ++ langTests \"L8\" 8\n\n\nlangTests :: String -> Int -> [IO TestTree]\nlangTests lang n =\n [ testGroup (name \"pos\") <$> dirTests (spriteCmd n) (dir \"pos\") [] ExitSuccess\n , testGroup (name \"neg\") <$> dirTests (spriteCmd n) (dir \"neg\") [] (ExitFailure 1)\n ]\n where\n name :: String -> String\n name k = printf \"%s-%s-%d\" k lang n\n dir k = \"test\" lang k\n\ntestRunner :: Ingredient\ntestRunner = rerunningTests\n [ listingTests\n , combineReporters myConsoleReporter antXMLRunner\n , myConsoleReporter\n ]\n\nmyConsoleReporter :: Ingredient\nmyConsoleReporter = combineReporters consoleTestReporter loggingTestReporter\n\n-- | Combine two @TestReporter@s into one.\n--\n-- Runs the reporters in sequence, so it's best to start with the one\n-- that will produce incremental output, e.g. 'consoleTestReporter'.\ncombineReporters :: Ingredient -> Ingredient -> Ingredient\ncombineReporters (TestReporter opts1 run1) (TestReporter opts2 run2)\n = TestReporter (opts1 ++ opts2) $ \\opts tree -> do\n f1 <- run1 opts tree\n f2 <- run2 opts tree\n return $ \\smap -> f1 smap >> f2 smap\ncombineReporters _ _ = error \"combineReporters needs TestReporters\"\n\n\n---------------------------------------------------------------------------\ndirTests :: TestCmd -> FilePath -> [FilePath] -> ExitCode -> IO [TestTree]\n---------------------------------------------------------------------------\ndirTests testCmd root ignored code = do\n files <- walkDirectory root\n let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ]\n return $ mkTest testCmd code root <$> tests\n\nisTest :: FilePath -> Bool\nisTest f = takeExtension f `elem` [\".re\"]\n\n---------------------------------------------------------------------------\nmkTest :: TestCmd -> ExitCode -> FilePath -> FilePath -> TestTree\n---------------------------------------------------------------------------\nmkTest testCmd code dir file\n = testCase file $\n if test `elem` knownToFail\n then do\n printf \"%s is known to fail: SKIPPING\" test\n assertEqual \"\" True True\n else do\n createDirectoryIfMissing True $ takeDirectory log\n bin <- binPath execName\n withFile log WriteMode $ \\h -> do\n let cmd = testCmd bin dir file\n (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h}\n c <- waitForProcess ph\n assertEqual (\"Wrong exit code: \" ++ cmd) code c\n where\n test = dir file\n log = let (d,f) = splitFileName file in dir d \".liquid\" f <.> \"log\"\n\nbinPath :: FilePath -> IO FilePath\nbinPath pkgName = ( pkgName) <$> getBinDir\n\nknownToFail = []\n\n---------------------------------------------------------------------------\n-- | Project specific configuration ---------------------------------------\n---------------------------------------------------------------------------\n\ntype TestCmd = FilePath -> FilePath -> FilePath -> String\n\nexecName :: FilePath\nexecName = \"sprite\"\n\nspriteCmd :: Int -> TestCmd\nspriteCmd n bin dir file = printf \"cd %s && %s %d %s\" dir bin n file\n\n\n----------------------------------------------------------------------------------------\n-- Generic Helpers\n----------------------------------------------------------------------------------------\n\ngroup n xs = testGroup n <$> sequence xs\n\n----------------------------------------------------------------------------------------\nwalkDirectory :: FilePath -> IO [FilePath]\n----------------------------------------------------------------------------------------\nwalkDirectory root\n = do (ds,fs) <- partitionM doesDirectoryExist . candidates =<< (getDirectoryContents root `catchIOError` const (return []))\n (fs++) <$> concatMapM walkDirectory ds\n where\n candidates fs = [root f | f <- fs, not (isExtSeparator (head f))]\n\npartitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a])\npartitionM f = go [] []\n where\n go ls rs [] = return (ls,rs)\n go ls rs (x:xs) = do b <- f x\n if b then go (x:ls) rs xs\n else go ls (x:rs) xs\n\n-- isDirectory :: FilePath -> IO Bool\n-- isDirectory = fmap Posix.isDirectory . Posix.getFileStatus\n\nconcatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]\nconcatMapM _ [] = pure []\nconcatMapM f (x:xs) = (++) <$> f x <*> concatMapM f xs\n\n-- -- this is largely based on ocharles' test runner at\n-- -- https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs#L65\n-- loggingTestReporter :: Ingredient\n-- loggingTestReporter = TestReporter [] $ \\opts tree -> Just $ \\smap -> do\n-- let\n-- runTest _ testName _ = Traversal $ Functor.Compose $ do\n-- i <- State.get\n\n-- summary <- lift $ STM.atomically $ do\n-- status <- STM.readTVar $\n-- fromMaybe (error \"Attempted to lookup test by index outside bounds\") $\n-- IntMap.lookup i smap\n\n-- let mkSuccess time = [(testName, time, True)]\n-- mkFailure time = [(testName, time, False)]\n\n-- case status of\n-- -- If the test is done, generate a summary for it\n-- Done result\n-- | resultSuccessful result\n-- -> pure (mkSuccess (resultTime result))\n-- | otherwise\n-- -> pure (mkFailure (resultTime result))\n-- -- Otherwise the test has either not been started or is currently\n-- -- executing\n-- _ -> STM.retry\n\n-- Const summary <$ State.modify (+ 1)\n\n-- runGroup group children = Traversal $ Functor.Compose $ do\n-- Const soFar <- Functor.getCompose $ getTraversal children\n-- pure $ Const $ map (\\(n,t,s) -> (groupn,t,s)) soFar\n\n-- computeFailures :: StatusMap -> IO Int\n-- computeFailures = fmap getSum . getApp . foldMap (\\var -> Ap $\n-- (\\r -> Sum $ if resultSuccessful r then 0 else 1) <$> getResultFromTVar var)\n\n-- getResultFromTVar :: STM.TVar Status -> IO Result\n-- getResultFromTVar var =\n-- STM.atomically $ do\n-- status <- STM.readTVar var\n-- case status of\n-- Done r -> return r\n-- _ -> STM.retry\n\n-- (Const summary, _tests) <-\n-- flip State.runStateT 0 $ Functor.getCompose $ getTraversal $\n-- foldTestTree\n-- trivialFold { foldSingle = runTest, foldGroup = runGroup }\n-- opts\n-- tree\n\n-- return $ \\_elapsedTime -> do\n-- -- get some semblance of a hostname\n-- host <- takeWhile (/='.') . takeWhile (not . isSpace) <$> readProcess \"hostname\" [] []\n-- -- don't use the `time` package, major api differences between ghc 708 and 710\n-- time <- head . lines <$> readProcess \"date\" [\"+%Y-%m-%dT%H-%M-%S\"] []\n-- -- build header\n-- ref <- gitRef\n-- timestamp <- gitTimestamp\n-- epochTime <- gitEpochTimestamp\n-- hash <- gitHash\n-- let hdr = unlines [ref ++ \" : \" ++ hash,\n-- \"Timestamp: \" ++ timestamp,\n-- \"Epoch Timestamp: \" ++ epochTime,\n-- headerDelim,\n-- \"test, time(s), result\"]\n\n\n-- let dir = \"test\" \"logs\" host ++ \"-\" ++ time\n-- let smry = \"test\" \"logs\" \"cur\" \"summary.csv\"\n-- writeFile smry $ unlines\n-- $ hdr\n-- : map (\\(n, t, r) -> printf \"%s, %0.4f, %s\" n t (show r)) summary\n-- -- system $ \"cp -r tests/logs/cur \" ++ dir\n-- (==0) <$> computeFailures smap\n\n\n-- this is largely based on ocharles' test runner at\n-- https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs#L65\nloggingTestReporter :: Ingredient\nloggingTestReporter = TestReporter [] $ \\opts tree -> Just $ \\smap -> do\n let\n runTest _ testName _ = Traversal $ Functor.Compose $ do\n i <- State.get\n\n summary <- lift $ STM.atomically $ do\n status <- STM.readTVar $\n fromMaybe (error \"Attempted to lookup test by index outside bounds\") $\n IntMap.lookup i smap\n\n let mkSuccess time = [(testName, time, True)]\n mkFailure time = [(testName, time, False)]\n\n case status of\n -- If the test is done, generate a summary for it\n Done result\n | resultSuccessful result\n -> pure (mkSuccess (resultTime result))\n | otherwise\n -> pure (mkFailure (resultTime result))\n -- Otherwise the test has either not been started or is currently\n -- executing\n _ -> STM.retry\n\n Const summary <$ State.modify (+ 1)\n\n runGroup _ group' children = Traversal $ Functor.Compose $ do\n Const soFar <- Functor.getCompose $ getTraversal $ mconcat children\n pure $ Const $ map (\\(n,t,s) -> (group' n,t,s)) soFar\n\n computeFailures :: StatusMap -> IO Int\n computeFailures = fmap getSum . getApp . foldMap (\\var -> Ap $\n (\\r -> Sum $ if resultSuccessful r then 0 else 1) <$> getResultFromTVar var)\n\n getResultFromTVar :: STM.TVar Status -> IO Result\n getResultFromTVar var =\n STM.atomically $ do\n status <- STM.readTVar var\n case status of\n Done r -> return r\n _ -> STM.retry\n\n (Const summary, _tests) <-\n flip State.runStateT 0 $ Functor.getCompose $ getTraversal $\n foldTestTree\n trivialFold { foldSingle = runTest, foldGroup = runGroup }\n opts\n tree\n\n return $ \\_elapsedTime -> do\n -- don't use the `time` package, major api differences between ghc 708 and 710\n -- build header\n ref <- gitRef\n timestamp <- gitTimestamp\n epochTime <- gitEpochTimestamp\n hash <- gitHash\n let hdr = unlines [ref ++ \" : \" ++ hash,\n \"Timestamp: \" ++ timestamp,\n \"Epoch Timestamp: \" ++ epochTime,\n headerDelim,\n \"test, time(s), result\"]\n\n let smry = \"test\" \"logs\" \"cur\" \"summary.csv\"\n writeFile smry $ unlines\n $ hdr\n : map (\\(n, t, r) -> printf \"%s, %0.4f, %s\" n t (show r)) summary\n (==0) <$> computeFailures smap\n\n\n\n\ngitTimestamp :: IO String\ngitTimestamp = do\n res <- gitProcess [\"show\", \"--format=\\\"%ci\\\"\", \"--quiet\"]\n return $ filter notNoise res\n\ngitEpochTimestamp :: IO String\ngitEpochTimestamp = do\n res <- gitProcess [\"show\", \"--format=\\\"%ct\\\"\", \"--quiet\"]\n return $ filter notNoise res\n\ngitHash :: IO String\ngitHash = do\n res <- gitProcess [\"show\", \"--format=\\\"%H\\\"\", \"--quiet\"]\n return $ filter notNoise res\n\ngitRef :: IO String\ngitRef = do\n res <- gitProcess [\"show\", \"--format=\\\"%d\\\"\", \"--quiet\"]\n return $ filter notNoise res\n\n-- | Calls `git` for info; returns `\"plain\"` if we are not in a git directory.\ngitProcess :: [String] -> IO String\ngitProcess args = (readProcess \"git\" args []) `catchIOError` const (return \"plain\")\n\nnotNoise :: Char -> Bool\nnotNoise a = a /= '\\\"' && a /= '\\n' && a /= '\\r'\n\nheaderDelim :: String\nheaderDelim = replicate 80 '-'\n" }, { "path": "test/logs/cur/summary.csv", "content": " (HEAD -> bump, origin/bump) : 24d6e7c580595f45e9c53eb128f0e9377fc081b4\nTimestamp: 2024-03-08 23:02:23 -0800\nEpoch Timestamp: 1709967743\n--------------------------------------------------------------------------------\ntest, time(s), result\n\nTests/L1/pos-L1-1/int01.re, 0.5696, True\nTests/L1/pos-L1-1/int00.re, 0.5485, True\nTests/L1/pos-L1-1/inc02.re, 0.5768, True\nTests/L1/pos-L1-1/inc01.re, 0.5684, True\nTests/L1/pos-L1-1/inc00.re, 0.5686, True\nTests/L1/neg-L1-1/int01.re, 0.5739, True\nTests/L1/neg-L1-1/inc02.re, 0.5735, True\nTests/L1/neg-L1-1/inc01.re, 0.5721, True\nTests/L1/neg-L1-1/inc00.re, 0.0389, True\nTests/L2/pos-L1-2/int01.re, 0.0355, True\nTests/L2/pos-L1-2/int00.re, 0.0346, True\nTests/L2/pos-L1-2/inc02.re, 0.0451, True\nTests/L2/pos-L1-2/inc01.re, 0.0457, True\nTests/L2/pos-L1-2/inc00.re, 0.0395, True\nTests/L2/neg-L1-2/int01.re, 0.0341, True\nTests/L2/neg-L1-2/inc02.re, 0.0460, True\nTests/L2/neg-L1-2/inc01.re, 0.0383, True\nTests/L2/neg-L1-2/inc00.re, 0.0445, True\nTests/L2/pos-L2-2/sum00.re, 0.0330, True\nTests/L2/pos-L2-2/abs00.re, 0.0441, True\nTests/L2/pos-L2-2/abs01.re, 0.0482, True\nTests/L2/pos-L2-2/cmp01.re, 0.0327, True\nTests/L2/pos-L2-2/cmp00.re, 0.0339, True\nTests/L2/neg-L2-2/sum00.re, 0.0368, True\nTests/L2/neg-L2-2/abs00.re, 0.0354, True\nTests/L2/neg-L2-2/abs01.re, 0.0471, True\nTests/L2/neg-L2-2/cmp01.re, 0.0433, True\nTests/L2/neg-L2-2/cmp00.re, 0.0458, True\nTests/L3/pos-L1-3/int01.re, 0.0453, True\nTests/L3/pos-L1-3/int00.re, 0.0247, True\nTests/L3/pos-L1-3/inc02.re, 0.0328, True\nTests/L3/pos-L1-3/inc01.re, 0.0346, True\nTests/L3/pos-L1-3/inc00.re, 0.0385, True\nTests/L3/neg-L1-3/int01.re, 0.0347, True\nTests/L3/neg-L1-3/inc02.re, 0.0467, True\nTests/L3/neg-L1-3/inc01.re, 0.0445, True\nTests/L3/neg-L1-3/inc00.re, 0.0339, True\nTests/L3/pos-L2-3/sum00.re, 0.0420, True\nTests/L3/pos-L2-3/abs00.re, 0.0485, True\nTests/L3/pos-L2-3/abs01.re, 0.0481, True\nTests/L3/pos-L2-3/cmp01.re, 0.0456, True\nTests/L3/pos-L2-3/cmp00.re, 0.0333, True\nTests/L3/neg-L2-3/sum00.re, 0.0342, True\nTests/L3/neg-L2-3/abs00.re, 0.0430, True\nTests/L3/neg-L2-3/abs01.re, 0.0449, True\nTests/L3/neg-L2-3/cmp01.re, 0.0444, True\nTests/L3/neg-L2-3/cmp00.re, 0.0357, True\nTests/L3/pos-L3-3/abs02.re, 0.0462, True\nTests/L3/pos-L3-3/abs02-debug.re, 0.0347, True\nTests/L3/pos-L3-3/assert00.re, 0.0349, True\nTests/L3/pos-L3-3/sum01.re, 0.0484, True\nTests/L3/pos-L3-3/abs01.re, 0.0422, True\nTests/L3/neg-L3-3/abs02.re, 0.0485, True\nTests/L3/neg-L3-3/assert00.re, 0.0364, True\nTests/L3/neg-L3-3/sum01.re, 0.0354, True\nTests/L3/neg-L3-3/rebind.re, 0.0355, True\nTests/L3/neg-L3-3/abs02-bad.re, 0.0485, True\nTests/L3/neg-L3-3/abs01.re, 0.0376, True\nTests/L4/pos-L1-4/int01.re, 0.0435, True\nTests/L4/pos-L1-4/int00.re, 0.0257, True\nTests/L4/pos-L1-4/inc02.re, 0.0457, True\nTests/L4/pos-L1-4/inc01.re, 0.0332, True\nTests/L4/pos-L1-4/inc00.re, 0.0331, True\nTests/L4/neg-L1-4/int01.re, 0.0373, True\nTests/L4/neg-L1-4/inc02.re, 0.0357, True\nTests/L4/neg-L1-4/inc01.re, 0.0371, True\nTests/L4/neg-L1-4/inc00.re, 0.0386, True\nTests/L4/pos-L2-4/sum00.re, 0.0461, True\nTests/L4/pos-L2-4/abs00.re, 0.0376, True\nTests/L4/pos-L2-4/abs01.re, 0.0469, True\nTests/L4/pos-L2-4/cmp01.re, 0.0384, True\nTests/L4/pos-L2-4/cmp00.re, 0.0351, True\nTests/L4/neg-L2-4/sum00.re, 0.0336, True\nTests/L4/neg-L2-4/abs00.re, 0.0352, True\nTests/L4/neg-L2-4/abs01.re, 0.0482, True\nTests/L4/neg-L2-4/cmp01.re, 0.0453, True\nTests/L4/neg-L2-4/cmp00.re, 0.0473, True\nTests/L4/pos-L3-4/abs02.re, 0.0488, True\nTests/L4/pos-L3-4/abs02-debug.re, 0.0378, True\nTests/L4/pos-L3-4/assert00.re, 0.0387, True\nTests/L4/pos-L3-4/sum01.re, 0.0469, True\nTests/L4/pos-L3-4/abs01.re, 0.0342, True\nTests/L4/neg-L3-4/abs02.re, 0.0462, True\nTests/L4/neg-L3-4/assert00.re, 0.0409, True\nTests/L4/neg-L3-4/sum01.re, 0.0468, True\nTests/L4/neg-L3-4/rebind.re, 0.0336, True\nTests/L4/neg-L3-4/abs02-bad.re, 0.0445, True\nTests/L4/neg-L3-4/abs01.re, 0.0385, True\nTests/L4/pos-L4-4/id00.re, 0.0354, True\nTests/L4/pos-L4-4/foldn01.re, 0.0501, True\nTests/L4/pos-L4-4/foldn00.re, 0.0436, True\nTests/L4/pos-L4-4/choose01.re, 0.0446, True\nTests/L4/pos-L4-4/choose00.re, 0.0401, True\nTests/L4/neg-L4-4/id00.re, 0.0345, True\nTests/L4/neg-L4-4/foldn01.re, 0.0229, True\nTests/L4/neg-L4-4/foldn00.re, 0.0357, True\nTests/L4/neg-L4-4/choose01.re, 0.0367, True\nTests/L4/neg-L4-4/choose00.re, 0.0484, True\nTests/L5/pos-L1-5/int01.re, 0.0501, True\nTests/L5/pos-L1-5/int00.re, 0.0350, True\nTests/L5/pos-L1-5/inc02.re, 0.0468, True\nTests/L5/pos-L1-5/inc01.re, 0.0327, True\nTests/L5/pos-L1-5/inc00.re, 0.0338, True\nTests/L5/neg-L1-5/int01.re, 0.0371, True\nTests/L5/neg-L1-5/inc02.re, 0.0360, True\nTests/L5/neg-L1-5/inc01.re, 0.0459, True\nTests/L5/neg-L1-5/inc00.re, 0.0413, True\nTests/L5/pos-L2-5/sum00.re, 0.0404, True\nTests/L5/pos-L2-5/abs00.re, 0.0452, True\nTests/L5/pos-L2-5/abs01.re, 0.0463, True\nTests/L5/pos-L2-5/cmp01.re, 0.0461, True\nTests/L5/pos-L2-5/cmp00.re, 0.0460, True\nTests/L5/neg-L2-5/sum00.re, 0.0353, True\nTests/L5/neg-L2-5/abs00.re, 0.0426, True\nTests/L5/neg-L2-5/abs01.re, 0.0433, True\nTests/L5/neg-L2-5/cmp01.re, 0.0368, True\nTests/L5/neg-L2-5/cmp00.re, 0.0468, True\nTests/L5/pos-L3-5/abs02.re, 0.0467, True\nTests/L5/pos-L3-5/abs02-debug.re, 0.0336, True\nTests/L5/pos-L3-5/assert00.re, 0.0421, True\nTests/L5/pos-L3-5/sum01.re, 0.0449, True\nTests/L5/pos-L3-5/abs01.re, 0.0464, True\nTests/L5/neg-L3-5/abs02.re, 0.0419, True\nTests/L5/neg-L3-5/assert00.re, 0.0444, True\nTests/L5/neg-L3-5/sum01.re, 0.0431, True\nTests/L5/neg-L3-5/rebind.re, 0.0489, True\nTests/L5/neg-L3-5/abs02-bad.re, 0.0491, True\nTests/L5/neg-L3-5/abs01.re, 0.0343, True\nTests/L5/pos-L4-5/id00.re, 0.0351, True\nTests/L5/pos-L4-5/foldn01.re, 0.0617, True\nTests/L5/pos-L4-5/foldn00.re, 0.0587, True\nTests/L5/pos-L4-5/choose01.re, 0.0442, True\nTests/L5/pos-L4-5/choose00.re, 0.0479, True\nTests/L5/neg-L4-5/id00.re, 0.0429, True\nTests/L5/neg-L4-5/foldn01.re, 0.0529, True\nTests/L5/neg-L4-5/foldn00.re, 0.0436, True\nTests/L5/neg-L4-5/choose01.re, 0.0319, True\nTests/L5/neg-L4-5/choose00.re, 0.0617, True\nTests/L5/pos-L5-5/tuple00.re, 0.0606, True\nTests/L5/pos-L5-5/olist01.re, 0.0582, True\nTests/L5/pos-L5-5/isort00.re, 0.0723, True\nTests/L5/pos-L5-5/isort01.re, 0.0623, True\nTests/L5/pos-L5-5/listSet.re, 0.0480, True\nTests/L5/pos-L5-5/single00.re, 0.0480, True\nTests/L5/pos-L5-5/olist00.re, 0.0468, True\nTests/L5/pos-L5-5/append00.re, 0.0424, True\nTests/L5/pos-L5-5/head00.re, 0.0476, True\nTests/L5/pos-L5-5/tail01.re, 0.0478, True\nTests/L5/pos-L5-5/head01.re, 0.0479, True\nTests/L5/pos-L5-5/cons00.re, 0.0355, True\nTests/L5/pos-L5-5/olist02.re, 0.0471, True\nTests/L5/pos-L5-5/nil00.re, 0.0343, True\nTests/L5/pos-L5-5/fold_right00.re, 0.0332, True\nTests/L5/neg-L5-5/tuple00.re, 0.0437, True\nTests/L5/neg-L5-5/olist01.re, 0.0468, True\nTests/L5/neg-L5-5/isort00.re, 0.0449, True\nTests/L5/neg-L5-5/isort01.re, 0.0444, True\nTests/L5/neg-L5-5/listSet.re, 0.0495, True\nTests/L5/neg-L5-5/single00.re, 0.0368, True\nTests/L5/neg-L5-5/olist00.re, 0.0354, True\nTests/L5/neg-L5-5/append00.re, 0.0467, True\nTests/L5/neg-L5-5/head00.re, 0.0460, True\nTests/L5/neg-L5-5/tail01.re, 0.0425, True\nTests/L5/neg-L5-5/head01.re, 0.0441, True\nTests/L5/neg-L5-5/cons00.re, 0.0344, True\nTests/L5/neg-L5-5/olist02.re, 0.0490, True\nTests/L5/neg-L5-5/nil00.re, 0.0340, True\nTests/L6/pos-L1-6/int01.re, 0.0320, True\nTests/L6/pos-L1-6/int00.re, 0.0225, True\nTests/L6/pos-L1-6/inc02.re, 0.0449, True\nTests/L6/pos-L1-6/inc01.re, 0.0449, True\nTests/L6/pos-L1-6/inc00.re, 0.0358, True\nTests/L6/neg-L1-6/int01.re, 0.0354, True\nTests/L6/neg-L1-6/inc02.re, 0.0522, True\nTests/L6/neg-L1-6/inc01.re, 0.0512, True\nTests/L6/neg-L1-6/inc00.re, 0.0348, True\nTests/L6/pos-L2-6/sum00.re, 0.0371, True\nTests/L6/pos-L2-6/abs00.re, 0.0433, True\nTests/L6/pos-L2-6/abs01.re, 0.0472, True\nTests/L6/pos-L2-6/cmp01.re, 0.0420, True\nTests/L6/pos-L2-6/cmp00.re, 0.0399, True\nTests/L6/neg-L2-6/sum00.re, 0.0434, True\nTests/L6/neg-L2-6/abs00.re, 0.0407, True\nTests/L6/neg-L2-6/abs01.re, 0.0342, True\nTests/L6/neg-L2-6/cmp01.re, 0.0341, True\nTests/L6/neg-L2-6/cmp00.re, 0.0360, True\nTests/L6/pos-L3-6/abs02.re, 0.0461, True\nTests/L6/pos-L3-6/abs02-debug.re, 0.0456, True\nTests/L6/pos-L3-6/assert00.re, 0.0430, True\nTests/L6/pos-L3-6/sum01.re, 0.0509, True\nTests/L6/pos-L3-6/abs01.re, 0.0501, True\nTests/L6/neg-L3-6/abs02.re, 0.0496, True\nTests/L6/neg-L3-6/assert00.re, 0.0357, True\nTests/L6/neg-L3-6/sum01.re, 0.0496, True\nTests/L6/neg-L3-6/rebind.re, 0.0453, True\nTests/L6/neg-L3-6/abs02-bad.re, 0.0443, True\nTests/L6/neg-L3-6/abs01.re, 0.0445, True\nTests/L6/pos-L4-6/id00.re, 0.0353, True\nTests/L6/pos-L4-6/foldn01.re, 0.0471, True\nTests/L6/pos-L4-6/foldn00.re, 0.0475, True\nTests/L6/pos-L4-6/choose01.re, 0.0364, True\nTests/L6/pos-L4-6/choose00.re, 0.0419, True\nTests/L6/neg-L4-6/id00.re, 0.0435, True\nTests/L6/neg-L4-6/foldn01.re, 0.0362, True\nTests/L6/neg-L4-6/foldn00.re, 0.0440, True\nTests/L6/neg-L4-6/choose01.re, 0.0449, True\nTests/L6/neg-L4-6/choose00.re, 0.0453, True\nTests/L6/pos-L5-6/tuple00.re, 0.0338, True\nTests/L6/pos-L5-6/olist01.re, 0.0493, True\nTests/L6/pos-L5-6/isort00.re, 0.0441, True\nTests/L6/pos-L5-6/isort01.re, 0.0450, True\nTests/L6/pos-L5-6/listSet.re, 0.0453, True\nTests/L6/pos-L5-6/single00.re, 0.0488, True\nTests/L6/pos-L5-6/olist00.re, 0.0363, True\nTests/L6/pos-L5-6/append00.re, 0.0458, True\nTests/L6/pos-L5-6/head00.re, 0.0466, True\nTests/L6/pos-L5-6/tail01.re, 0.0365, True\nTests/L6/pos-L5-6/head01.re, 0.0456, True\nTests/L6/pos-L5-6/cons00.re, 0.0327, True\nTests/L6/pos-L5-6/olist02.re, 0.0454, True\nTests/L6/pos-L5-6/nil00.re, 0.0476, True\nTests/L6/pos-L5-6/fold_right00.re, 0.0359, True\nTests/L6/neg-L5-6/tuple00.re, 0.0362, True\nTests/L6/neg-L5-6/olist01.re, 0.0384, True\nTests/L6/neg-L5-6/isort00.re, 0.0492, True\nTests/L6/neg-L5-6/isort01.re, 0.0488, True\nTests/L6/neg-L5-6/listSet.re, 0.0468, True\nTests/L6/neg-L5-6/single00.re, 0.0445, True\nTests/L6/neg-L5-6/olist00.re, 0.0458, True\nTests/L6/neg-L5-6/append00.re, 0.0473, True\nTests/L6/neg-L5-6/head00.re, 0.0378, True\nTests/L6/neg-L5-6/tail01.re, 0.0398, True\nTests/L6/neg-L5-6/head01.re, 0.0358, True\nTests/L6/neg-L5-6/cons00.re, 0.0430, True\nTests/L6/neg-L5-6/olist02.re, 0.0449, True\nTests/L6/neg-L5-6/nil00.re, 0.0365, True\nTests/L6/pos-L6-6/maxpoly.re, 0.0487, True\nTests/L6/pos-L6-6/deptup003.re, 0.0474, True\nTests/L6/pos-L6-6/deptup00.re, 0.0464, True\nTests/L6/pos-L6-6/deptup002.re, 0.0462, True\nTests/L6/pos-L6-6/apply00.re, 0.0266, True\nTests/L6/pos-L6-6/maxlist00.re, 0.0440, True\nTests/L6/pos-L6-6/deptup001.re, 0.0454, True\nTests/L6/pos-L6-6/maxint.re, 0.0453, True\nTests/L6/pos-L6-6/deptup002a.re, 0.0456, True\nTests/L6/pos-L6-6/maxlist01.re, 0.0619, True\nTests/L6/pos-L6-6/deptup000.re, 0.0339, True\nTests/L6/pos-L6-6/isort02.re, 0.0551, True\nTests/L6/neg-L6-6/maxint1.re, 0.0407, True\nTests/L6/neg-L6-6/maxlist00_1.re, 0.0476, True\nTests/L6/neg-L6-6/deptup00.re, 0.0450, True\nTests/L6/neg-L6-6/maxlist.re, 0.0515, True\nTests/L6/neg-L6-6/maxlist00_2.re, 0.0476, True\nTests/L6/neg-L6-6/maxlist01.re, 0.0458, True\nTests/L6/neg-L6-6/isort02.re, 0.0586, True\nTests/L6/neg-L6-6/maxint2.re, 0.0368, True\nTests/L8/pos-L7-8/sumAcc.re, 0.0554, True\nTests/L8/pos-L7-8/listSet.re, 0.0595, True\nTests/L8/pos-L7-8/range.re, 0.0469, True\nTests/L8/pos-L7-8/ack.re, 0.0591, True\nTests/L8/pos-L7-8/sumNat.re, 0.0440, True\nTests/L8/pos-L7-8/append.re, 0.0469, True\nTests/L8/pos-L7-8/sum.re, 0.0504, True\nTests/L8/pos-L7-8/braid.re, 0.0479, True\nTests/L8/neg-L7-8/sumAcc.re, 0.0598, True\nTests/L8/neg-L7-8/listSet.re, 0.0668, True\nTests/L8/neg-L7-8/range.re, 0.0657, True\nTests/L8/neg-L7-8/ack.re, 0.0743, True\nTests/L8/neg-L7-8/list00.re, 0.0663, True\nTests/L8/neg-L7-8/sum.re, 0.0692, True\nTests/L8/pos-L8-8/listSet.re, 0.0954, True\nTests/L8/pos-L8-8/poly.re, 0.0578, True\nTests/L8/pos-L8-8/append.re, 0.0715, True\nTests/L8/pos-L8-8/sum.re, 0.0533, True\nTests/L8/neg-L8-8/listSet.re, 0.0319, True\nTests/L8/neg-L8-8/append.re, 0.0312, True\nTests/L8/neg-L8-8/sum.re, 0.0464, True\n" } ]