├── shell.nix ├── cabal.project ├── tasty ├── Main.hs └── HasCal │ └── Test │ ├── HourClock.hs │ ├── EuclidAlg.hs │ ├── Flags.hs │ ├── Trade.hs │ ├── Hanoi.hs │ ├── Transfer.hs │ ├── AsyncInterface.hs │ ├── FastMutex.hs │ ├── DieHard.hs │ ├── DiningPhilosophers.hs │ ├── API.hs │ ├── Market.hs │ ├── FIFO.hs │ └── InternalMemory.hs ├── .github └── workflows │ └── main.yml ├── doctest └── Main.hs ├── default.nix ├── LICENSE ├── HasCal.cabal ├── README.md └── src ├── HasCal.hs └── HasCal ├── Expression.hs ├── Property.hs └── Coroutine.hs /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix).env 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | write-ghc-environment-files: always 3 | -------------------------------------------------------------------------------- /tasty/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-} 2 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: 'main' 2 | on: [ 'pull_request' ] 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v2.4.0 8 | - uses: cachix/install-nix-action@v15 9 | - run: nix-build 10 | -------------------------------------------------------------------------------- /doctest/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Test.DocTest as DocTest 4 | import qualified System.Environment as Environment 5 | 6 | main :: IO () 7 | main = do 8 | args <- Environment.getArgs 9 | DocTest.mainFromCabal "HasCal" args 10 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | nixpkgs = builtins.fetchTarball { 3 | url = "https://github.com/NixOS/nixpkgs/archive/faad370edcb37162401be50d45526f52bb16a713.tar.gz"; 4 | sha256 = "1d82d4vh0layf6n925j0h2nym16jbvcvps3l5m8ln9hxn0m6gadn"; 5 | }; 6 | 7 | overlay = pkgsNew: pkgsOld: { 8 | haskellPackages = pkgsOld.haskellPackages.override (old : { 9 | overrides = 10 | pkgsNew.lib.fold pkgsNew.lib.composeExtensions 11 | (old.overrides or (_: _: { })) 12 | [ (pkgsNew.haskell.lib.packageSourceOverrides { 13 | HasCal = ./.; 14 | }) 15 | (haskellPackagesNew: haskellPackagesOld: { 16 | doctest-parallel = 17 | pkgsNew.haskell.lib.dontCheck haskellPackagesOld.doctest-parallel; 18 | 19 | HasCal = 20 | pkgsNew.haskell.lib.overrideCabal 21 | haskellPackagesOld.HasCal 22 | (_: { 23 | testTarget = "tasty"; 24 | }); 25 | }) 26 | ]; 27 | }); 28 | }; 29 | 30 | config = { allowBroken = true; }; 31 | 32 | pkgs = import nixpkgs { inherit config; overlays = [ overlay ]; }; 33 | 34 | in 35 | pkgs.haskellPackages.HasCal 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Gabriella Gonzalez 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Gabriella Gonzalez nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/HourClock.hs: -------------------------------------------------------------------------------- 1 | {-| This is based on the [HourClock example](https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/HourClock/HourClock.tla) 2 | from figure 2.1 on page 20 in Lamport's \"Specifying Systems\" book: 3 | 4 | > ---------------------- MODULE HourClock ---------------------- 5 | > EXTENDS Naturals 6 | > VARIABLE hr 7 | > HCini == hr \in (1 .. 12) 8 | > HCnxt == hr' = IF hr # 12 THEN hr + 1 ELSE 1 9 | > HC == HCini /\ [][HCnxt]_hr 10 | > -------------------------------------------------------------- 11 | > THEOREM HC => []HCini 12 | > ============================================================== 13 | -} 14 | 15 | {-# LANGUAGE BlockArguments #-} 16 | {-# LANGUAGE DeriveAnyClass #-} 17 | {-# LANGUAGE DeriveGeneric #-} 18 | {-# LANGUAGE RecordWildCards #-} 19 | {-# LANGUAGE TemplateHaskell #-} 20 | 21 | module HasCal.Test.HourClock where 22 | 23 | import HasCal 24 | import Prelude hiding ((.)) 25 | import Test.Tasty (TestTree) 26 | 27 | import qualified Test.Tasty.HUnit as HUnit 28 | import qualified Control.Monad as Monad 29 | 30 | data Global = Global { _hr :: Int } 31 | deriving (Eq, Generic, Hashable, Show, ToJSON) 32 | 33 | data Label = Ini | Nxt 34 | deriving (Eq, Generic, Hashable, Show, ToJSON) 35 | 36 | makeLenses ''Global 37 | 38 | tick :: Int -> Int 39 | tick hour = hour `mod` 12 + 1 40 | 41 | test_hourClock :: TestTree 42 | test_hourClock = HUnit.testCase "Hour clock" do 43 | model defaultModel 44 | { termination = False 45 | 46 | , startingGlobals = do 47 | _hr <- [1 .. 12] 48 | return Global{..} 49 | 50 | , coroutine = Coroutine 51 | { startingLabel = Ini 52 | , startingLocals = pure () 53 | , process = Monad.forever do 54 | yield Nxt 55 | global.hr %= tick 56 | } 57 | 58 | , property = always . viewing (state . hr . to (`elem` [ 1 .. 12 ])) 59 | } 60 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/EuclidAlg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | {-| This example is taken from sections 2.0 through 2.4 of "A PlusCal User's 8 | Manual" 9 | -} 10 | 11 | module HasCal.Test.EuclidAlg where 12 | 13 | import Control.Monad (when) 14 | import HasCal 15 | import Prelude hiding (gcd, print, (.)) 16 | import Test.Tasty (TestTree) 17 | 18 | import qualified Prelude 19 | import qualified Test.Tasty.HUnit as HUnit 20 | 21 | data Global = Global { _u :: Int, _v :: Int } 22 | deriving (Eq, Generic, Hashable, Show, ToJSON) 23 | 24 | makeLenses ''Global 25 | 26 | initialU :: Int 27 | initialU = 24 28 | 29 | euclidAlg :: Int -> IO () 30 | euclidAlg n = do 31 | model defaultModel 32 | { startingGlobals = do 33 | _v <- [ 1 .. n ] 34 | let _u = initialU 35 | return Global{..} 36 | 37 | , coroutine = Coroutine 38 | { startingLabel = () 39 | 40 | , startingLocals = pure () 41 | 42 | , process = do 43 | initialV <- use (global.v) 44 | while (do u_ <- use (global.u); return (u_ /= 0)) do 45 | tempU <- use (global.u) 46 | tempV <- use (global.v) 47 | when (tempU < tempV) do 48 | global.u .= tempU 49 | global.v .= tempV 50 | newV <- use (global.v) 51 | global.u -= newV 52 | finalV <- use (global.v) 53 | assert (Just finalV == gcd initialU initialV) 54 | assert (finalV == Prelude.gcd initialU initialV) 55 | } 56 | 57 | , property = true 58 | } 59 | 60 | gcd :: Int -> Int -> Maybe Int 61 | gcd x y = 62 | choose [ 1 .. x ] \i -> 63 | x `mod` i == 0 64 | && y `mod` i == 0 65 | && forall_ [ 1 .. x ] \j -> 66 | x `mod` j == 0 67 | && y `mod` j == 0 68 | ==> i >= j 69 | 70 | test_euclidAlg :: TestTree 71 | test_euclidAlg = HUnit.testCase "Euclid's algorithm" do 72 | euclidAlg 4 73 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/Flags.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | {-| This example is from the "Behaviors" section of the "Learn TLA+" guide 9 | 10 | > ---- MODULE flags ---- 11 | > EXTENDS TLC, Integers 12 | > (* --algorithm flags 13 | > variables f1 \in BOOLEAN, f2 \in BOOLEAN, f3 \in BOOLEAN 14 | > begin 15 | > while TRUE do 16 | > with f \in {1, 2, 3} do 17 | > if f = 1 then 18 | > either 19 | > f1 := TRUE; 20 | > or 21 | > f1 := FALSE; 22 | > end either; 23 | > elsif f = 2 then 24 | > either 25 | > f2 := TRUE; 26 | > or 27 | > f2 := FALSE; 28 | > end either; 29 | > else 30 | > either 31 | > f3 := TRUE; 32 | > or 33 | > f3 := FALSE; 34 | > end either; 35 | > end if; 36 | > end with; 37 | > end while; 38 | > end algorithm; *) 39 | > 40 | > ==== 41 | 42 | -} 43 | module HasCal.Test.Flags where 44 | 45 | import Control.Monad (forever) 46 | import HasCal 47 | import Prelude hiding ((.)) 48 | import Test.Tasty (TestTree) 49 | 50 | import qualified Test.Tasty.HUnit as HUnit 51 | 52 | data Global = Global{ _f1 :: Bool, _f2 :: Bool, _f3 :: Bool } 53 | deriving (Eq, Generic, Hashable, Show, ToJSON) 54 | 55 | data Label = A | B deriving (Eq, Generic, Hashable, Show, ToJSON) 56 | 57 | makeLenses ''Global 58 | 59 | test_flags :: TestTree 60 | test_flags = HUnit.testCase "Flags" do 61 | model defaultModel 62 | { termination = False 63 | 64 | , startingGlobals = do 65 | _f1 <- universe @Bool 66 | _f2 <- universe @Bool 67 | _f3 <- universe @Bool 68 | return Global{..} 69 | 70 | , coroutine = Coroutine 71 | { startingLabel = A 72 | 73 | , startingLocals = pure () 74 | 75 | , process = forever do 76 | yield B 77 | f <- with [ f1, f2, f3 ] 78 | bool <- with universe 79 | global.f .= bool 80 | } 81 | 82 | , property = true 83 | } 84 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/Trade.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | {-| This example is from the "Introduction" section of the "Learn TLA+" guide 10 | 11 | > People == {"alice", "bob"} 12 | > Items == {"ore", "sheep", "brick"} 13 | > (* --algorithm trade 14 | > variable owner_of \in [Items -> People] 15 | > 16 | > process giveitem \in 1..3 \* up to three possible trades made 17 | > variables item \in Items, 18 | > owner = owner_of[item], 19 | > to \in People, 20 | > origin_of_trade \in People 21 | > begin Give: 22 | > if origin_of_trade = owner then 23 | > owner_of[item] := to; 24 | > end if; 25 | > end process; 26 | > end algorithm; *) 27 | 28 | -} 29 | 30 | module HasCal.Test.Trade where 31 | 32 | import Control.Monad (when) 33 | import HasCal hiding (to) 34 | import Prelude hiding ((.)) 35 | import Test.Tasty (TestTree) 36 | 37 | import qualified Test.Tasty.HUnit as HUnit 38 | 39 | data People = Alice | Bob 40 | deriving (Eq, Generic, Hashable, Show, ToJSON, Universe) 41 | 42 | data Items = Ore | Sheep | Brick 43 | deriving (Eq, Generic, Hashable, Show, ToJSON, ToJSONKey, Universe) 44 | 45 | data Global = Global { _owner_of :: HashMap Items People } 46 | deriving (Eq, Generic, Hashable, Show, ToJSON) 47 | 48 | makeLenses ''Global 49 | 50 | test_trade :: TestTree 51 | test_trade = HUnit.testCase "Trade" do 52 | model defaultModel 53 | { startingGlobals = do 54 | _owner_of <- universe @Items --> universe @People 55 | return Global{..} 56 | 57 | , coroutine = traverse_ giveitem [ 1 .. 3 ] 58 | 59 | , property = true 60 | } 61 | where 62 | giveitem :: Int -> Coroutine Global () 63 | giveitem _ = Coroutine 64 | { startingLabel = () 65 | 66 | , startingLocals = pure () 67 | 68 | , process = do 69 | item <- with (universe @Items) 70 | to <- with (universe @People) 71 | origin_of_trade <- with (universe @People) 72 | 73 | Just owner <- preuse (global.owner_of.ix item) 74 | 75 | when (origin_of_trade == owner) do 76 | global.owner_of.ix item .= to 77 | } 78 | -------------------------------------------------------------------------------- /HasCal.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: HasCal 3 | version: 1.0.0 4 | synopsis: Haskell embedding of PlusCal 5 | bug-reports: https://github.com/Gabriel439/HasCal/issues 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Gabriella Gonzalez 9 | maintainer: Gabriel439@gmail.com 10 | copyright: 2021 Gabriella Gonzalez 11 | 12 | common common 13 | build-depends: base >=4.14.3.0 && < 5 14 | , Diff 15 | , aeson 16 | , ansi-terminal 17 | , exceptions 18 | , hashable 19 | , hashtables 20 | , logict 21 | , microlens-platform 22 | , mtl 23 | , prettyprinter 24 | , prettyprinter-ansi-terminal 25 | , profunctors 26 | , safe-exceptions 27 | , scientific 28 | , text 29 | , transformers 30 | , unordered-containers 31 | hs-source-dirs: src 32 | ghc-options: -Wall -O2 33 | default-language: Haskell2010 34 | 35 | library 36 | import: common 37 | exposed-modules: HasCal 38 | , HasCal.Coroutine 39 | , HasCal.Expression 40 | , HasCal.Property 41 | ghc-options: -Wall -O2 42 | 43 | test-suite tasty 44 | import: common 45 | type: exitcode-stdio-1.0 46 | main-is: Main.hs 47 | build-depends: base >=4.14.3.0 && < 5 48 | , HasCal 49 | , containers 50 | , tasty 51 | , tasty-expected-failure 52 | , tasty-hunit 53 | , tasty-discover 54 | other-modules: HasCal.Test.AsyncInterface 55 | , HasCal.Test.DieHard 56 | , HasCal.Test.EuclidAlg 57 | , HasCal.Test.Flags 58 | , HasCal.Test.FastMutex 59 | , HasCal.Test.Hanoi 60 | , HasCal.Test.HourClock 61 | , HasCal.Test.Market 62 | , HasCal.Test.Trade 63 | , HasCal.Test.Transfer 64 | hs-source-dirs: tasty 65 | ghc-options: -Wall -O2 -rtsopts 66 | default-language: Haskell2010 67 | 68 | test-suite doctest 69 | type: exitcode-stdio-1.0 70 | hs-source-dirs: doctest 71 | main-is: Main.hs 72 | build-depends: base, HasCal, doctest-parallel 73 | ghc-options: -Wall -O2 -threaded 74 | default-language: Haskell2010 75 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/Hanoi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | 5 | {-| This example is from the "Tuples And Structures" section of the "Learn TLA+" 6 | guide 7 | 8 | > ---- MODULE hanoi ---- 9 | > EXTENDS TLC, Sequences, Integers 10 | > 11 | > (* --algorithm hanoi 12 | > variables tower = <<<<1, 2, 3>>, <<>>, <<>>>>, 13 | > 14 | > define 15 | > D == DOMAIN tower 16 | > end define; 17 | > 18 | > begin 19 | > while TRUE do 20 | > assert tower[3] /= <<1, 2, 3>>; 21 | > with from \in {x \in D : tower[x] /= <<>>}, 22 | > to \in { 23 | > y \in D : 24 | > \/ tower[y] = <<>> 25 | > \/ Head(tower[from]) < Head(tower[y]) 26 | > } 27 | > do 28 | > tower[from] := Tail(tower[from]) || 29 | > tower[to] := <> \o tower[to]; 30 | > end with; 31 | > end while; 32 | > end algorithm; *) 33 | > ==== 34 | 35 | -} 36 | 37 | module HasCal.Test.Hanoi where 38 | 39 | import Control.Monad (forever) 40 | import HasCal hiding (to) 41 | import Prelude hiding ((.)) 42 | import Test.Tasty (TestTree) 43 | 44 | import qualified Test.Tasty.HUnit as HUnit 45 | import qualified Test.Tasty.ExpectedFailure as Failure 46 | 47 | data Label = A | B deriving (Eq, Generic, Hashable, Show, ToJSON) 48 | 49 | test_hanoi :: TestTree 50 | test_hanoi = 51 | Failure.expectFailBecause "The original example intentionally fails" do 52 | HUnit.testCase "Hanoi" do 53 | model defaultModel 54 | { termination = False 55 | 56 | , startingGlobals = do 57 | let board :: [[Int]] 58 | board = [ [ 1, 2, 3 ], [ ], [ ] ] 59 | 60 | pure board 61 | 62 | , coroutine = Coroutine 63 | { startingLabel = A 64 | 65 | , startingLocals = pure () 66 | 67 | , process = forever do 68 | yield B 69 | 70 | _position2 <- use (global.ix 2) 71 | assert (_position2 /= [ 1, 2, 3 ]) 72 | 73 | from <- with [ 0 .. 2 ] 74 | to <- with [ 0 .. 2 ] 75 | 76 | src <- use (global.ix from) 77 | dst <- use (global.ix to ) 78 | 79 | case (src, dst) of 80 | (s : rc, []) -> do 81 | global.ix from .= rc 82 | global.ix to .= [ s ] 83 | (s : rc, d : st) | s < d -> do 84 | global.ix from .= rc 85 | global.ix to .= s : d : st 86 | _ -> do 87 | empty 88 | } 89 | 90 | , property = true 91 | } 92 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/Transfer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | {-| This example is from the "An Example" section of the "Learn TLA+" guide 8 | 9 | > ---- MODULE Transfer ---- 10 | > EXTENDS Naturals, TLC 11 | > 12 | > (* --algorithm transfer 13 | > variables alice_account = 10, bob_account = 10, 14 | > account_total = alice_account + bob_account; 15 | > 16 | > process Transfer \in 1..2 17 | > variable money \in 1..20; 18 | > begin 19 | > Transfer: 20 | > if alice_account >= money then 21 | > A: alice_account := alice_account - money; 22 | > bob_account := bob_account + money; 23 | > end if; 24 | > C: assert alice_account >= 0; 25 | > end process 26 | > 27 | > end algorithm *) 28 | > 29 | > MoneyInvariant == alice_account + bob_account = account_total 30 | > 31 | > ==== 32 | 33 | -} 34 | module HasCal.Test.Transfer where 35 | 36 | import Control.Monad (when) 37 | import HasCal 38 | import Prelude hiding ((.)) 39 | import Test.Tasty (TestTree) 40 | 41 | import qualified Test.Tasty.HUnit as HUnit 42 | import qualified Test.Tasty.ExpectedFailure as Failure 43 | 44 | data Global = Global 45 | { _alice_account :: Int 46 | , _bob_account :: Int 47 | , _account_total :: Int 48 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 49 | 50 | data Local = Local { _money :: Int } 51 | deriving (Eq, Generic, Hashable, Show, ToJSON) 52 | 53 | data Label = Transfer | A | C deriving (Eq, Generic, Hashable, Show, ToJSON) 54 | 55 | makeLenses ''Global 56 | makeLenses ''Local 57 | 58 | test_transfer :: TestTree 59 | test_transfer = 60 | Failure.expectFailBecause "The example has a deliberate TOCTOU bug" do 61 | HUnit.testCase "Transfer" do 62 | model defaultModel 63 | { startingGlobals = do 64 | let _alice_account = 10 65 | let _bob_account = 10 66 | let _account_total = _alice_account + _bob_account 67 | return Global{..} 68 | 69 | , coroutine = traverse transfer [ 1 .. 2 ] 70 | 71 | , property = 72 | let predicate Global{..} = 73 | _alice_account + _bob_account == _account_total 74 | in always . viewing (state . to predicate) 75 | } 76 | where 77 | transfer :: Int -> Coroutine Global Label 78 | transfer _ = Coroutine 79 | { startingLabel = Transfer 80 | 81 | , startingLocals = do 82 | _money <- [ 1 .. 20 ] 83 | return Local{..} 84 | 85 | , process = do 86 | _money <- use (local.money) 87 | 88 | alice_old <- use (global.alice_account) 89 | 90 | when (alice_old >= _money) do 91 | yield A 92 | global.alice_account -= _money 93 | global.bob_account += _money 94 | 95 | yield C 96 | alice_new <- use (global.alice_account) 97 | assert (alice_new >= 0) 98 | } 99 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/AsyncInterface.hs: -------------------------------------------------------------------------------- 1 | {-| This is based on the [AsynchInterface example](https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/AsynchronousInterface/AsynchInterface.tla) 2 | from figure 3.1 on page 27 in Lamport's \"Specifying Systems\" book: 3 | 4 | > ------------------ MODULE AsynchInterface --------------------- 5 | > EXTENDS Naturals 6 | > CONSTANT Data 7 | > VARIABLES val, rdy, ack 8 | > 9 | > TypeInvariant == /\ val \in Data 10 | > /\ rdy \in {0, 1} 11 | > /\ ack \in {0, 1} 12 | > --------------------------------------------------------------- 13 | > Init == /\ val \in Data 14 | > /\ rdy \in {0, 1} 15 | > /\ ack = rdy 16 | > 17 | > Send == /\ rdy = ack 18 | > /\ val' \in Data 19 | > /\ rdy' = 1 - rdy 20 | > /\ UNCHANGED ack 21 | > 22 | > Rcv == /\ rdy # ack 23 | > /\ ack' = 1 - ack 24 | > /\ UNCHANGED <> 25 | > 26 | > Next == Send \/ Rcv 27 | > 28 | > Spec == Init /\ [][Next]_<> 29 | > --------------------------------------------------------------- 30 | > THEOREM Spec => []TypeInvariant 31 | > =============================================================== 32 | -} 33 | 34 | {-# LANGUAGE BlockArguments #-} 35 | {-# LANGUAGE DeriveAnyClass #-} 36 | {-# LANGUAGE DeriveGeneric #-} 37 | {-# LANGUAGE RecordWildCards #-} 38 | {-# LANGUAGE TemplateHaskell #-} 39 | 40 | module HasCal.Test.AsyncInterface where 41 | 42 | import HasCal 43 | import Prelude hiding ((.)) 44 | import Test.Tasty (TestTree) 45 | 46 | import qualified Test.Tasty.HUnit as HUnit 47 | import qualified Control.Monad as Monad 48 | 49 | data Chan = Chan { _val :: Data, _rdy :: Bool, _ack :: Bool } 50 | deriving (Eq, Generic, Hashable, Show, ToJSON) 51 | 52 | data Label = Init | Send | Rcv deriving (Eq, Generic, Hashable, Show, ToJSON) 53 | 54 | data Data = D1 | D2 | D3 deriving (Eq, Generic, Hashable, Show, ToJSON, Universe) 55 | 56 | makeLenses ''Chan 57 | 58 | -- `send` and `rcv` are factored out into top-level utilities so that they can 59 | -- be reused by the "HasCal.Test.FIFO" example 60 | 61 | send :: Data -> Process Chan local label () 62 | send message = do 63 | Chan{..} <- use global 64 | await (_rdy == _ack) 65 | global.val .= message 66 | global.rdy %= not 67 | 68 | rcv :: Process Chan local label () 69 | rcv = do 70 | Chan{..} <- use global 71 | await (_rdy /= _ack) 72 | global.ack %= not 73 | 74 | channelModel :: Model Chan Label 75 | channelModel = defaultModel 76 | { termination = False 77 | 78 | , startingGlobals = do 79 | _val <- universe 80 | _rdy <- universe 81 | let _ack = _rdy 82 | return Chan{..} 83 | 84 | , coroutine = Coroutine 85 | { startingLabel = Init 86 | 87 | , startingLocals = pure () 88 | 89 | , process = Monad.forever 90 | ( (do msg <- with universe 91 | send msg 92 | yield Send 93 | ) 94 | <|> (do rcv 95 | yield Rcv 96 | ) 97 | ) 98 | } 99 | 100 | , property = true 101 | } 102 | 103 | test_asyncInterface :: TestTree 104 | test_asyncInterface = HUnit.testCase "Async interface" do 105 | model channelModel 106 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/FastMutex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | -- | This example is taken from section 2.6 of "A PlusCal User's Manual" 8 | module HasCal.Test.FastMutex where 9 | 10 | import Control.Monad (when) 11 | import Data.Traversable (for) 12 | import HasCal 13 | import Numeric.Natural (Natural) 14 | import Prelude hiding ((.)) 15 | import Test.Tasty (TestTree) 16 | 17 | import qualified Control.Monad as Monad 18 | import qualified Test.Tasty.HUnit as HUnit 19 | 20 | data Global = Global{ _x :: Int, _y :: Int, _b :: HashMap Int Bool } 21 | deriving (Eq, Generic, Hashable, Show, ToJSON) 22 | 23 | data Label 24 | = Default 25 | | NonCriticalSection 26 | | Start 27 | | CriticalSection 28 | | Line Natural 29 | deriving (Eq, Generic, Hashable, Show, ToJSON) 30 | 31 | makeLenses ''Global 32 | 33 | fastMutex :: Int -> IO () 34 | fastMutex n = model defaultModel 35 | { termination = False 36 | 37 | , startingGlobals = do 38 | let _x = 0 39 | let _y = 0 40 | let _b = [ 1.. n ] |-> \_i -> False 41 | return Global{..} 42 | 43 | , coroutine = for [ 1 .. n ] proc 44 | 45 | , property = 46 | let predicate labels = 47 | length (filter (== CriticalSection) labels) <= 1 48 | in always . viewing (label . to predicate) 49 | } 50 | where 51 | proc :: Int -> Coroutine Global Label 52 | proc self = Coroutine 53 | { startingLabel = Default 54 | 55 | , startingLocals = pure () 56 | 57 | , process = ncs 58 | } 59 | where 60 | ncs = do 61 | yield NonCriticalSection 62 | start 63 | 64 | start :: Process Global () Label a 65 | start = do 66 | yield Start 67 | global.b.ix(self) .= True 68 | 69 | yield (Line 1) 70 | global.x .= self 71 | 72 | yield (Line 2) 73 | y0 <- use (global.y) 74 | when (y0 /= 0) do 75 | yield (Line 3) 76 | global.b.ix(self) .= False 77 | 78 | yield (Line 4) 79 | y1 <- use (global.y) 80 | await (y1 == 0) 81 | start 82 | 83 | yield (Line 5) 84 | global.y .= self 85 | 86 | yield (Line 6) 87 | x0 <- use (global.x) 88 | when (x0 /= self) do 89 | yield (Line 7) 90 | global.b.ix(self) .= False 91 | 92 | yield (Line 8) 93 | Monad.forM_ [ 1 .. n ] \j -> do 94 | Just bool <- preuse (global.b.ix(j)) 95 | await (not bool) 96 | 97 | yield (Line 9) 98 | y1 <- use (global.y) 99 | when (y1 /= self) do 100 | yield (Line 10) 101 | y2 <- use (global.y) 102 | await (y2 == 0) 103 | start 104 | 105 | yield CriticalSection 106 | 107 | yield (Line 11) 108 | global.y .= 0 109 | 110 | yield (Line 12) 111 | global.b.ix(self) .= False 112 | 113 | ncs 114 | 115 | test_fastMutex :: TestTree 116 | test_fastMutex = HUnit.testCase "Fast mutex algorithm" do 117 | fastMutex 3 118 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/DieHard.hs: -------------------------------------------------------------------------------- 1 | {-| The following is the "Die Hard" 2 | [example](https://github.com/tlaplus/Examples/blob/master/specifications/DieHard/DieHard.tla) 3 | from Lamport's [*TLA+ Video 4 | Course*](http://lamport.azurewebsites.net/video/videos.html). 5 | 6 | > VARIABLES small, big 7 | > 8 | > TypeOK = /\ small \in 0..3 9 | > /\ big \in 0..5 10 | > 11 | > Init == /\ big = 0 12 | > /\ small = 0 13 | > 14 | > FillSmall == /\ small' = 3 15 | > /\ big' = big 16 | > 17 | > FillBig == /\ big' = 5 18 | > /\ small' = small 19 | > 20 | > EmptySmall == /\ small' = 0 21 | > /\ big' = big 22 | > 23 | > EmptyBig == /\ big' = 0 24 | > /\ small' = small 25 | > 26 | > SmallToBig == /\ big' = Min(big + small, 5) 27 | > /\ small' = small - (big' - big) 28 | > 29 | > BigToSmall == /\ small' = Min(big + small, 3) 30 | > /\ big' = big - (small' - small) 31 | 32 | This module ports the above TLA+ code to HasCal. 33 | -} 34 | 35 | {-# LANGUAGE BlockArguments #-} 36 | {-# LANGUAGE DeriveAnyClass #-} 37 | {-# LANGUAGE DeriveGeneric #-} 38 | {-# LANGUAGE RecordWildCards #-} 39 | {-# LANGUAGE TemplateHaskell #-} 40 | {-# LANGUAGE TypeApplications #-} 41 | 42 | module HasCal.Test.DieHard where 43 | 44 | import HasCal 45 | import Prelude hiding (either, init, (.)) 46 | import Test.Tasty (TestTree) 47 | 48 | import qualified Test.Tasty.HUnit as HUnit 49 | import qualified Test.Tasty.ExpectedFailure as Failure 50 | import qualified Control.Monad as Monad 51 | 52 | data Global = Global { _small :: Int, _big :: Int } 53 | deriving (Eq, Generic, Hashable, Show, ToJSON) 54 | 55 | makeLenses ''Global 56 | 57 | data Label = Init | FillSmall | FillBig | EmptySmall | EmptyBig | SmallToBig | BigToSmall 58 | deriving (Eq, Generic, Hashable, Show, ToJSON) 59 | 60 | typeOK :: Global -> Bool 61 | typeOK Global {..} = _small `elem` [0..3] && _big `elem` [0..5] 62 | 63 | init, fillSmall, fillBig, emptySmall, emptyBig, smallToBig, bigToSmall :: Process Global () Label () 64 | 65 | init = Monad.forever next 66 | 67 | fillSmall = do 68 | yield FillSmall 69 | global.small .= 3 70 | 71 | fillBig = do 72 | yield FillBig 73 | global.big .= 5 74 | 75 | emptySmall = do 76 | yield EmptySmall 77 | global.small .= 0 78 | 79 | emptyBig = do 80 | yield EmptyBig 81 | global.big .= 0 82 | 83 | smallToBig = do 84 | yield SmallToBig 85 | _small <- use (global.small) 86 | _big <- use (global.big) 87 | _big' <- global.big <.= min (_big + _small) 5 88 | global.small .= _small - (_big' - _big) 89 | 90 | bigToSmall = do 91 | yield BigToSmall 92 | _small <- use (global.small) 93 | _big <- use (global.big) 94 | _small' <- global.small <.= min (_big + _small) 3 95 | global.big .= _big - (_small' - _small) 96 | 97 | next :: Process Global () Label () 98 | next = 99 | either 100 | [ fillSmall 101 | , fillBig 102 | , emptySmall 103 | , emptyBig 104 | , smallToBig 105 | , bigToSmall 106 | ] 107 | 108 | test_dieHard :: TestTree 109 | test_dieHard = 110 | Failure.expectFailBecause "The solution to the puzzle is the counterexample" do 111 | HUnit.testCase "Die Hard" do 112 | model defaultModel 113 | { termination = False 114 | 115 | , startingGlobals = do 116 | let _small = 0 117 | _big = 0 118 | return Global{..} 119 | 120 | , coroutine = Coroutine 121 | { startingLabel = Init 122 | , startingLocals = pure () 123 | , process = init 124 | } 125 | 126 | , property = always . viewing (state . big . to (/= 4)) 127 | } 128 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HasCal 2 | 3 | HasCal embeds PlusCal in Haskell as an ordinary Haskell package. Everything is 4 | implemented entirely in Haskell, including the model checker. 5 | 6 | ## Examples 7 | 8 | You can find lots of example code in the [test suite](./tasty/HasCal/Test), 9 | including an example which translates the following PlusCal code from the 10 | [Learn TLA+ book](https://learntla.com/introduction/example/): 11 | 12 | ``` 13 | ---- MODULE Transfer ---- 14 | EXTENDS Naturals, TLC 15 | 16 | (* --algorithm transfer 17 | variables alice_account = 10, bob_account = 10, 18 | account_total = alice_account + bob_account; 19 | 20 | process Transfer \in 1..2 21 | variable money \in 1..20; 22 | begin 23 | Transfer: 24 | if alice_account >= money then 25 | A: alice_account := alice_account - money; 26 | bob_account := bob_account + money; 27 | end if; 28 | C: assert alice_account >= 0; 29 | end process 30 | 31 | end algorithm *) 32 | 33 | MoneyInvariant == alice_account + bob_account = account_total 34 | ``` 35 | 36 | … into this Haskell code: 37 | 38 | ```haskell 39 | {-# LANGUAGE BlockArguments #-} 40 | {-# LANGUAGE DeriveAnyClass #-} 41 | {-# LANGUAGE DeriveGeneric #-} 42 | {-# LANGUAGE RecordWildCards #-} 43 | {-# LANGUAGE TemplateHaskell #-} 44 | 45 | import Control.Monad (when) 46 | import Prelude hiding ((.)) 47 | import HasCal 48 | 49 | data Global = Global 50 | { _alice_account :: Int 51 | , _bob_account :: Int 52 | , _account_total :: Int 53 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 54 | 55 | data Local = Local { _money :: Int } 56 | deriving (Eq, Generic, Hashable, Show, ToJSON) 57 | 58 | data Label = Transfer | A | C deriving (Eq, Generic, Hashable, Show, ToJSON) 59 | 60 | makeLenses ''Global 61 | makeLenses ''Local 62 | 63 | main :: IO () 64 | main = do 65 | let transfer _ = Coroutine 66 | { startingLabel = Transfer 67 | 68 | , startingLocals = do 69 | _money <- [ 1 .. 20 ] 70 | return Local{..} 71 | 72 | , process = do 73 | _money <- use (local.money) 74 | 75 | alice_old <- use (global.alice_account) 76 | 77 | when (alice_old >= _money) do 78 | yield A 79 | global.alice_account -= _money 80 | global.bob_account += _money 81 | 82 | yield C 83 | alice_new <- use (global.alice_account) 84 | assert (alice_new >= 0) 85 | } 86 | 87 | model defaultModel 88 | { startingGlobals = do 89 | let _alice_account = 10 90 | let _bob_account = 10 91 | let _account_total = _alice_account + _bob_account 92 | return Global{..} 93 | 94 | , coroutine = traverse transfer [ 1 .. 2 ] 95 | 96 | , property = 97 | let predicate (Global{..}, _) = 98 | _alice_account + _bob_account == _account_total 99 | in always . arr predicate 100 | } 101 | ``` 102 | 103 | ## Notable differences from PlusCal 104 | 105 | HasCal differs from PlusCal in a few ways, which are enumerated here: 106 | 107 | * HasCal processes are fair by default 108 | 109 | You have to explicitly opt out of fairness by adding an explicit "do nothing" 110 | branch to a process 111 | 112 | * Liveness properties can be vacuously satisfied by infinite cycles 113 | 114 | If you disable the termination check then a process that goes into an infinite 115 | loop may satisfy a liveness property by virtue of never failing the property. 116 | 117 | For example, if have a liveness property that checks that a local variable is 118 | eventually equals 1, that property can be satisfied by an infinite loop that 119 | never sets the variable to 1. 120 | 121 | * HasCal does not support symmetry sets 122 | 123 | The performance overhead of implementing symmetry sets negates the benefit 124 | 125 | * HasCal does not support the `goto` keyword 126 | 127 | `goto` can be simulated in Haskell by mutually recursive named procedures 128 | 129 | See, for example, 130 | [the "FastMutex" example from the test suite](tasty/HasCal/Test/FastMutex.hs) 131 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/DiningPhilosophers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | {-| This example is from the "Processes" section of the "Learn TLA+" guide 8 | 9 | > EXTENDS Integers, Sequences, TLC, FiniteSets 10 | > CONSTANTS NumPhilosophers, NULL 11 | > ASSUME NumPhilosophers > 0 12 | > NP == NumPhilosophers 13 | > 14 | > (* --algorithm dining_philosophers 15 | > 16 | > variables forks = [fork \in 1..NP |-> NULL] 17 | > 18 | > define 19 | > LeftFork(p) == p 20 | > RightFork(p) == IF p = NP THEN 1 ELSE p + 1 21 | > 22 | > HeldForks(p) == 23 | > { x \in {LeftFork(p), RightFork(p)}: forks[x] = p} 24 | > 25 | > AvailableForks(p) == 26 | > { x \in {LeftFork(p), RightFork(p)}: forks[x] = NULL} 27 | > 28 | > end define; 29 | > process philosopher \in 1..NP 30 | > variables hungry = TRUE; 31 | > begin P: 32 | > while hungry do 33 | > with fork \in AvailableForks(self) do 34 | > forks[fork] := self; 35 | > end with; 36 | > Eat: 37 | > if Cardinality(HeldForks(self)) = 2 then 38 | > hungry := FALSE; 39 | > forks[LeftFork(self)] := NULL || 40 | > forks[RightFork(self)] := NULL; 41 | > end if; 42 | > end while; 43 | > end process; 44 | > end algorithm; *) 45 | 46 | -} 47 | 48 | module HasCal.Test.DiningPhilosophers where 49 | 50 | import HasCal 51 | import Prelude hiding ((.)) 52 | import Test.Tasty (TestTree) 53 | 54 | import qualified Control.Monad as Monad 55 | import qualified Test.Tasty.ExpectedFailure as Failure 56 | import qualified Test.Tasty.HUnit as HUnit 57 | 58 | type Fork = Int 59 | 60 | type Philosopher = Int 61 | 62 | data Global = Global { _forks :: HashMap Fork (Maybe Philosopher) } 63 | deriving (Eq, Generic, Hashable, ToJSON, Show) 64 | 65 | data Local = Local { _hungry :: Bool } 66 | deriving (Eq, Generic, Hashable, ToJSON, Show) 67 | 68 | data Labels = P | Eat 69 | deriving (Eq, Generic, Hashable, ToJSON, Show) 70 | 71 | makeLenses ''Global 72 | makeLenses ''Local 73 | 74 | diningPhilosophers :: Int -> IO () 75 | diningPhilosophers numPhilosophers = do 76 | let leftFork :: Philosopher -> Fork 77 | leftFork p = p 78 | 79 | let rightFork :: Philosopher -> Fork 80 | rightFork p = if p == numPhilosophers then 1 else p + 1 81 | 82 | let coroutine self = Coroutine 83 | { startingLabel = P 84 | 85 | , startingLocals = do 86 | let _hungry = True 87 | return Local{..} 88 | 89 | , process = do 90 | while (use (local.hungry)) do 91 | oldForks <- use (global.forks) 92 | 93 | let availableForks :: Philosopher -> [Fork] 94 | availableForks p = do 95 | x <- [ leftFork p, rightFork p ] 96 | Monad.guard (oldForks ^? ix x == Just Nothing) 97 | return x 98 | 99 | fork <- with (availableForks self) 100 | 101 | global.forks.ix fork .= Just self 102 | 103 | yield Eat 104 | 105 | newForks <- use (global.forks) 106 | 107 | let heldForks :: Philosopher -> [Fork] 108 | heldForks p = do 109 | x <- [ leftFork p, rightFork p ] 110 | Monad.guard (newForks ^? ix x == Just (Just p)) 111 | return x 112 | 113 | Monad.when (length (heldForks self) == 2) do 114 | local.hungry .= False 115 | global.forks.ix (leftFork self) .= Nothing 116 | global.forks.ix (rightFork self) .= Nothing 117 | } 118 | 119 | model defaultModel 120 | { startingGlobals = do 121 | let _forks = [ 1 .. numPhilosophers ] |-> \_fork -> Nothing 122 | return Global{..} 123 | 124 | , coroutine = traverse coroutine [ 1 .. numPhilosophers ] 125 | 126 | , property = true 127 | } 128 | 129 | test_diningPhilosophers :: TestTree 130 | test_diningPhilosophers = 131 | Failure.expectFailBecause "The original example has a deliberate deadlock" do 132 | HUnit.testCase "Dining philosophers" do 133 | diningPhilosophers 2 134 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | {-| This example is from the "Example: Rate Limiting" section of the "Learn 9 | TLA+" guide 10 | 11 | > ---- MODULE api ---- 12 | > EXTENDS Integers, TLC 13 | > (* --algorithm api 14 | > variables made_calls = 0, max_calls \in 5..10, reserved_calls = 0; 15 | > 16 | > 17 | > macro make_calls(n) begin 18 | > made_calls := made_calls + n; 19 | > assert made_calls <= max_calls; 20 | > end macro; 21 | > 22 | > 23 | > macro reserve(n) begin 24 | > await made_calls + reserved_calls + n <= max_calls; 25 | > reserved_calls := reserved_calls + n; 26 | > end macro 27 | > 28 | > process reset_limit = -1 29 | > begin 30 | > Reset: 31 | > while TRUE do 32 | > made_calls := 0; 33 | > end while 34 | > end process 35 | > 36 | > process get_collection = 0 37 | > begin 38 | > GCGetCalls: 39 | > reserve(1); 40 | > Request: 41 | > make_calls(1); 42 | > reserved_calls := reserved_calls - 1; 43 | > either goto GCGetCalls 44 | > or skip 45 | > end either; 46 | > end process; 47 | > 48 | > process get_put \in 1..3 49 | > begin 50 | > GPGetCalls: 51 | > reserve(2); 52 | > Call: 53 | > with c \in {1, 2} do 54 | > make_calls(c) 55 | > end with; 56 | > reserved_calls := reserved_calls - 2; 57 | > end process; 58 | > 59 | > end algorithm; *) 60 | 61 | -} 62 | 63 | module HasCal.Test.API where 64 | 65 | import HasCal 66 | import Prelude hiding ((.)) 67 | import Test.Tasty (TestTree) 68 | 69 | import qualified Test.Tasty.HUnit as HUnit 70 | 71 | data Global = Global 72 | { _made_calls :: Int 73 | , _max_calls :: Int 74 | , _reserved_calls :: Int 75 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 76 | 77 | data ResetLimitLabel = ResetBegin | Reset 78 | deriving (Eq, Generic, Hashable, Show, ToJSON) 79 | 80 | data GetCollectionLabel = GetCollectionBegin | GCGetCalls | Request 81 | deriving (Eq, Generic, Hashable, Show, ToJSON) 82 | 83 | data GetPutLabel = GetPutBegin | GPGetCalls | Call 84 | deriving (Eq, Generic, Hashable, Show, ToJSON) 85 | 86 | data Labels = Labels 87 | { _reset_limit :: ResetLimitLabel 88 | , _get_collection :: GetCollectionLabel 89 | , _get_put :: GetPutLabel 90 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 91 | 92 | makeLenses ''Global 93 | 94 | reserve :: Int -> Process Global local label () 95 | reserve n = do 96 | Global{..} <- use global 97 | 98 | await (_made_calls + _reserved_calls + n <= _max_calls) 99 | 100 | global.reserved_calls += n 101 | 102 | make_calls :: (Show local, ToJSON local) => Int -> Process Global local label () 103 | make_calls n = do 104 | global.made_calls += n 105 | 106 | Global{..} <- use global 107 | assert (_made_calls <= _max_calls) 108 | 109 | test_api :: TestTree 110 | test_api = HUnit.testCase "API" do 111 | let reset_limit = Coroutine 112 | { startingLabel = ResetBegin 113 | 114 | , startingLocals = pure () 115 | 116 | , process = do 117 | while true do 118 | yield Reset 119 | global.made_calls .= 0 120 | } 121 | 122 | let get_collection = Coroutine 123 | { startingLabel = GetCollectionBegin 124 | 125 | , startingLocals = pure () 126 | 127 | , process = do 128 | let gcGetCalls = do 129 | yield GCGetCalls 130 | 131 | reserve 1 132 | 133 | yield Request 134 | 135 | make_calls 1 136 | 137 | global.reserved_calls -= 1 138 | 139 | gcGetCalls <|> skip 140 | 141 | gcGetCalls 142 | } 143 | 144 | let get_put = Coroutine 145 | { startingLabel = GetPutBegin 146 | 147 | , startingLocals = pure () 148 | 149 | , process = do 150 | yield GPGetCalls 151 | 152 | reserve 2 153 | 154 | yield Call 155 | 156 | c <- with [ 1, 2 ] 157 | 158 | make_calls c 159 | 160 | global.reserved_calls -= 2 161 | } 162 | 163 | model defaultModel 164 | { startingGlobals = do 165 | let _made_calls = 0 166 | 167 | _max_calls <- [ 5 .. 10 ] 168 | 169 | let _reserved_calls = 0 170 | 171 | return Global{..} 172 | 173 | , coroutine = do 174 | _reset_limit <- reset_limit 175 | _get_collection <- get_collection 176 | _get_put <- get_put 177 | return Labels{..} 178 | 179 | , property = true 180 | 181 | , termination = False 182 | } 183 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/Market.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | {-| This example is from the "Example: Arbitrage" section of the "Learn TLA+" 11 | guide 12 | 13 | > ---- MODULE market ---- 14 | > EXTENDS Integers 15 | > CONSTANTS Item, MaxPrice, Vendor, MaxActions 16 | > 17 | > I == Item 18 | > V == Vendor 19 | > P == 1..MaxPrice 20 | > 21 | > ValidMarkets == [V \X I -> [buy : P, sell : P]] 22 | > 23 | > (* --algorithm market 24 | > variables market \in ValidMarkets, 25 | > backpack = {}, \* items we have 26 | > actions = 0, 27 | > profit = 0; 28 | > 29 | > begin 30 | > Act: 31 | > while actions < MaxActions do 32 | > either 33 | > Buy: 34 | > with v \in V, i \in Item \ backpack do 35 | > profit := profit - market[<>].sell; 36 | > backpack := backpack \union {i}; 37 | > end with; 38 | > or 39 | > Sell: 40 | > with v \in V, i \in backpack do 41 | > profit := profit + market[<>].buy; 42 | > backpack := backpack \ {i}; 43 | > end with; 44 | > end either; 45 | > Loop: 46 | > actions := actions + 1; 47 | > end while; 48 | > end algorithm; *) 49 | > 50 | > \* Translation 51 | > 52 | > NoArbitrage == profit <= 0 53 | > ==== 54 | 55 | -} 56 | module HasCal.Test.Market where 57 | 58 | import Data.Set (Set) 59 | import Prelude hiding (either, (.)) 60 | import HasCal 61 | import Test.Tasty (TestTree) 62 | 63 | import qualified Control.Monad as Monad 64 | import qualified Data.HashMap.Strict as HashMap 65 | import qualified Data.Set as Set 66 | import qualified Test.Tasty.HUnit as HUnit 67 | import qualified Test.Tasty.ExpectedFailure as Failure 68 | 69 | data Item = Ore | Sheep | Brick 70 | deriving (Eq, Hashable, Generic, Ord, Show, ToJSON, ToJSONKey, Universe) 71 | 72 | data Vendor = Alice 73 | deriving (Eq, Generic, Hashable, Show, ToJSON, Universe) 74 | 75 | data Offer = Offer { _buy :: !Int, _sell :: !Int } 76 | deriving (Eq, Generic, Hashable, Show, ToJSON) 77 | 78 | data Global = Global 79 | { _market :: !(HashMap (Vendor, Item) Offer) 80 | , _trades :: !(HashMap [Item] Item) 81 | , _backpack :: !(Set Item) 82 | , _profit :: !Int 83 | , _actions :: !Int 84 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 85 | 86 | data Label = Act | Buy | Sell | Trade | Loop 87 | deriving (Eq, Generic, Hashable, Show, ToJSON) 88 | 89 | makeLenses ''Offer 90 | makeLenses ''Global 91 | 92 | arbitrage :: Int -> Int -> IO () 93 | arbitrage maxPrice maxActions = do 94 | let _I = universe @Item 95 | let _V = universe @Vendor 96 | let _P = [ 1 .. maxPrice ] 97 | 98 | model defaultModel 99 | { startingGlobals = do 100 | let _domain = do 101 | v <- _V 102 | i <- _I 103 | return (v, i) 104 | 105 | let _range = do 106 | _buy <- _P 107 | _sell <- _P 108 | Monad.guard (_buy <= _sell) 109 | return Offer{..} 110 | 111 | _market <- _domain --> _range 112 | 113 | let validMarket = and do 114 | ((_, item0), Offer{ _buy }) <- HashMap.toList _market 115 | ((_, item1), Offer{ _sell }) <- HashMap.toList _market 116 | return (item0 == item1 ==> _buy <= _sell) 117 | 118 | Monad.guard validMarket 119 | 120 | _trades <- filter (\items -> 1 < length items) (subset _I) --> _I 121 | 122 | let _backpack = Set.empty 123 | 124 | let _profit = 0 125 | 126 | let _actions = 0 127 | 128 | return Global{..} 129 | 130 | , coroutine = Coroutine 131 | { startingLabel = Act 132 | 133 | , startingLocals = pure () 134 | 135 | , process = do 136 | while (do a <- use (global.actions); pure (a < maxActions)) do 137 | either 138 | [ do 139 | yield Buy 140 | _backpack <- use (global.backpack) 141 | v <- with _V 142 | i <- with (Set.toList (Set.difference (Set.fromList _I) _backpack)) 143 | Just loss <- preuse (global.market.ix (v, i).sell) 144 | global.profit -= loss 145 | global.backpack %= Set.insert i 146 | , do 147 | yield Sell 148 | _backpack <- use (global.backpack) 149 | v <- with _V 150 | i <- with (Set.toList _backpack) 151 | Just gain <- preuse (global.market.ix (v, i).buy) 152 | global.profit += gain 153 | global.backpack %= Set.delete i 154 | , do 155 | yield Trade 156 | _backpack <- use (global.backpack) 157 | _trades <- use (global.trades) 158 | itemsLost <- with (Set.toList (Set.intersection (Set.fromList (subset (Set.toList _backpack))) (Set.fromList (domain _trades)))) 159 | Just itemGained <- preuse (global.trades.ix itemsLost) 160 | global.backpack %= Set.insert itemGained . (`Set.difference` (Set.fromList itemsLost)) 161 | ] 162 | 163 | yield Loop 164 | global.actions += 1 165 | } 166 | 167 | , property = always . viewing (state . profit . to (<= 0)) 168 | } 169 | 170 | test_market :: TestTree 171 | test_market = 172 | Failure.expectFailBecause "The original example has a deliberate failure" do 173 | HUnit.testCase "Market" do 174 | arbitrage 6 5 175 | -------------------------------------------------------------------------------- /src/HasCal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE DerivingStrategies #-} 8 | {-# LANGUAGE DuplicateRecordFields #-} 9 | {-# LANGUAGE ExistentialQuantification #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | -- | This documentation assumes that you are already familiar with PlusCal and 18 | -- TLA+. If not, then you will probably want to read at least one of the 19 | -- following resources first: 20 | -- 21 | -- * 22 | -- * 23 | -- 24 | -- This package implements PlusCal as an embedded domain-specific language 25 | -- (i.e. eDSL) in Haskell. In other words, this does not compile to any 26 | -- intermediate or external language; the whole thing is implemented in pure 27 | -- Haskell. 28 | -- 29 | -- The package is organized into the following modules, which you should study 30 | -- in order if you want to learn more: 31 | -- 32 | -- "HasCal.Coroutine" provides the domain-specific language for creating and 33 | -- and model-checking concurrent `Coroutine`s 34 | -- 35 | -- "HasCal.Property" provides the the domain-specific language for creating and 36 | -- checking temporal `Property`s 37 | -- 38 | -- "HasCal.Expression" provides assorted utilities for non-temporal expressions 39 | -- 40 | -- … and you can import this module if you want an \"all-in-one\" import for 41 | -- convenience. 42 | -- 43 | -- As a complete example, you can translate this PlusCal program from the 44 | -- \"Learn TLA+\" guide: 45 | -- 46 | -- > ---- MODULE Transfer ---- 47 | -- > EXTENDS Naturals, TLC 48 | -- > 49 | -- > (* --algorithm transfer 50 | -- > variables alice_account = 10, bob_account = 10, 51 | -- > account_total = alice_account + bob_account; 52 | -- > 53 | -- > process Transfer \in 1..2 54 | -- > variable money \in 1..20; 55 | -- > begin 56 | -- > Transfer: 57 | -- > if alice_account >= money then 58 | -- > A: alice_account := alice_account - money; 59 | -- > bob_account := bob_account + money; 60 | -- > end if; 61 | -- > C: assert alice_account >= 0; 62 | -- > end process 63 | -- > 64 | -- > end algorithm *) 65 | -- > 66 | -- > MoneyInvariant == alice_account + bob_account = account_total 67 | -- > 68 | -- > ==== 69 | -- 70 | -- … into a Haskell program that is also model-checked within Haskell: 71 | -- 72 | -- @ 73 | -- {-# LANGUAGE BlockArguments #-} 74 | -- {-# LANGUAGE DeriveAnyClass #-} 75 | -- {-# LANGUAGE DeriveGeneric #-} 76 | -- {-# LANGUAGE RecordWildCards #-} 77 | -- {-# LANGUAGE TemplateHaskell #-} 78 | -- 79 | -- import "Control.Monad" (`Control.Monad.when`) 80 | -- import "Prelude" hiding ((`Prelude..`)) 81 | -- import "HasCal" 82 | -- 83 | -- data Global = Global 84 | -- { _alice_account :: `Int` 85 | -- , _bob_account :: `Int` 86 | -- , _account_total :: `Int` 87 | -- } deriving (`Eq`, `Generic`, `Hashable`, `Show`, `ToJSON`) 88 | -- 89 | -- data Local = Local { _money :: `Int` } 90 | -- deriving (`Eq`, `Generic`, `Hashable`, `Show`, `ToJSON`) 91 | -- 92 | -- data Label = Transfer | A | C deriving (`Eq`, `Generic`, `Hashable`, `Show`, `ToJSON`) 93 | -- 94 | -- `Control.TH.makeLenses` ''Global 95 | -- `Control.TH.makeLenses` ''Local 96 | -- 97 | -- main :: `IO` () 98 | -- main = do 99 | -- let transfer _ = `Coroutine` 100 | -- { startingLabel = Transfer 101 | -- 102 | -- , startingLocals = do 103 | -- _money <- [ 1 .. 20 ] 104 | -- `return` Local{..} 105 | -- 106 | -- , process = do 107 | -- _money <- `use` (local.money) 108 | -- 109 | -- alice_old <- `use` (global.alice_account) 110 | -- 111 | -- when (alice_old `>=` _money) do 112 | -- `yield` A 113 | -- global.alice_account `-=` _money 114 | -- global.bob_account `+=` _money 115 | -- 116 | -- `yield` C 117 | -- alice_new <- `use` (global.alice_account) 118 | -- `assert` (alice_new `>=` 0) 119 | -- } 120 | -- 121 | -- `model` `defaultModel` 122 | -- { startingGlobals = do 123 | -- let _alice_account = 10 124 | -- let _bob_account = 10 125 | -- let _account_total = _alice_account `+` _bob_account 126 | -- `return` Global{..} 127 | -- 128 | -- , coroutine = `traverse` transfer [ 1 .. 2 ] 129 | -- 130 | -- , property = 131 | -- let predicate (Global{..}, _) = 132 | -- _alice_account `+` _bob_account `==` _account_total 133 | -- in `always` . `arr` predicate 134 | -- } 135 | -- @ 136 | 137 | module HasCal 138 | ( -- * Internal re-exports 139 | module HasCal.Expression 140 | , module HasCal.Property 141 | , module HasCal.Coroutine 142 | 143 | -- * External re-exports 144 | , module Lens.Micro.Platform 145 | , Generic 146 | , HashMap 147 | , Alternative(..) 148 | , Hashable 149 | , MonadIO(..) 150 | , ToJSON(..) 151 | , ToJSONKey(..) 152 | , Category(..) 153 | , Arrow(..) 154 | , Profunctor(..) 155 | , for_ 156 | , traverse_ 157 | ) where 158 | 159 | import Control.Arrow (Arrow(..)) 160 | import Control.Applicative (Alternative(..)) 161 | import Control.Category (Category(..)) 162 | import Control.Monad.IO.Class (MonadIO(..)) 163 | import Data.Aeson (ToJSON(..), ToJSONKey(..)) 164 | import Data.Foldable (for_, traverse_) 165 | import Data.Hashable (Hashable) 166 | import Data.HashMap.Strict (HashMap) 167 | import Data.Profunctor (Profunctor(..)) 168 | import GHC.Generics (Generic) 169 | import HasCal.Expression 170 | import HasCal.Property 171 | import HasCal.Coroutine 172 | import Lens.Micro.Platform 173 | 174 | -- TODO: Associate local state with process names 175 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/FIFO.hs: -------------------------------------------------------------------------------- 1 | {-| This is based on the [Channel module](https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/FIFO/Channel.tla) 2 | from figure 3.2 on page 30 in Lamport's \"Specifying Systems\" book: 3 | 4 | > -------------------------- MODULE Channel ----------------------------- 5 | > EXTENDS Naturals 6 | > CONSTANT Data 7 | > VARIABLE chan 8 | > 9 | > TypeInvariant == chan \in [val : Data, rdy : {0, 1}, ack : {0, 1}] 10 | > ----------------------------------------------------------------------- 11 | > Init == /\ TypeInvariant 12 | > /\ chan.ack = chan.rdy 13 | > 14 | > Send(d) == /\ chan.rdy = chan.ack 15 | > /\ chan' = [chan EXCEPT !.val = d, !.rdy = 1 - @] 16 | > 17 | > Rcv == /\ chan.rdy # chan.ack 18 | > /\ chan' = [chan EXCEPT !.ack = 1 - @] 19 | > 20 | > Next == (\E d \in Data : Send(d)) \/ Rcv 21 | > 22 | > Spec == Init /\ [][Next]_chan 23 | > ----------------------------------------------------------------------- 24 | > THEOREM Spec => []TypeInvariant 25 | > ======================================================================= 26 | 27 | … and the [InnerFIFO module](https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/FIFO/InnerFIFO.tla) 28 | from figure 4.1 on page 38 in Lamport's \"Specifying Systems\" book: 29 | 30 | > ---------------------------- MODULE InnerFIFO ------------------------------- 31 | > EXTENDS Naturals, Sequences 32 | > CONSTANT Message 33 | > VARIABLES in, out, q 34 | > InChan == INSTANCE Channel WITH Data <- Message, chan <- in 35 | > OutChan == INSTANCE Channel WITH Data <- Message, chan <- out 36 | > ----------------------------------------------------------------------------- 37 | > Init == /\ InChan!Init 38 | > /\ OutChan!Init 39 | > /\ q = << >> 40 | > 41 | > TypeInvariant == /\ InChan!TypeInvariant 42 | > /\ OutChan!TypeInvariant 43 | > /\ q \in Seq(Message) 44 | > 45 | > SSend(msg) == /\ InChan!Send(msg) \* Send msg on channel `in'. 46 | > /\ UNCHANGED <> 47 | > 48 | > BufRcv == /\ InChan!Rcv \* Receive message from channel `in'. 49 | > /\ q' = Append(q, in.val) \* and append it to tail of q. 50 | > /\ UNCHANGED out 51 | > 52 | > BufSend == /\ q # << >> \* Enabled only if q is nonempty. 53 | > /\ OutChan!Send(Head(q)) \* Send Head(q) on channel `out' 54 | > /\ q' = Tail(q) \* and remove it from q. 55 | > /\ UNCHANGED in 56 | > 57 | > RRcv == /\ OutChan!Rcv \* Receive message from channel `out'. 58 | > /\ UNCHANGED <> 59 | > 60 | > Next == \/ \E msg \in Message : SSend(msg) 61 | > \/ BufRcv 62 | > \/ BufSend 63 | > \/ RRcv 64 | > 65 | > Spec == Init /\ [][Next]_<> 66 | > ----------------------------------------------------------------------------- 67 | > THEOREM Spec => []TypeInvariant 68 | > ============================================================================= 69 | 70 | … and the [FIFO example](https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/FIFO/FIFO.tla) 71 | on page 41: 72 | 73 | > ------------------------ MODULE FIFO ------------------------- 74 | > CONSTANT Message 75 | > VARIABLES in, out 76 | > Inner(q) == INSTANCE InnerFIFO 77 | > Spec == \EE q : Inner(q)!Spec 78 | > ============================================================== 79 | 80 | For the @Channel@ we reuse the "HasCal.Test.AsyncInterface" module, but 81 | the other two modules we inline here. 82 | -} 83 | 84 | {-# LANGUAGE ApplicativeDo #-} 85 | {-# LANGUAGE BlockArguments #-} 86 | {-# LANGUAGE DeriveAnyClass #-} 87 | {-# LANGUAGE DeriveGeneric #-} 88 | {-# LANGUAGE NamedFieldPuns #-} 89 | {-# LANGUAGE RecordWildCards #-} 90 | {-# LANGUAGE TemplateHaskell #-} 91 | 92 | module HasCal.Test.FIFO where 93 | 94 | import Data.Sequence (Seq, ViewL(..), (|>)) 95 | import HasCal 96 | import HasCal.Test.AsyncInterface (Chan, Data, val) 97 | import Prelude hiding ((.)) 98 | import Test.Tasty (TestTree) 99 | 100 | import qualified Control.Monad as Monad 101 | import qualified Data.Sequence as Seq 102 | import qualified HasCal.Test.AsyncInterface as Channel 103 | import qualified Test.Tasty.HUnit as HUnit 104 | 105 | data Global = Global 106 | { _inChannel :: Chan 107 | , _outChannel :: Chan 108 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 109 | 110 | data Local = Local { _q :: Seq Data } 111 | deriving (Eq, Generic, Hashable, Show, ToJSON) 112 | 113 | data Label = Init | SSend | BufRcv | BufSend | RRcv 114 | deriving (Eq, Generic, Hashable, Show, ToJSON) 115 | 116 | makeLenses ''Global 117 | makeLenses ''Local 118 | 119 | -- There's technically no need to rename `channelModel` to `inChan` / `outChan`. 120 | -- since they're pure and instantiated identically. We could have just used 121 | -- `channelModel` directly in their place. These synonyms are just to show the 122 | -- correspondence to the TLA+ model. 123 | 124 | inChan :: Model Chan Channel.Label 125 | inChan = Channel.channelModel 126 | 127 | outChan :: Model Chan Channel.Label 128 | outChan = Channel.channelModel 129 | 130 | test_asyncInterface :: TestTree 131 | test_asyncInterface = HUnit.testCase "FIFO" do 132 | model defaultModel 133 | { termination = termination inChan /\ termination outChan 134 | 135 | , startingGlobals = do 136 | _inChannel <- startingGlobals inChan 137 | _outChannel <- startingGlobals outChan 138 | return Global{..} 139 | 140 | , coroutine = Coroutine 141 | { startingLabel = Init 142 | 143 | , startingLocals = do 144 | let _q = mempty 145 | return Local{..} 146 | 147 | , process = do 148 | let ssend = do 149 | _q <- use (local.q) 150 | await (Seq.length _q <= 3) 151 | msg <- with universe 152 | zoomProcess inChannel (Channel.send msg) 153 | 154 | let bufRcv = do 155 | zoomProcess inChannel Channel.rcv 156 | _val <- use (global.inChannel.val) 157 | local.q %= (|> _val) 158 | 159 | let bufSend = do 160 | _q <- use (local.q) 161 | 162 | case Seq.viewl _q of 163 | h :< t -> do 164 | zoomProcess outChannel (Channel.send h) 165 | local.q .= t 166 | EmptyL -> 167 | empty 168 | 169 | let rRcv = do 170 | zoomProcess outChannel Channel.rcv 171 | 172 | Monad.forever 173 | ( (do ssend ; yield SSend ) 174 | <|> (do bufRcv ; yield BufRcv ) 175 | <|> (do bufSend; yield BufSend) 176 | <|> (do rRcv ; yield RRcv ) 177 | ) 178 | } 179 | 180 | , property = true 181 | } 182 | -------------------------------------------------------------------------------- /tasty/HasCal/Test/InternalMemory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | {-| This is based on the [InternalMemory module](https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/CachingMemory/InternalMemory.tla) 8 | from figure 5.2 on page 52 in Lamport's \"Specifying Systems\" book: 9 | 10 | > ------------------ MODULE InternalMemory --------------------- 11 | > EXTENDS MemoryInterface 12 | > VARIABLES mem, ctl, buf 13 | > -------------------------------------------------------------- 14 | > IInit == /\ mem \in [Adr->Val] 15 | > /\ ctl = [p \in Proc |-> "rdy"] 16 | > /\ buf = [p \in Proc |-> NoVal] 17 | > /\ memInt \in InitMemInt 18 | > 19 | > TypeInvariant == 20 | > /\ mem \in [Adr->Val] 21 | > /\ ctl \in [Proc -> {"rdy", "busy","done"}] 22 | > /\ buf \in [Proc -> MReq \cup Val \cup {NoVal}] 23 | > 24 | > Req(p) == /\ ctl[p] = "rdy" 25 | > /\ \E req \in MReq : 26 | > /\ Send(p, req, memInt, memInt') 27 | > /\ buf' = [buf EXCEPT ![p] = req] 28 | > /\ ctl' = [ctl EXCEPT ![p] = "busy"] 29 | > /\ UNCHANGED mem 30 | > 31 | > Do(p) == 32 | > /\ ctl[p] = "busy" 33 | > /\ mem' = IF buf[p].op = "Wr" 34 | > THEN [mem EXCEPT ![buf[p].adr] = buf[p].val] 35 | > ELSE mem 36 | > /\ buf' = [buf EXCEPT ![p] = IF buf[p].op = "Wr" 37 | > THEN NoVal 38 | > ELSE mem[buf[p].adr]] 39 | > /\ ctl' = [ctl EXCEPT ![p] = "done"] 40 | > /\ UNCHANGED memInt 41 | > 42 | > Rsp(p) == /\ ctl[p] = "done" 43 | > /\ Reply(p, buf[p], memInt, memInt') 44 | > /\ ctl' = [ctl EXCEPT ![p]= "rdy"] 45 | > /\ UNCHANGED <> 46 | > 47 | > INext == \E p \in Proc: Req(p) \/ Do(p) \/ Rsp(p) 48 | > 49 | > ISpec == IInit /\ [][INext]_<> 50 | > -------------------------------------------------------------- 51 | > THEOREM ISpec => []TypeInvariant 52 | > ============================================================== 53 | 54 | … and the [MemoryInterface module](https://raw.githubusercontent.com/tlaplus/Examples/master/specifications/SpecifyingSystems/CachingMemory/MemoryInterface.tla) 55 | from figure 5.1 on page 48 in Lamport's \"Specifying Systems\" book: 56 | 57 | > -------------------------- MODULE MemoryInterface --------------------------- 58 | > VARIABLE memInt 59 | > CONSTANTS Send(_, _, _, _), 60 | > Reply(_, _, _, _), 61 | > InitMemInt, 62 | > Proc, 63 | > Adr, 64 | > Val 65 | > 66 | > (***************************************************************************) 67 | > (* We comment out the assumption because TLC cannot handle unbounded *) 68 | > (* quantifiers. *) 69 | > (***************************************************************************) 70 | > \* ASSUME \A p, d, miOld, miNew : 71 | > \* /\ Send(p,d,miOld,miNew) \in BOOLEAN 72 | > \* /\ Reply(p,d,miOld,miNew) \in BOOLEAN 73 | > 74 | > ----------------------------------------------------------------------------- 75 | > MReq == [op : {"Rd"}, adr: Adr] 76 | > \cup [op : {"Wr"}, adr: Adr, val : Val] 77 | > 78 | > NoVal == CHOOSE v : v \notin Val 79 | > ============================================================================= 80 | -} 81 | module HasCal.Test.InternalMemory where 82 | 83 | import HasCal 84 | import Prelude hiding ((.)) 85 | import Test.Tasty (TestTree) 86 | 87 | import qualified Control.Monad as Monad 88 | import qualified Test.Tasty.HUnit as HUnit 89 | 90 | data Adr = A1 | A2 | A3 91 | deriving (Eq, Generic, Hashable, Show, ToJSON, ToJSONKey, Universe) 92 | 93 | data Proc = P1 | P2 94 | deriving (Eq, Generic, Hashable, Show, ToJSONKey, ToJSON, Universe) 95 | 96 | data Val = V1 | V2 97 | deriving (Eq, Generic, Hashable, Show, ToJSON, Universe) 98 | 99 | data Local = Local 100 | { _mem :: HashMap Adr Val 101 | , _ctl :: HashMap Proc Ctl 102 | , _buf :: HashMap Proc Buf 103 | , _memInt :: (Proc, Buf) 104 | } deriving (Eq, Generic, Hashable, Show, ToJSON) 105 | 106 | data Ctl = Rdy | Busy | Done 107 | deriving (Eq, Generic, Hashable, Show, ToJSON) 108 | 109 | data Buf 110 | = Rd { _adr :: Adr } 111 | | Wr { _adr :: Adr, _val :: Val } 112 | | Val Val 113 | | NoVal 114 | deriving (Eq, Generic, Hashable, Show, ToJSON, Universe) 115 | 116 | data Label = Init | Req | Do | Rsp 117 | deriving (Eq, Generic, Hashable, Show, ToJSON) 118 | 119 | makeLenses ''Local 120 | 121 | -- https://github.com/tlaplus/Examples/blob/master/specifications/SpecifyingSystems/Liveness/MCInternalMemory.tla#L36-L37 122 | send :: Proc -> Buf -> Process () Local Label () 123 | send p d = local.memInt .= (p, d) 124 | 125 | reply :: Proc -> Buf -> Process () Local Label () 126 | reply p d = local.memInt .= (p, d) 127 | 128 | test_internalMemory :: TestTree 129 | test_internalMemory = HUnit.testCase "Internal memory" do 130 | model defaultModel 131 | { termination = False 132 | 133 | , startingGlobals = pure () 134 | 135 | , coroutine = Coroutine 136 | { startingLabel = Init 137 | 138 | , startingLocals = do 139 | _mem <- universe --> universe 140 | let _ctl = universe |-> \_p -> Rdy 141 | let _buf = universe |-> \_p -> NoVal 142 | let _memInt = (P1, NoVal) 143 | return Local{..} 144 | 145 | , process = Monad.forever do 146 | p <- with universe 147 | 148 | Just _ctl <- preuse (local.ctl.ix p) 149 | 150 | case _ctl of 151 | Rdy -> do 152 | yield Req 153 | 154 | req <- with universe 155 | 156 | send p req 157 | 158 | local.buf.ix p .= req 159 | 160 | local.ctl.ix p .= Busy 161 | 162 | Busy -> do 163 | yield Do 164 | 165 | Just _buf <- preuse (local.buf.ix p) 166 | 167 | case _buf of 168 | Wr{..} -> do 169 | local.mem.ix _adr .= _val 170 | 171 | local.buf.ix p .= NoVal 172 | 173 | Rd{..} -> do 174 | Just _val <- preuse (local.mem.ix _adr) 175 | 176 | local.buf.ix p .= Val _val 177 | 178 | _ -> do 179 | skip 180 | 181 | local.ctl.ix p .= Done 182 | 183 | Done -> do 184 | yield Rsp 185 | 186 | Just _buf <- preuse (local.buf.ix p) 187 | 188 | reply p _buf 189 | 190 | local.ctl.ix p .= Rdy 191 | } 192 | 193 | , property = true 194 | } 195 | -------------------------------------------------------------------------------- /src/HasCal/Expression.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-| This module contains utilities that correspond to TLA+ expressions 10 | 11 | Note that most TLA+ functionality is covered either by Haskell's standard 12 | library (for non-temporal expressions) and the "Temporal.Property" module 13 | (for temporal expression). This module only adds a few missing utilities 14 | not covered by either of those two for parity with TLA+ and also to use 15 | names more familiar to TLA+ users. 16 | -} 17 | module HasCal.Expression 18 | ( -- * TLA+ expressions 19 | forall_ 20 | , exists_ 21 | , Boolean(..) 22 | , (==>) 23 | , (<=>) 24 | , boolean 25 | , (-->) 26 | , (|->) 27 | , domain 28 | , range 29 | , subset 30 | , choose 31 | 32 | -- * Universe 33 | , Universe(..) 34 | ) where 35 | 36 | import Control.Applicative (Alternative(..), liftA2) 37 | import Data.Hashable (Hashable) 38 | import Data.HashMap.Strict (HashMap) 39 | import Data.Monoid (Ap(..)) 40 | import GHC.Generics 41 | 42 | import qualified Control.Monad as Monad 43 | import qualified Data.Foldable as Foldable 44 | import qualified Data.HashMap.Strict as HashMap 45 | import qualified Data.List as List 46 | 47 | {- $setup 48 | 49 | >>> import Data.Functor.Identity (Identity(..)) 50 | >>> import Data.List.NonEmpty (NonEmpty(..)) 51 | -} 52 | 53 | {-| Verify that all elements satisfy the given predicate, like @\\A@ in TLA+ 54 | 55 | `forall_` is like `all` but with the arguments `flip`ped. 56 | 57 | For example, the following TLA+ code: 58 | 59 | > \A i \in 1 .. 3 : 0 < i 60 | 61 | … would correspond to this Haskell code: 62 | 63 | >>> forall_ [ 1 .. 3 ] (\i -> 0 < i) 64 | True 65 | 66 | `forall_` obeys the following laws: 67 | 68 | @ 69 | `forall_` [] f = `True` 70 | 71 | `forall_` (xs `++` ys) f = `forall_` xs f `&&` `forall_` ys f 72 | 73 | `forall_` [ x ] f = f x 74 | @ 75 | -} 76 | forall_ :: Foldable list => list a -> (a -> Bool) -> Bool 77 | forall_ = flip all 78 | {-# INLINABLE forall_ #-} 79 | 80 | {-| Verify that any element satisfies the given predicate, like @\\E@ in TLA+ 81 | 82 | `exists_` is like `any` but with the arguments `flip`ped 83 | 84 | For example, the following TLA+ code: 85 | 86 | > \E i in 1 .. 3 : i = 3 87 | 88 | … would correspond to this Haskell code: 89 | 90 | >>> exists_ [ 1 .. 3 ] (\i -> i == 3) 91 | True 92 | 93 | `exists_` obeys the following laws: 94 | 95 | @ 96 | `exists_` [] f = `False` 97 | 98 | `exists_` (xs `++` ys) f = `exists_` xs f `||` exists_ ys f 99 | 100 | `exists_` [ x ] f = f x 101 | @ 102 | -} 103 | exists_ :: Foldable list => list a -> (a -> Bool) -> Bool 104 | exists_ = flip any 105 | {-# INLINABLE exists_ #-} 106 | 107 | {-| A class for types that support boolean algebra 108 | 109 | Laws: 110 | 111 | @ 112 | (x `/\` y) `/\` z = x `/\` (y `/\` z) 113 | 114 | x `/\` `true` = x 115 | 116 | `true` `/\` x = x 117 | @ 118 | 119 | @ 120 | (x `\/` y) `\/` z = x `\/` (y `\/` z) 121 | 122 | x `\/` `false` = x 123 | 124 | `false` `\/` x = x 125 | @ 126 | 127 | @ 128 | `false` `/\` x = `false` 129 | 130 | x `/\` `false` = `false` 131 | 132 | `true` `/\` x = `true` 133 | 134 | x `/\` `true` = `true` 135 | @ 136 | 137 | @ 138 | (x `===` y) `===` z = x `===` (y `===` z) 139 | 140 | x `===` `true` = x 141 | 142 | `true` `===` x = x 143 | @ 144 | 145 | @ 146 | (x `=/=` y) `=/=` z = x `=/=` (y `=/=` z) 147 | 148 | x `=/=` `false` = x 149 | 150 | `false` `=/=` x = x 151 | @ 152 | -} 153 | class Boolean a where 154 | -- | Generalizes `True` 155 | true :: a 156 | 157 | -- | Generalizes `False` 158 | false :: a 159 | 160 | -- | Generalizes `&&` 161 | (/\) :: a -> a -> a 162 | 163 | -- | Generalizes `||` 164 | (\/) :: a -> a -> a 165 | 166 | -- | Generalizes `==` on `Bool`s 167 | (===) :: a -> a -> a 168 | 169 | -- | Generalizes `/=` on `Bool`s 170 | (=/=) :: a -> a -> a 171 | 172 | infixr 3 /\ 173 | infixr 2 \/ 174 | infixr 4 === 175 | infixr 4 =/= 176 | 177 | instance Boolean Bool where 178 | true = True 179 | 180 | false = False 181 | 182 | (/\) = (&&) 183 | 184 | (\/) = (||) 185 | 186 | (===) = (==) 187 | 188 | (=/=) = (/=) 189 | 190 | instance Boolean b => Boolean (a -> b) where 191 | true = pure true 192 | 193 | false = pure false 194 | 195 | (/\) = liftA2 (/\) 196 | 197 | (\/) = liftA2 (\/) 198 | 199 | (===) = liftA2 (===) 200 | 201 | (=/=) = liftA2 (=/=) 202 | 203 | instance (Applicative f, Boolean a) => Boolean (Ap f a) where 204 | true = Ap (pure true) 205 | 206 | false = Ap (pure false) 207 | 208 | Ap l /\ Ap r = Ap (liftA2 (/\) l r) 209 | 210 | Ap l \/ Ap r = Ap (liftA2 (\/) l r) 211 | 212 | Ap l === Ap r = Ap (liftA2 (===) l r) 213 | 214 | Ap l =/= Ap r = Ap (liftA2 (=/=) l r) 215 | 216 | {-| Logical implication, like @=>@ in TLA+ 217 | 218 | @p `==>` q@ is the same as \"if @p@ then @q@\" 219 | 220 | @ 221 | p `==>` q = (p `===` `false`) `\/` q 222 | @ 223 | -} 224 | (==>) :: Boolean bool => bool -> bool -> bool 225 | p ==> q = (p === false) \/ q 226 | {-# INLINABLE (==>) #-} 227 | 228 | {-| Bidirectional logical implication, like @<=>@ in TLA+ 229 | 230 | @p `<=>` q@ is the same as \"if and only if @p@ then @q@\" 231 | 232 | @ 233 | p `<=>` q = (p `==>` q) `&&` (q `==>` p) 234 | @ 235 | -} 236 | (<=>) :: Boolean bool => bool -> bool -> bool 237 | p <=> q = (p ==> q) /\ (q ==> p) 238 | {-# INLINABLE (<=>) #-} 239 | 240 | infixr 1 ==>, <=> 241 | 242 | {-| All possible boolean values, like the @BOOLEAN@ set in TLA+ 243 | 244 | @ 245 | `boolean` = `universe` @`Bool` 246 | @ 247 | -} 248 | boolean :: [Bool] 249 | boolean = universe @Bool 250 | 251 | {-| A function set, like the @->@ operator in TLA+ 252 | 253 | >>> [ 1, 2 ] --> [ False, True ] 254 | [fromList [(1,False),(2,False)],fromList [(1,False),(2,True)],fromList [(1,True),(2,False)],fromList [(1,True),(2,True)]] 255 | 256 | This operator also supports ranges and domains other than lists. For 257 | example, you can limit the domain or range to only one value by using 258 | `Data.Functor.Identity.Identity` instead of a list: 259 | 260 | >>> [ 1, 2 ] --> Identity True 261 | Identity (fromList [(1,True),(2,True)]) 262 | 263 | >>> Identity 1 --> [ False, True ] 264 | [fromList [(1,False)],fromList [(1,True)]] 265 | 266 | >>> Identity 1 --> Identity True 267 | Identity (fromList [(1,True)]) 268 | 269 | … and if the range has only one value then there will only be one 270 | \"function\" in the function set. 271 | 272 | This operator also works with `Maybe` for the domain or range: 273 | 274 | >>> [ 1, 2 ] --> Just True 275 | Just (fromList [(1,True),(2,True)]) 276 | 277 | >>> [ 1, 2 ] --> Nothing 278 | Nothing 279 | 280 | >>> Just 1 --> [ True, False ] 281 | [fromList [(1,True)],fromList [(1,False)]] 282 | 283 | >>> Nothing --> [ True, False ] 284 | [fromList []] 285 | 286 | … and also `Data.List.NonEmpty.NonEmpty` lists: 287 | 288 | >>> [ 1, 2 ] --> (False :| [ True ]) 289 | fromList [(1,False),(2,False)] :| [fromList [(1,False),(2,True)],fromList [(1,True),(2,False)],fromList [(1,True),(2,True)]] 290 | 291 | >>> (1 :| [ 2 ]) --> [ False, True ] 292 | [fromList [(1,False),(2,False)],fromList [(1,False),(2,True)],fromList [(1,True),(2,False)],fromList [(1,True),(2,True)]] 293 | -} 294 | (-->) 295 | :: (Traversable domain, Applicative range, Eq key, Hashable key) 296 | => domain key 297 | -- ^ Domain 298 | -> range value 299 | -- ^ Range 300 | -> range (HashMap key value) 301 | keys --> values = 302 | fmap (HashMap.fromList . Foldable.toList) (traverse process keys) 303 | where 304 | process key = fmap ((,) key) values 305 | 306 | {-| A function set, like the @|->@ operator in TLA+ 307 | 308 | For example, the following TLA+ code: 309 | 310 | > [ i \in 1 .. 3 |-> i + 1 ] 311 | 312 | … would correspond to this Haskell code: 313 | 314 | >>> [ 1 .. 3 ] |-> \i -> i + 1 315 | fromList [(1,2),(2,3),(3,4)] 316 | -} 317 | (|->) 318 | :: (Foldable list, Functor list, Eq key, Hashable key) 319 | => list key -> (key -> value) -> HashMap key value 320 | keys |-> function = HashMap.fromList (Foldable.toList (fmap adapt keys)) 321 | where 322 | adapt key = (key, function key) 323 | 324 | {-| The domain of a function set, like the @DOMAIN@ function in TLA+ 325 | 326 | `domain` is a synonym for @"Data.HashMap.Strict".`HashMap.keys`@. 327 | -} 328 | domain :: HashMap key value -> [key] 329 | domain = HashMap.keys 330 | {-# INLINE domain #-} 331 | 332 | {-| The range of a function set, like the @RANGE@ function that TLA+ projects 333 | commonly define 334 | 335 | `range` is a synonym for @"Data.HashMap.Strict".`HashMap.elems`@. 336 | -} 337 | range :: HashMap key value -> [value] 338 | range = HashMap.elems 339 | {-# INLINE range #-} 340 | 341 | {-| The powerset of a list, like the @SUBSET@ function in TLA+ 342 | 343 | >>> subset [ 1, 2, 3 ] 344 | [[],[3],[2],[2,3],[1],[1,3],[1,2],[1,2,3]] 345 | -} 346 | subset :: [a] -> [[a]] 347 | subset = Monad.filterM (\_ -> [False, True]) 348 | 349 | {-| Find the first matching element, like the @CHOOSE@ function in TLA+ except 350 | that this will return a `Nothing` instead of throwing an exception 351 | 352 | `choose` is like `List.find`, but with the arguments `flip`ped. 353 | 354 | For example, the following TLA+ code: 355 | 356 | > CHOOSE i \in 1 .. 3 : 1 < i 357 | 358 | … would correspond to this Haskell code: 359 | 360 | >>> choose [ 1 .. 3 ] (\i -> 1 < i ) 361 | Just 2 362 | 363 | `choose` obeys the following laws: 364 | 365 | @ 366 | `choose` `Control.Applicative.empty` f = `Control.Applicative.empty` 367 | 368 | `choose` (xs `Control.Applicative.<|>` ys) f = `choose` xs f `Control.Applicative.<|>` `choose` ys f 369 | @ 370 | 371 | … or equivalently: 372 | 373 | @ 374 | `choose` [] f = `Nothing` 375 | 376 | `choose` (xs `++` ys) f = `choose` xs f `Control.Applicative.<|>` `choose` ys f 377 | @ 378 | 379 | -} 380 | choose :: Foldable list => list a -> (a -> Bool) -> Maybe a 381 | choose = flip List.find 382 | {-# INLINABLE choose #-} 383 | 384 | -- | A type where all possible values can be enumerated as a list 385 | -- 386 | -- You can derive `Universe` for any type that implements `Generic`: 387 | -- 388 | -- @ 389 | -- {-# LANGUAGE DerivingStrategies #-} 390 | -- {-# LANGUAGE DeriveAnyClass #-} 391 | -- {-# LANGUAGE DeriveGeneric #-} 392 | -- 393 | -- data Example = … 394 | -- deriving stock (`Generic`) 395 | -- deriving anyclass (`Universe`) 396 | -- @ 397 | class Universe a where 398 | universe :: [a] 399 | default universe :: (Generic a, GenericUniverse (Rep a)) => [a] 400 | universe = fmap to genericUniverse 401 | 402 | deriving anyclass instance Universe () 403 | 404 | deriving anyclass instance Universe Bool 405 | 406 | class GenericUniverse f where 407 | genericUniverse :: [f a] 408 | 409 | instance GenericUniverse f => GenericUniverse (M1 i t f) where 410 | genericUniverse = fmap M1 genericUniverse 411 | 412 | instance GenericUniverse U1 where 413 | genericUniverse = pure U1 414 | 415 | instance GenericUniverse V1 where 416 | genericUniverse = empty 417 | 418 | instance (GenericUniverse l, GenericUniverse r) => GenericUniverse (l :*: r) where 419 | genericUniverse = do 420 | l <- genericUniverse 421 | r <- genericUniverse 422 | return (l :*: r) 423 | 424 | instance (GenericUniverse l, GenericUniverse r) => GenericUniverse (l :+: r) where 425 | genericUniverse = fmap L1 genericUniverse <|> fmap R1 genericUniverse 426 | 427 | instance Universe c => GenericUniverse (K1 i c) where 428 | genericUniverse = fmap K1 universe 429 | -------------------------------------------------------------------------------- /src/HasCal/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE ExistentialQuantification #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | 12 | {-| This module implements support for temporal logic 13 | 14 | Specifically, the module provides a temporal `Property` type and utilities 15 | for creating and checking `Property`s against sequences of inputs and 16 | outputs 17 | -} 18 | 19 | module HasCal.Property 20 | ( 21 | -- * Property 22 | Property 23 | , eventually 24 | , always 25 | , (~>) 26 | , viewing 27 | , prime 28 | , following 29 | , infer 30 | 31 | -- * Check 32 | , Check(..) 33 | , check 34 | , checkList 35 | ) where 36 | 37 | import Control.Applicative (liftA2) 38 | import Control.Arrow (Arrow(..)) 39 | import Control.Category (Category(..)) 40 | import Control.Monad.Trans.State (State, StateT(..)) 41 | import Data.Hashable (Hashable(..)) 42 | import Data.Monoid (Ap(..)) 43 | import Data.Profunctor (Profunctor(..)) 44 | import GHC.Generics (Generic) 45 | import HasCal.Expression (Boolean(..), Universe(..), (==>)) 46 | import Lens.Micro.Platform (Getting) 47 | import Prelude hiding (id, (.)) 48 | 49 | import qualified Control.Monad as Monad 50 | import qualified Control.Monad.Trans.State as State 51 | import qualified Data.HashSet as HashSet 52 | import qualified Data.HashMap.Strict as HashMap 53 | import qualified Lens.Micro.Platform as Lens 54 | 55 | {- $setup 56 | 57 | >>> :m -Prelude 58 | >>> import Prelude hiding ((.), id) 59 | >>> import HasCal 60 | -} 61 | 62 | {-| A temporal `Property` is a stateful transformation from an @input@ to an 63 | @output@ 64 | 65 | The type variables are: 66 | 67 | * @input@: The type of the input to the property 68 | * @output@: The type of the output that changes in response to the input 69 | 70 | You can create a `Property` using: 71 | 72 | * `arr` - Lift a pure function from an @input@ to an @output@ into the 73 | equivalent `Property` 74 | * `eventually` - A `Property` that @output@s `True` if the @input@ will 75 | `eventually` be `True` (either now or in the future) 76 | * `always` - A `Property` that @output@s `True` if the @input@ will `always` 77 | be `True` (both now and in the future) 78 | * `id` - The trivial `Property` whose @output@ always matches the @input@ 79 | * `pure` - A `Property` with a constant @output@ that ignores the @input@ 80 | * `mempty` - A `Property` with a constant empty @output@ 81 | * A numeric literal - A `Property` with a constant numeric @output@ 82 | 83 | You can combine one or more `Property`s using: 84 | 85 | * (`.`) - You can compose two `Property`s end-to-end, feeding the @output@ 86 | of one property as the @input@ to another `Property` 87 | * `Applicative` operations (or @do@ notation if you enable @ApplicativeDo@) 88 | - this shares their @input@ and combines their @output@s pointwise 89 | * (`<>`) - This combines their @output@s pointwise using (`<>`) 90 | * Numeric operators - These operators combine their @output@s pointwise 91 | 92 | You can transform a `Property` using: 93 | 94 | * `fmap` - Transform the @output@ 95 | * `lmap` - Transform the @input@ 96 | 97 | You can consume a `Property` using: 98 | 99 | * `infer` - Convert a `Property` to the equivalent transformation on 100 | lists that infers the outputs from the inputs 101 | * `check` - Convert a `Property` to a `Check` for checking that a 102 | sequence of outputs is consistent with the inputs 103 | -} 104 | data Property input output = 105 | forall state . (Eq state, Hashable state, Universe state) 106 | => Property state (input -> State state output) 107 | deriving (Boolean, Monoid, Semigroup) via (Ap (Property input) output) 108 | 109 | {- Under the hood, a `Property` is essentially the exact same thing as the 110 | `Scan` type from the @foldl@ package, but with two differences: 111 | 112 | * The `Property` type is actually used to process the sequence of inputs 113 | in reverse, resulting in a sequence of outputs that are also reversed 114 | 115 | * We add more constraints to the existentially quantified @state@ type so 116 | that we can invert the scan when converting to the `Check` type 117 | -} 118 | 119 | instance Functor (Property input) where 120 | fmap f (Property s k) = Property s (fmap f . k) 121 | 122 | instance Applicative (Property input) where 123 | pure b = Property () (\_ -> pure b) 124 | 125 | Property sL kL <*> Property sR kR = Property s k 126 | where 127 | s = Pair sL sR 128 | 129 | k a = State.state step 130 | where 131 | step !(Pair l r) = (f x, Pair l' r') 132 | where 133 | (f, l') = State.runState (kL a) l 134 | (x, r') = State.runState (kR a) r 135 | 136 | instance Num output => Num (Property input output) where 137 | fromInteger = pure . fromInteger 138 | 139 | negate = fmap negate 140 | abs = fmap abs 141 | signum = fmap signum 142 | 143 | (+) = liftA2 (+) 144 | (*) = liftA2 (*) 145 | (-) = liftA2 (-) 146 | 147 | instance Fractional output => Fractional (Property input output) where 148 | fromRational = pure . fromRational 149 | 150 | recip = fmap recip 151 | 152 | (/) = liftA2 (/) 153 | 154 | instance Floating output => Floating (Property input output) where 155 | pi = pure pi 156 | 157 | exp = fmap exp 158 | sqrt = fmap sqrt 159 | log = fmap log 160 | sin = fmap sin 161 | tan = fmap tan 162 | cos = fmap cos 163 | asin = fmap asin 164 | atan = fmap atan 165 | acos = fmap acos 166 | sinh = fmap sinh 167 | tanh = fmap tanh 168 | cosh = fmap cosh 169 | asinh = fmap asinh 170 | atanh = fmap atanh 171 | acosh = fmap acosh 172 | 173 | (**) = liftA2 (**) 174 | logBase = liftA2 logBase 175 | 176 | instance Category Property where 177 | id = Property () pure 178 | 179 | Property sL kL . Property sR kR = Property s k 180 | where 181 | s = Pair sL sR 182 | 183 | k a = State.state step 184 | where 185 | step !(Pair l r) = (c, Pair l' r') 186 | where 187 | (b, r') = State.runState (kR a) r 188 | (c, l') = State.runState (kL b) l 189 | 190 | instance Arrow Property where 191 | arr f = fmap f id 192 | 193 | first (Property state step) = Property state step' 194 | where 195 | step' (a, b) = 196 | State.state (\s -> first (,b) (State.runState (step a) s)) 197 | 198 | second (Property state step) = Property state step' 199 | where 200 | step' (a, b) = 201 | State.state (\s -> first (a,) (State.runState (step b) s)) 202 | 203 | instance Profunctor Property where 204 | lmap f (Property s k) = Property s (k . f) 205 | 206 | rmap = fmap 207 | 208 | data Pair a b = Pair !a !b 209 | deriving stock (Eq, Generic) 210 | deriving anyclass (Hashable) 211 | 212 | instance (Universe a, Universe b) => Universe (Pair a b) where 213 | universe = liftA2 Pair universe universe 214 | 215 | {-| This property outputs `True` if the current input or any future input is 216 | `True`, and outputs `False` otherwise 217 | 218 | This is equivalent to the @<>@ temporal operator from TLA+ 219 | 220 | >>> infer eventually [ False, True, False ] 221 | [True,True,False] 222 | -} 223 | eventually :: Property Bool Bool 224 | eventually = Property False (\l -> State.state (\r -> let b = l || r in (b, b))) 225 | {-# INLINABLE eventually #-} 226 | 227 | {-| This property outputs `False` if the current input or any future input is 228 | `False`, and outputs `True` otherwise 229 | 230 | This is equivalent to the @[]@ temporal operator from TLA+ 231 | 232 | >>> infer always [ True, False, True ] 233 | [False,False,True] 234 | -} 235 | always :: Property Bool Bool 236 | always = Property True (\l -> State.state (\r -> let b = l && r in (b, b))) 237 | {-# INLINABLE always #-} 238 | 239 | {-| @f `~>` g@ returns `True` if every `True` output of @f@ is eventually 240 | followed by a `True` output from @g@ 241 | 242 | > f ~> g = always . (liftA2 (==>) f (eventually . g)) 243 | 244 | This is equivalent to the @~>@ temporal operator from TLA+ 245 | 246 | >>> infer (arr even ~> arr odd) [ 1, 2, 3, 4 ] 247 | [False,False,False,False] 248 | >>> infer (arr even ~> arr odd) [ 0, 1, 2, 3 ] 249 | [True,True,True,True] 250 | -} 251 | (~>) :: Property a Bool -> Property a Bool -> Property a Bool 252 | f ~> g = always . (liftA2 (==>) f (eventually . g)) 253 | {-# INLINABLE (~>) #-} 254 | 255 | {-| Turn a getter into the equivalent `Property` 256 | 257 | > `viewing` getter = `arr` (`Lens.view` getter) 258 | 259 | This comes in handy in conjunction with the `HasCal.Coroutine.state` and 260 | `HasCal.Coroutine.label` lenses: 261 | 262 | > `eventually` . `viewing` (`label` . `to` (== "foo")) 263 | > :: Property (Input global String) Bool 264 | 265 | >>> infer (viewing _1) [ (True, 1), (False, 2), (True, 3) ] 266 | [True,False,True] 267 | -} 268 | viewing :: Getting b a b -> Property a b 269 | viewing getter = arr (Lens.view getter) 270 | {-# INLINABLE viewing #-} 271 | 272 | {-| This property outputs each element with the following element (or `Nothing` 273 | if there is no following element) 274 | 275 | This is called \"prime\" as a reference to the TLA+ convention of referring 276 | to the next value of @x@ using @x'@ (i.e. \"@x@ prime\") 277 | 278 | >>> infer prime [ False, True, True ] 279 | [Just (False,True),Just (True,True),Nothing] 280 | -} 281 | prime :: (Eq a, Hashable a, Universe a) => Property a (Maybe (a, a)) 282 | prime = Property Zero step 283 | where 284 | step a0 = State.state f 285 | where 286 | f Zero = (Nothing, One a0) 287 | f (One a1 ) = (Just (a0, a1), Two a0 a1) 288 | f (Two a1 _) = (Just (a0, a1), Two a0 a1) 289 | {-# INLINABLE prime #-} 290 | 291 | data Prime a = Zero | One !a | Two !a !a 292 | deriving (Eq, Generic, Hashable) 293 | 294 | instance Universe a => Universe (Prime a) where 295 | universe = Zero : fmap One universe <> liftA2 Two universe universe 296 | 297 | {-| This is a more ergonomic version of `prime` for the common case where you 298 | want to compare each temporal input against the next input using an 299 | equivalence relation 300 | 301 | >>> infer (following (/=)) [ False, False, True, False ] 302 | [False,True,True,True] 303 | -} 304 | following 305 | :: (Eq input, Hashable input, Universe input) 306 | => (input -> input -> Bool) -> Property input Bool 307 | following (?) = arr adapt . prime 308 | where 309 | adapt Nothing = True 310 | adapt (Just (x, y)) = x ? y 311 | {-# INLINABLE following #-} 312 | 313 | {-| Convert a `Property` into the equivalent list transformation 314 | 315 | >>> infer (arr even) [ 2, 3, 5 ] 316 | [True,False,False] 317 | >>> infer eventually [ False, True, False ] 318 | [True,True,False] 319 | >>> infer always [ True, False, True ] 320 | [False,False,True] 321 | >>> infer (always . arr odd) [ 2, 3, 5 ] 322 | [False,True,True] 323 | >>> infer (eventually . arr even) [ 2, 3, 5 ] 324 | [True,False,False] 325 | >>> infer (eventually . always . arr odd) [ 2, 3, 5 ] 326 | [True,True,True] 327 | >>> infer (eventually . always . arr even) [ 2, 3, 5 ] 328 | [False,False,False] 329 | 330 | Note that `infer` has to `reverse` the list twice in order to infer the 331 | outputs from the inputs, so `infer` does not run in constant space. Use 332 | `check` or `checkList` if you want something that processes the input in a 333 | single forward pass. 334 | -} 335 | infer :: Property input output -> [input] -> [output] 336 | infer (Property s k) as = 337 | reverse (State.evalState (traverse k (reverse as)) s) 338 | 339 | {-| A `Check` is like a temporal `Property` except that you can check a sequence 340 | of @input@s against a corresponding sequence of @output@s in a single 341 | forward pass in constant space. This `Check` has the following two 342 | performance properties: 343 | 344 | * The `Check` can terminate early with a negative result if it determines 345 | that the temporal `Property` can no longer hold, regardless of future 346 | @input@ / @output@ values 347 | 348 | * The `Check` cannot terminate early if the @input@ / @output@ pairs satisfy 349 | the original temporal `Property`. The entire sequence must be traversed 350 | in order to establish an affirmative result 351 | 352 | Unlike `Property`, a `Check` cannot infer the @output@s from the @input@s 353 | because doing so would require knowing in advance what the future @input@s 354 | would be, and that is incompatible with traversing the @input@s in a single 355 | forward pass. For example, @`check` `always`@ cannot necessarily tell if 356 | the current @output@ should return `True` until it has seen all future 357 | @input@s, too. 358 | 359 | Other than the difference in algorithmic complexity, the `Check` type is 360 | similar to the `Property` type, meaning that they both share the same type 361 | parameters and the same instances. However, you generally should prefer to 362 | use the instances for the `Property` type because those are more efficient. 363 | 364 | The main difference between `Property` and `Check` is that the `Property` 365 | type is abstract, whereas the `Check` type is not That means that you can 366 | pattern match on the `Check` type in order to obtain two values: 367 | 368 | * A stateful step function that you feed an inputs to get a list of 369 | acceptable outputs 370 | * An expected final state 371 | 372 | Study the source code for the `checkList` utility if you want to see an 373 | example for how you would use these two values to validate a list of 374 | @input@ / @output@ pairs against a temporal `Property`. 375 | -} 376 | data Check input output = 377 | forall state . (Eq state, Hashable state, Universe state) 378 | => Check 379 | state 380 | -- ^ Expected final state 381 | (input -> StateT state [] output) 382 | -- ^ Given an @input@ and an old @state@, return a list of possible 383 | -- new @(output, state)@ pairs 384 | deriving (Boolean, Monoid, Semigroup) via (Ap (Check input) output) 385 | 386 | instance Functor (Check input) where 387 | fmap f (Check s k) = Check s (fmap f . k) 388 | 389 | instance Applicative (Check input) where 390 | pure b = Check () (\_ -> pure b) 391 | 392 | Check sL kL <*> Check sR kR = Check s k 393 | where 394 | s = Pair sL sR 395 | 396 | k a = StateT step 397 | where 398 | step !(Pair l r) = do 399 | (f, l') <- State.runStateT (kL a) l 400 | (x, r') <- State.runStateT (kR a) r 401 | return (f x, Pair l' r') 402 | 403 | instance Num output => Num (Check input output) where 404 | fromInteger = pure . fromInteger 405 | 406 | negate = fmap negate 407 | abs = fmap abs 408 | signum = fmap signum 409 | 410 | (+) = liftA2 (+) 411 | (*) = liftA2 (*) 412 | (-) = liftA2 (-) 413 | 414 | instance Fractional output => Fractional (Check input output) where 415 | fromRational = pure . fromRational 416 | 417 | recip = fmap recip 418 | 419 | (/) = liftA2 (/) 420 | 421 | instance Floating output => Floating (Check input output) where 422 | pi = pure pi 423 | 424 | exp = fmap exp 425 | sqrt = fmap sqrt 426 | log = fmap log 427 | sin = fmap sin 428 | tan = fmap tan 429 | cos = fmap cos 430 | asin = fmap asin 431 | atan = fmap atan 432 | acos = fmap acos 433 | sinh = fmap sinh 434 | tanh = fmap tanh 435 | cosh = fmap cosh 436 | asinh = fmap asinh 437 | atanh = fmap atanh 438 | acosh = fmap acosh 439 | 440 | (**) = liftA2 (**) 441 | logBase = liftA2 logBase 442 | 443 | instance Category Check where 444 | id = Check () pure 445 | 446 | Check sL kL . Check sR kR = Check s k 447 | where 448 | s = Pair sL sR 449 | 450 | k a = StateT step 451 | where 452 | step !(Pair l r) = do 453 | (b, r') <- State.runStateT (kR a) r 454 | (c, l') <- State.runStateT (kL b) l 455 | return (c, Pair l' r') 456 | 457 | instance Profunctor Check where 458 | lmap f (Check s k) = Check s (k . f) 459 | 460 | rmap = fmap 461 | 462 | {-| Convert a `Property` into a `Check` 463 | 464 | See the documentation for `Check` for more details on how to use a 465 | `Check` 466 | 467 | This is mostly used to implement `HasCal.Coroutine.model`, but you 468 | can use this to implement your own efficient temporal property 469 | checker 470 | -} 471 | check :: Property input output -> Check input output 472 | check (Property s k) = Check s k' 473 | where 474 | relation a = HashMap.fromListWith (<>) (fmap adapt universe) 475 | where 476 | adapt old = (new, [(b, old)]) 477 | where 478 | (b, new) = State.runState (k a) old 479 | 480 | k' a = StateT (\new -> HashMap.findWithDefault [] new (relation a)) 481 | {-# INLINABLE check #-} 482 | 483 | {-| This function checks that a list of @input@ and @output@ pairs is 484 | consistent with the given temporal `Property` 485 | 486 | You can think of `checkList` as having the following definition: 487 | 488 | > checkList property pairs = infer property inputs == outputs 489 | > where 490 | > (inputs, outputs) = unzip pairs 491 | 492 | … except that `checkList` processes the list in a single forward pass 493 | (unlike `infer`) 494 | 495 | >>> checkList eventually [(False, True), (True, True), (False, False)] 496 | True 497 | -} 498 | checkList :: Eq output => Property input output -> [(input, output)] -> Bool 499 | checkList temporal = 500 | case check temporal of 501 | Check finalState k -> loop (HashSet.fromList universe) 502 | where 503 | loop states [] = 504 | HashSet.member finalState states 505 | loop states ((input, output) : pairs) 506 | | HashSet.null states = False 507 | | otherwise = loop newStates pairs 508 | where 509 | newStates = HashSet.fromList do 510 | state <- HashSet.toList states 511 | 512 | (output', newState) <- State.runStateT (k input) state 513 | 514 | Monad.guard (output == output') 515 | 516 | return newState 517 | -------------------------------------------------------------------------------- /src/HasCal/Coroutine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE DerivingStrategies #-} 8 | {-# LANGUAGE DerivingVia #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | {-# LANGUAGE ExistentialQuantification #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | {-# LANGUAGE RankNTypes #-} 16 | {-# LANGUAGE ScopedTypeVariables #-} 17 | {-# LANGUAGE TypeApplications #-} 18 | 19 | {-| This module provides the `Process` and `Coroutine` types and associated 20 | utilities for working with them 21 | -} 22 | module HasCal.Coroutine 23 | ( -- * Concurrent processes 24 | Process 25 | , Coroutine(..) 26 | 27 | -- * State management 28 | , Status(..) 29 | , global 30 | , local 31 | , globally 32 | , locally 33 | , zoomProcess 34 | , zoomCoroutine 35 | 36 | -- * PlusCal Statements 37 | -- $statements 38 | , yield 39 | , skip 40 | , either 41 | , with 42 | , while 43 | , await 44 | , assert 45 | , die 46 | , print 47 | 48 | -- * Model checking 49 | , Model(..) 50 | , defaultModel 51 | , model 52 | 53 | -- * Model input 54 | , Input(..) 55 | , state 56 | , label 57 | , stately 58 | , labelly 59 | 60 | -- * Error handling 61 | , ModelException(..) 62 | , PropertyFailedReason(..) 63 | ) where 64 | 65 | import Control.Applicative (Alternative(..), liftA2) 66 | import Control.Exception.Safe (Exception) 67 | import Control.Monad.Catch (MonadThrow(..)) 68 | import Control.Monad.IO.Class (MonadIO(..)) 69 | import Control.Monad.Logic (LogicT(..)) 70 | import Control.Monad.State.Strict (MonadState(get,put), StateT) 71 | import Control.Monad.Trans.Class (MonadTrans(..)) 72 | import Data.Aeson (ToJSON(..), Value(..)) 73 | import Data.Aeson.Key (Key) 74 | import Data.Aeson.KeyMap (KeyMap) 75 | import Data.Algorithm.Diff (PolyDiff(..)) 76 | import Data.HashSet (HashSet) 77 | import Data.Hashable (Hashable(..)) 78 | import Data.Monoid (Any(..), Ap) 79 | import Data.Text (Text) 80 | import GHC.Generics (Generic) 81 | import HasCal.Expression (Boolean(..), Universe(..)) 82 | import HasCal.Property (Check(..), Property) 83 | import Lens.Micro.Platform (Lens, Lens', zoom) 84 | import Numeric.Natural (Natural) 85 | import Prelude hiding (either, print) 86 | import Prettyprinter (Doc, Pretty(..)) 87 | import Prettyprinter.Render.Terminal (AnsiStyle, Color(..)) 88 | 89 | import qualified Control.Applicative as Applicative 90 | import qualified Control.Exception.Safe as Exception 91 | import qualified Control.Monad as Monad 92 | import qualified Control.Monad.Logic as Logic 93 | import qualified Control.Monad.State.Lazy as State.Lazy 94 | import qualified Control.Monad.State.Strict as State 95 | import qualified Control.Monad.Writer as Writer 96 | import qualified Data.Aeson.Key as Aeson.Key 97 | import qualified Data.Aeson.KeyMap as Aeson.KeyMap 98 | import qualified Data.Algorithm.Diff as Diff 99 | import qualified Data.Char as Char 100 | import qualified Data.Foldable as Foldable 101 | import qualified Data.HashSet as HashSet 102 | import qualified Data.HashTable.IO as HashTable 103 | import qualified Data.HashTable.ST.Cuckoo as Cuckoo 104 | import qualified Data.IORef as IORef 105 | import qualified Data.Scientific as Scientific 106 | import qualified Data.Text as Text 107 | import qualified HasCal.Property as Property 108 | import qualified Lens.Micro.Platform as Lens 109 | import qualified Prelude 110 | import qualified Prettyprinter as Pretty 111 | import qualified Prettyprinter.Render.String as Pretty.String 112 | import qualified Prettyprinter.Render.Terminal as Pretty.Terminal 113 | import qualified Prettyprinter.Render.Text as Pretty.Text 114 | import qualified System.Console.ANSI as ANSI 115 | import qualified System.Exit as Exit 116 | import qualified System.IO as IO 117 | import qualified Text.Show as Show 118 | 119 | {- $setup 120 | 121 | >>> :m -Prelude 122 | >>> import Prelude hiding ((.), id) 123 | >>> import HasCal 124 | -} 125 | 126 | -- | Convert a list to the equivalent `LogicT` 127 | select :: [a] -> LogicT m a 128 | select as = LogicT (\cons nil -> foldr cons nil as) 129 | 130 | {-| Assert that a `LogicT` makes progress by throwing a `Deadlock` exception if 131 | the `LogicT` is empty 132 | -} 133 | progressive :: LogicT IO a -> LogicT IO a 134 | progressive (LogicT k) = LogicT k' 135 | where 136 | k' cons nil = do 137 | (nonEmpty, s) <- k cons' nil' 138 | if nonEmpty 139 | then return s 140 | else Exception.throw Deadlock 141 | where 142 | cons' a m = fmap ((,) True) (cons a (fmap snd m)) 143 | 144 | nil' = fmap ((,) False) nil 145 | 146 | {-| A `Process` represents a sequence of @PlusCal@ statements. You can think of 147 | a `Process` as a non-deterministic finite automaton: 148 | 149 | * The `Process` transitions atomically between labeled states 150 | * The `Process` may explore multiple state transitions in parallel because 151 | is it non-deterministic 152 | 153 | The only caveat is that a `Process` does not include a starting state (which 154 | is only later specified upon conversion to a `Coroutine`). 155 | 156 | The type variables are: 157 | 158 | * @global@: The type of the global state shared by every `Process` 159 | * @local@: The type of the process-local state unique to this `Process` 160 | * @label@: The type of labels that this `Process` emits 161 | * @result@: The return value of the `Process` 162 | 163 | Processes support the following core functionality: 164 | 165 | * `yield` - Yield control alongside a label for the current state, ending 166 | an atomic transition 167 | * `pure` / `return` - Promote a value to a `Process` which does nothing 168 | and returns the value 169 | * `empty` - Terminate a `Process` 170 | * `liftIO` - Run an arbitrary `IO` action inside a `Process` 171 | * `throwM` - Throw an exception inside a `Process`, causing model checking 172 | to fail 173 | * `get` / `put` - Get and set the current `Process` state 174 | * `mempty` - A `Process` which does nothing 175 | 176 | Additionally, the utilities in the \"PlusCal utilities\" section wrap the 177 | above functionality to use more PlusCal-friendly names. 178 | 179 | You can combine multiple `Process`es using: 180 | 181 | * @do@ notation - Run `Process`es sequentially 182 | * (`<|>`) - Explore two `Process`es in parallel 183 | * (`<>`) - Run two `Process`es sequentially and combine their return values 184 | 185 | Finally, you will need to convert a `Process` into a `Coroutine` by wrapping 186 | the `Process` in the `Coroutine` constructor 187 | -} 188 | newtype Process global local label result 189 | = Choice 190 | { possibilities 191 | :: StateT (Status global local) (LogicT IO) 192 | (Step global local label result) 193 | } 194 | deriving stock (Functor) 195 | deriving (Boolean, Semigroup, Monoid) 196 | via (Ap (Process global local label) result) 197 | 198 | instance Applicative (Process global local label) where 199 | pure result = Choice (pure (Done result)) 200 | 201 | (<*>) = Monad.ap 202 | 203 | instance Monad (Process global local label) where 204 | Choice ps >>= f = Choice do 205 | p <- ps 206 | case p of 207 | Yield _label rest -> do 208 | return (Yield _label (rest >>= f)) 209 | Done result -> possibilities (f result) 210 | 211 | instance MonadFail (Process global local label) where 212 | fail _ = empty 213 | 214 | instance Alternative (Process global local label) where 215 | empty = Choice empty 216 | 217 | Choice psL <|> Choice psR = Choice (psL <|> psR) 218 | 219 | instance MonadState (Status global local) (Process global local label) where 220 | get = Choice (fmap Done get) 221 | 222 | put s = Choice (fmap Done (put s)) 223 | 224 | state k = Choice (fmap Done (State.state k)) 225 | 226 | instance MonadThrow (Process global local label) where 227 | throwM e = Choice (fmap Done (liftIO (throwM e))) 228 | 229 | instance MonadIO (Process global local label) where 230 | liftIO io = Choice (fmap Done (liftIO io)) 231 | 232 | data Step global local label result 233 | = Yield label (Process global local label result) 234 | | Done result 235 | deriving stock (Functor) 236 | 237 | {-| The `Status` type represents the state for every `Process`, which has two 238 | components: 239 | 240 | * @global@ - The global state shared by all `Process`es 241 | * @local@ - The local state unique to this `Process` 242 | -} 243 | data Status global local = Status 244 | { _global :: !global 245 | -- ^ Shared global state 246 | , _local :: !local 247 | -- ^ `Process`-local state 248 | } deriving stock (Eq, Generic, Show) 249 | deriving anyclass (Hashable, ToJSON) 250 | 251 | -- | A lens for accessing the global state of a `Process` 252 | global :: Lens' (Status global local) global 253 | global k (Status a b) = fmap (\a' -> Status a' b) (k a) 254 | {-# INLINABLE global #-} 255 | 256 | -- | A lens for accessing the local state of a `Process` 257 | local :: Lens' (Status global local) local 258 | local k (Status a b) = fmap (\b' -> Status a b') (k b) 259 | {-# INLINABLE local #-} 260 | 261 | {-| Lift a lens on global state to a lens on `Status` 262 | 263 | @ 264 | `globally` :: Lens' outer inner -> Lens' (`Status` outer local) (`Status` inner local) 265 | @ 266 | -} 267 | globally 268 | :: Lens outer outer' inner inner' 269 | -- ^ Lens to lift 270 | -> Lens (Status outer local) (Status outer' local) (Status inner local) (Status inner' local) 271 | globally l k (Status a b) = 272 | unFocusingGlobal (l (\a' -> FocusingGlobal (k (Status a' b))) a) 273 | 274 | data FocusingGlobal f local global = 275 | FocusingGlobal { unFocusingGlobal :: f (Status global local) } 276 | 277 | instance Functor f => Functor (FocusingGlobal f local) where 278 | fmap f (FocusingGlobal x) = FocusingGlobal (fmap adapt x) 279 | where 280 | adapt (Status a b) = Status (f a) b 281 | 282 | {-| Lift a lens on local state to a lens on `Status` 283 | 284 | @ 285 | `locally` :: Lens' outer inner -> Lens' (`Status` global outer) (`Status` global inner) 286 | @ 287 | -} 288 | locally 289 | :: Lens outer outer' inner inner' 290 | -- ^ Lens to lift 291 | -> Lens (Status global outer) (Status global outer') (Status global inner) (Status global inner') 292 | locally l k (Status a b) = 293 | unFocusingLocal (l (\b' -> FocusingLocal (k (Status a b'))) b) 294 | 295 | data FocusingLocal f global local = 296 | FocusingLocal { unFocusingLocal :: f (Status global local) } 297 | 298 | instance Functor f => Functor (FocusingLocal f local) where 299 | fmap f (FocusingLocal x) = FocusingLocal (fmap adapt x) 300 | where 301 | adapt (Status a b) = Status a (f b) 302 | 303 | {-| A `Coroutine` wraps a `Process` alongside a starting label and starting 304 | process-local state. Including the starting state makes a `Coroutine` a 305 | complete non-deterministic finite automaton that can be combined with 306 | other `Coroutine`s using `Applicative` operations. Combining `Coroutine`s 307 | in this way is the same as taking the Cartesian product of their 308 | equivalent non-deterministic finite automata. For a more detailed 309 | explanation, see: 310 | 311 | * 312 | 313 | The type variables are: 314 | 315 | * @global@: The type of the global state shared by every `Coroutine` 316 | * @label@: The type of labels that this `Coroutine` emits 317 | 318 | Carefully note that the `Process`-local state (i.e. the @local@ variable) 319 | is hidden upon conversion to a `Coroutine`, in order to ensure that the 320 | `Process`-local state of each `Coroutine` is isolated from one another. 321 | 322 | You can create a `Coroutine` in the following ways: 323 | 324 | * The `Coroutine`` constructor - Wrap a `Process` with a starting state and 325 | label to create a `Coroutine` 326 | * `pure` - A `Coroutine` with a single state and no valid transitions 327 | * `mempty` - A `Coroutine` that does nothing 328 | 329 | You can combine `Coroutine`s using: 330 | 331 | * `Functor` and `Applicative` utilities (e.g. (`<$>`) and (`<*>`)) 332 | * @do@ notation, if you enable @ApplicativeDo@ 333 | * (`<>`) - Run two `Coroutine`s in parallel and combine their results 334 | -} 335 | data Coroutine global label = 336 | forall local 337 | . (Eq local, Hashable local, ToJSON local, Show local) 338 | => Coroutine 339 | { startingLabel :: label 340 | , startingLocals :: [local] 341 | , process :: Process global local label () 342 | } 343 | deriving (Boolean, Semigroup, Monoid) 344 | via (Ap (Coroutine global) label) 345 | 346 | instance Functor (Coroutine global) where 347 | fmap = Applicative.liftA 348 | 349 | instance Applicative (Coroutine global) where 350 | pure _label = Coroutine _label (pure Unit) empty 351 | 352 | Coroutine label0F sF fs0 <*> Coroutine label0X sX xs0 = 353 | Coroutine label0FX s fxs 354 | where 355 | (label0FX, fxs) = loop (label0F, fs0) (label0X, xs0) 356 | 357 | s = liftA2 Pair sF sX 358 | 359 | loop (label1F, Choice fs) (label1X, Choice xs) = 360 | ( label1F label1X 361 | , Choice (fmap adaptF (Lens.zoom onLeft fs)) 362 | <|> Choice (fmap adaptX (Lens.zoom onRight xs)) 363 | ) 364 | where 365 | adaptF (Done result) = Done result 366 | adaptF (Yield labelF restF) = Yield labelFX restFX 367 | where 368 | (labelFX, restFX) = loop (labelF, restF) (label1X, Choice xs) 369 | 370 | adaptX (Done result) = Done result 371 | adaptX (Yield labelX restX) = Yield labelFX restFX 372 | where 373 | (labelFX, restFX) = loop (label1F, Choice fs) (labelX, restX) 374 | 375 | onLeft :: Lens' (Status global (Pair l r)) (Status global l) 376 | onLeft k (Status g (Pair l r)) = fmap adapt (k (Status g l)) 377 | where 378 | adapt (Status g' l') = Status g' (Pair l' r) 379 | 380 | onRight :: Lens' (Status global (Pair l r)) (Status global r) 381 | onRight k (Status g (Pair l r)) = fmap adapt (k (Status g r)) 382 | where 383 | adapt (Status g' r') = Status g' (Pair l r') 384 | 385 | data Unit = Unit 386 | deriving stock (Eq, Generic, Show) 387 | deriving anyclass (Hashable) 388 | 389 | instance ToJSON Unit where 390 | toJSON Unit = toJSON ([] :: [Value]) 391 | 392 | data Pair a b = Pair !a !b 393 | deriving stock (Eq, Generic, Show) 394 | deriving anyclass (Hashable) 395 | 396 | instance (ToJSON a, ToJSON b) => ToJSON (Pair a b) where 397 | toJSON (Pair a b) = 398 | case (toJSON a, toJSON b) of 399 | (Array as, Array bs) -> Array (as <> bs) 400 | (a' , b' ) -> toJSON [ a', b' ] 401 | 402 | {- $statements 403 | This section provides commands that correspond as closely as possible to the 404 | equivalent PlusCal commands of the same name. These commands do not 405 | represent the full extent of what you can do within Haskell processes, but 406 | they do provide feature parity with PlusCal (with the exception of the 407 | @goto@ command, which is not supported here). 408 | 409 | Many of these commands are synonyms for utilities from Haskell's standard 410 | library. For example, `await` is just a synonym for `Monad.guard`. These 411 | synonyms exist primarily for educational purposes, to illustrate how 412 | PlusCal idioms correspond to Haskell idioms, but you can still use these 413 | synonyms if you want the Haskell code to resemble PlusCal as much as 414 | possible. 415 | -} 416 | 417 | {-| End the current atomic transition alongside a label for the current state. 418 | This potentially yields control to other `Process`es. 419 | 420 | If the exact same label and state have been reached before then the 421 | model checker behavior depends on whether you enable the termination 422 | check: 423 | 424 | * If you enable the termination check then the model checker will 425 | `Exception.throw` a `Nontermination` exception since revisiting the same 426 | state indicates a simulation path that permits an infinite loop 427 | 428 | * If you disable the termination check then the model checker will still 429 | end the current simulation branch since it has already visited this 430 | state before 431 | 432 | -} 433 | yield :: label -> Process global local label () 434 | yield _label = Choice (pure (Yield _label mempty)) 435 | {-# INLINABLE yield #-} 436 | 437 | {-| A `Process` which does nothing, like the @skip@ statement in PlusCal 438 | 439 | This is a synonym for `mempty`, but with a `Process`-specific type 440 | signature. 441 | 442 | Note that you do not need to use `skip` in Haskell as often as in PlusCal. 443 | For example, consider the following PlusCal code: 444 | 445 | > A: 446 | > skip; 447 | > B: 448 | > either 449 | > skip; 450 | > or 451 | > C: 452 | > skip; 453 | > end either; 454 | 455 | The equivalent Haskell code can elide many of those `skip`s: 456 | 457 | @ 458 | example = do 459 | `yield` "A" 460 | `yield` "B" 461 | `either` 462 | [ `skip` 463 | , `yield` "C" 464 | ] 465 | @ 466 | 467 | … because `skip` literally does nothing and therefore can be omitted in 468 | most cases. 469 | -} 470 | skip :: Process global local label () 471 | skip = mempty 472 | {-# INLINE skip #-} 473 | 474 | {-| Non-deterministically simulate multiple subroutines, like an @either@ 475 | statement in PlusCal 476 | 477 | This is a synonym for @"Data.Foldable".`Foldable.asum`@, but with a 478 | `Process`-specific type signature. 479 | 480 | The model checker will explore all branches, succeeding only if all branches 481 | succeed. 482 | 483 | `either` obeys the following laws: 484 | 485 | @ 486 | `either` [ a ] = a 487 | 488 | `either` (as `<|>` bs) = `either` as `<|>` `either` bs 489 | 490 | `either` `empty` = `empty` 491 | @ 492 | 493 | … or equivalently: 494 | 495 | @ 496 | `either` (as `++` bs) = `either` as `<|>` `either` bs 497 | 498 | `either` [] = `empty` 499 | @ 500 | 501 | Those rules also imply that: 502 | 503 | @ 504 | `either` [ a, b ] = a `<|>` b 505 | @ 506 | -} 507 | either 508 | :: Foldable list 509 | => list (Process global local label result) 510 | -- ^ Subroutines to non-deterministically select from 511 | -> Process global local label result 512 | either = Foldable.asum 513 | {-# INLINE either #-} 514 | 515 | {-| Non-deterministically select from one of multiple possible values, like 516 | a @with@ statement in PlusCal 517 | 518 | `with` is (essentially) the same thing as using `either` to select from a 519 | list of `pure` subroutines: 520 | 521 | @ 522 | `with` results = `either` (`fmap` `pure` results) 523 | @ 524 | 525 | `with` obeys the following laws: 526 | 527 | @ 528 | `with` (as `<|>` bs) = `with` as `<|>` `with` bs 529 | 530 | `with` `empty` = `empty` 531 | 532 | `with` (`pure` a) = `pure` a 533 | @ 534 | 535 | … or equivalently: 536 | 537 | @ 538 | `with` (as `++` bs) = `with` as `<|>` `with` bs 539 | 540 | `with` [] = `empty` 541 | 542 | `with` [a] = `pure` a 543 | @ 544 | 545 | -} 546 | with :: Foldable list => list result -> Process global local label result 547 | with = foldr cons empty 548 | where 549 | cons result rest = pure result <|> rest 550 | {-# INLINABLE with #-} 551 | 552 | {-| Run a loop so long as the loop condition does not return `True`, like a 553 | @while@ statement in PlusCal 554 | 555 | You will typically /not/ want to use this and instead you will more likely 556 | want to use one of the utilities from "Control.Monad". This is only 557 | provided for parity with PlusCal. 558 | 559 | @ 560 | `while` (`pure` `True`) body = `Monad.forever` body 561 | 562 | `while` (`pure` `False`) body = skip 563 | @ 564 | -} 565 | while 566 | :: Process global local label Bool 567 | -- ^ Condition 568 | -> Process global local label () 569 | -- ^ Body of the loop 570 | -> Process global local label () 571 | while condition body = do 572 | bool <- condition 573 | Monad.when bool do 574 | body 575 | while condition body 576 | 577 | {-| Only permit the current state transition if the predicate is `True`, like 578 | an @await@ statement in PlusCal 579 | 580 | This is a synonym for @"Control.Monad".`Monad.guard`@, but with a 581 | `Process`-specific type signature. 582 | 583 | @ 584 | `await` `False` = `empty` 585 | `await` `True` = `mempty` 586 | 587 | `await` (a `||` b) = `await` a `<|>` `await` b 588 | `await` (a `&&` b) = `await` a `<>` `await` b 589 | @ 590 | -} 591 | await :: Bool -> Process global local label () 592 | await = Monad.guard 593 | {-# INLINE await #-} 594 | 595 | {-| Throw an exception if the condition does not evaluate to `True`, like an 596 | @assert@ statement in PlusCal 597 | 598 | The model checker will fail if any branch throws an exception (with `assert` 599 | or otherwise), but exceptions thrown using `assert` will also automatically 600 | include the current `Process` state 601 | 602 | @ 603 | `assert` `True` = `skip` 604 | @ 605 | -} 606 | assert 607 | :: (ToJSON local, ToJSON global, Show local, Show global) 608 | => Bool 609 | -- ^ Condition 610 | -> Process global local label () 611 | assert True = skip 612 | assert False = do 613 | _status <- get 614 | Exception.throw AssertionFailed{ _status } 615 | 616 | -- | Die with an error message 617 | die :: Text -> Process global local label result 618 | die _message = Exception.throw Failure{ _message } 619 | 620 | {-| Print a value to the console for debugging purposes, like a @print@ 621 | statement in PlusCal 622 | 623 | This is the same as @"Prelude".`Prelude.print`@, except wrapped in a 624 | `liftIO` 625 | -} 626 | print :: Show a => a -> Process global local label () 627 | print a = liftIO (Prelude.print a) 628 | {-# INLINABLE print #-} 629 | 630 | -- | Zoom in on a subset of a `Coroutine`'s global state using a lens 631 | zoomCoroutine 632 | :: Lens' outer inner -> Coroutine inner label -> Coroutine outer label 633 | zoomCoroutine l Coroutine{ startingLabel, startingLocals, process } = 634 | Coroutine 635 | { startingLabel 636 | , startingLocals 637 | , process = zoomProcess l process 638 | } 639 | 640 | -- | Zoom in on a subset of a `Process`'s global state using a lens 641 | zoomProcess 642 | :: Lens' outer inner 643 | -> Process inner local label result 644 | -> Process outer local label result 645 | zoomProcess l = adaptProcess 646 | where 647 | adaptProcess (Choice steps) = 648 | Choice (zoom (globally l) (fmap adaptStep steps)) 649 | 650 | adaptStep (Done result ) = Done result 651 | adaptStep (Yield _label rest) = Yield _label (adaptProcess rest) 652 | 653 | {-| The `ModelException` type represents all of the ways in which the model 654 | checker can fail 655 | -} 656 | data ModelException = 657 | forall value . (Show value, ToJSON value) 658 | => Nontermination { _history :: [value] } 659 | -- ^ The process does not necessarily terminate because at least one 660 | -- branch of execution permits an infinite cycle 661 | | Deadlock 662 | -- ^ The process deadlocked, meaning that no branch of execution 663 | -- successfully ran to completion 664 | | forall value . (Show value, ToJSON value) 665 | => AssertionFailed { _status :: value } 666 | -- ^ The process failed to satisfy an `assert` statement 667 | | forall value . (Show value, ToJSON value) 668 | => PropertyFailed 669 | { _inputHistory :: [value] 670 | , _reason :: PropertyFailedReason 671 | } 672 | -- ^ At least one branch of execution failed to satisfy the specified 673 | -- `Property` 674 | | Failure { _message :: Text } 675 | -- ^ Used by the `fail` method 676 | 677 | instance Pretty ModelException where 678 | pretty = Pretty.unAnnotate . prettyModelException 679 | 680 | -- | The reason why a `PropertyFailed` exception was thrown 681 | data PropertyFailedReason 682 | = Unsatisfiable 683 | -- ^ The `Property` can no longer satisfied, regardless of future input 684 | | UnsatisfyingConclusion 685 | -- ^ We could not satisfy the `Property` before reaching the end of the 686 | -- input sequence. For example, you would get this error if you check the 687 | -- `Property.eventually` `Property` against an input sequence where every 688 | -- input was `False` 689 | deriving (Show) 690 | 691 | instance Show ModelException where 692 | showsPrec _ Nontermination{ _history } = 693 | showString "Nontermination {_history = " 694 | . Show.showListWith shows _history 695 | . showString "}" 696 | showsPrec _ Deadlock = 697 | showString "Deadlock" 698 | showsPrec _ AssertionFailed{ _status } = 699 | showString "AssertionFailed {_status = " 700 | . shows _status 701 | . showString "}" 702 | showsPrec _ PropertyFailed{ _inputHistory, _reason } = 703 | showString "PropertyFailed {_inputHistory = " 704 | . Show.showListWith shows _inputHistory 705 | . showString ", _reason = " 706 | . shows _reason 707 | . showString "}" 708 | showsPrec _ Failure{ _message } = 709 | showString "Failure {_message = " 710 | . shows _message 711 | . showString "}" 712 | 713 | instance Exception ModelException where 714 | displayException exception = 715 | Pretty.String.renderString 716 | (Pretty.layoutPretty Pretty.defaultLayoutOptions (pretty exception)) 717 | 718 | data HistoryKey a b = HistoryKey{ _label :: !a, _status :: !b } 719 | deriving stock (Eq, Generic, Show) 720 | deriving anyclass (Hashable, ToJSON) 721 | 722 | prettyKey :: Text -> Doc ann 723 | prettyKey = 724 | Pretty.pretty 725 | . spaces 726 | . Text.concat 727 | . fmap capitalizeWord 728 | . Text.splitOn "_" 729 | . Text.dropWhile (== '_') 730 | where 731 | space c 732 | | Char.isUpper c = Text.pack [ ' ', c ] 733 | | otherwise = Text.singleton c 734 | 735 | capitalizeWord text = 736 | case Text.uncons text of 737 | Just (t, ext) -> 738 | Text.cons (Char.toUpper t) ext 739 | Nothing -> 740 | text 741 | 742 | spaces text = 743 | case Text.uncons text of 744 | Just (t, ext) -> 745 | Text.cons (Char.toUpper t) (Text.concatMap space ext) 746 | Nothing -> 747 | text 748 | 749 | prettyValue :: Value -> Doc ann 750 | prettyValue = loop 751 | where 752 | loop (Array values) = Pretty.group (Pretty.flatAlt long short) 753 | where 754 | long = Pretty.align (lined (fmap item values)) 755 | 756 | short 757 | | null values = "[ ]" 758 | | otherwise = "[ " <> commas (fmap loop values) <> " ]" 759 | 760 | item value = "- " <> loop value 761 | loop (Object keyValues) = 762 | Pretty.group (Pretty.flatAlt long short) 763 | where 764 | long = Pretty.align (lined (fmap processLong list)) 765 | 766 | short 767 | | null keyValues = "{ }" 768 | | otherwise = "{ " <> commas (fmap processShort list) <> " }" 769 | 770 | list = Aeson.KeyMap.toList keyValues 771 | 772 | processLong (key, value) = 773 | prettyKey (Aeson.Key.toText key) 774 | <> ":" 775 | <> Pretty.hardline 776 | <> " " 777 | <> loop value 778 | 779 | processShort (key, value) = 780 | prettyKey (Aeson.Key.toText key) <> ": " <> loop value 781 | loop (String text) = 782 | Pretty.pretty (show text) 783 | loop (Number scientific) = 784 | case Scientific.floatingOrInteger scientific of 785 | Left double -> Pretty.pretty @Double double 786 | Right integer -> Pretty.pretty @Integer integer 787 | loop (Bool bool) = 788 | Pretty.pretty bool 789 | loop Null = 790 | "null" 791 | 792 | prettyValueList :: [Value] -> Doc AnsiStyle 793 | prettyValueList values = 794 | case values of 795 | before : afters -> Pretty.group (Pretty.flatAlt long short) 796 | where 797 | docs = prettyValue before : diffs before afters 798 | 799 | long = Pretty.align (lined (fmap process docs)) 800 | 801 | short 802 | | null docs = "[ ]" 803 | | otherwise = "[ " <> commas docs <> " ]" 804 | 805 | process doc = "- " <> doc 806 | _ -> prettyValue (toJSON values) 807 | where 808 | diffs :: Value -> [Value] -> [Doc AnsiStyle] 809 | diffs _ [] = 810 | [ ] 811 | diffs before (after : afters) = do 812 | snd (diff before after) : diffs after afters 813 | 814 | diff :: Value -> Value -> (Any, Doc AnsiStyle) 815 | diff (Array old) (Array new) = do 816 | let oldList = Foldable.toList old 817 | let newList = Foldable.toList new 818 | 819 | let docs (o : ld) (n : ew) = do 820 | d <- diff o n 821 | ds <- docs ld ew 822 | return (d : ds) 823 | docs _ new' = do 824 | return (fmap (plus . prettyValue) new') 825 | 826 | (ds, Any matching) <- Writer.listen (docs oldList newList) 827 | 828 | ds' <- do 829 | if matching 830 | then do 831 | return ds 832 | else do 833 | let render (First a) = minus (prettyValue a) 834 | render (Second a) = plus (prettyValue a) 835 | render (Both a _) = prettyValue a 836 | 837 | return (fmap render (Diff.getDiff oldList newList)) 838 | 839 | let short 840 | | null ds' = 841 | "[ ]" 842 | | otherwise = 843 | "[ " <> commas ds' <> " ]" 844 | 845 | let long = Pretty.align (lined (fmap item ds')) 846 | where 847 | item d = "- " <> d 848 | 849 | return (Pretty.group (Pretty.flatAlt long short)) 850 | diff (Object old) (Object new) 851 | | let both = Aeson.KeyMap.intersection old new 852 | , not (Aeson.KeyMap.null both) = do 853 | Writer.tell (Any True) 854 | 855 | let extraOlds = Aeson.KeyMap.difference old new 856 | let extraNews = Aeson.KeyMap.difference new old 857 | 858 | let combine 859 | :: Key 860 | -> Value 861 | -> Value 862 | -> (Any, (Doc AnsiStyle, Doc AnsiStyle)) 863 | combine key o n = do 864 | doc <- diff o n 865 | let long = 866 | prettyKey (Aeson.Key.toText key) 867 | <> ":" 868 | <> Pretty.hardline 869 | <> " " 870 | <> doc 871 | 872 | let short = 873 | prettyKey (Aeson.Key.toText key) 874 | <> ": " 875 | <> doc 876 | 877 | return (long, short) 878 | 879 | let boths :: KeyMap (Any, (Doc AnsiStyle, Doc AnsiStyle)) 880 | boths = Aeson.KeyMap.intersectionWithKey combine old new 881 | 882 | (bothLongs, bothShorts) <- do 883 | fmap unzip (Monad.sequence (Aeson.KeyMap.elems boths)) 884 | 885 | let (extraNewLongs, extraNewShorts) = 886 | unzip (fmap (extra plus) (Aeson.KeyMap.toList extraNews)) 887 | 888 | let (extraOldLongs, extraOldShorts) = 889 | unzip (fmap (extra minus) (Aeson.KeyMap.toList extraOlds)) 890 | 891 | let longs = extraOldLongs <> extraNewLongs <> bothLongs 892 | let shorts = extraOldShorts <> extraNewShorts <> bothShorts 893 | 894 | let long = Pretty.align (lined longs) 895 | 896 | let short 897 | | null shorts = 898 | "{ }" 899 | | otherwise = 900 | "{ " <> commas shorts <> " }" 901 | 902 | return (Pretty.group (Pretty.flatAlt long short)) 903 | where 904 | extra sign (key, value) = 905 | ( sign 906 | ( prettyKey (Aeson.Key.toText key) 907 | <> ":" 908 | <> Pretty.hardline 909 | <> " " 910 | <> prettyValue value 911 | ) 912 | , sign 913 | ( prettyKey (Aeson.Key.toText key) 914 | <> ": " 915 | <> prettyValue value 916 | ) 917 | ) 918 | diff old new 919 | | old == new = do 920 | Writer.tell (Any True) 921 | return (prettyValue new) 922 | | otherwise = do 923 | return (plus (prettyValue new)) 924 | 925 | minus = Pretty.annotate (Pretty.Terminal.color Red ) 926 | plus = Pretty.annotate (Pretty.Terminal.color Green) 927 | 928 | lined :: Foldable list => list (Doc ann) -> Doc ann 929 | lined = Pretty.concatWith append 930 | where 931 | append x y = x <> Pretty.hardline <> y 932 | 933 | commas :: Foldable list => list (Doc ann) -> Doc ann 934 | commas = Pretty.concatWith append 935 | where 936 | append x y = x <> ", " <> y 937 | 938 | prettyModelException :: ModelException -> Doc AnsiStyle 939 | prettyModelException Nontermination{ _history } = 940 | Pretty.align 941 | ( "Non-termination" 942 | <> Pretty.hardline 943 | <> Pretty.hardline 944 | <> prettyValueList (fmap toJSON (reverse _history)) 945 | ) 946 | prettyModelException Deadlock = 947 | "Deadlock" 948 | prettyModelException AssertionFailed{ _status } = 949 | Pretty.align 950 | ( "Assertion failed" 951 | <> Pretty.hardline 952 | <> Pretty.hardline 953 | <> prettyValue (toJSON _status) 954 | ) 955 | prettyModelException PropertyFailed{ _inputHistory, _reason } = 956 | Pretty.align 957 | ( "Property failed: " <> reason 958 | <> Pretty.hardline 959 | <> Pretty.hardline 960 | <> prettyValueList (fmap toJSON (reverse _inputHistory)) 961 | ) 962 | where 963 | reason = case _reason of 964 | Unsatisfiable -> "unsatisfiable" 965 | UnsatisfyingConclusion -> "unsatisfying conclusion" 966 | 967 | prettyModelException Failure{ _message } = "Failure: " <> pretty _message 968 | 969 | {-| A `Model` represents the model to check, alongside all model-checking 970 | options 971 | -} 972 | data Model global label = Model 973 | { termination :: Bool 974 | -- ^ When `True`, throw a `Nontermination` exception if any cycles are 975 | -- detected 976 | , deadlock :: Bool 977 | -- ^ When `True`, throw a `Deadlock` exception if if the `Coroutine` 978 | -- cannot make progress 979 | , debug :: Bool 980 | -- ^ Set this to `True` if you want to pretty-print the `ModelException` 981 | -- and instead throw @`Exit.ExitFailure` 1@ in its place 982 | , statistics :: Bool 983 | -- ^ Set this to `True` to display model-checking statistics at the end 984 | -- of the run 985 | , coroutine :: Coroutine global label 986 | -- ^ `Coroutine` to check 987 | , property :: Property (Input global label) Bool 988 | -- ^ `Property` to check 989 | , startingGlobals :: [global] 990 | -- ^ Possible starting global states 991 | } 992 | 993 | {-| Default model-checking options 994 | 995 | @ 996 | defaultModel = `Model` 997 | { termination = `True` 998 | , deadlock = `True` 999 | , debug = `False` 1000 | , statistics = `False` 1001 | , coroutine = `mempty` 1002 | , property = `true` 1003 | , startingGlobals = `pure` () 1004 | } 1005 | @ 1006 | -} 1007 | defaultModel :: Model () () 1008 | defaultModel = Model 1009 | { termination = True 1010 | , deadlock = True 1011 | , debug = False 1012 | , statistics = False 1013 | , coroutine = mempty 1014 | , property = true 1015 | , startingGlobals = pure () 1016 | } 1017 | 1018 | {- This type is used internally within the `model` function to keep track of 1019 | state specific to one \"timeline\" of the model checker (i.e. one possible 1020 | branch of execution) 1021 | 1022 | This `Timeline` state is isolated from other branches of execution 1023 | -} 1024 | data Timeline global local label status = Timeline 1025 | { _history :: [ HistoryKey label (Status global local) ] 1026 | -- ^ This is kept for error reporting so that if things go wrong we can 1027 | -- report to the user what sequence of events led up to the problem 1028 | , _historySet :: !(HashSet (HistoryKey label (Status global local))) 1029 | -- ^ This always the same as @`HashSet.fromList` _history@, 1030 | -- but kept as a separate field for efficiently updating and querying 1031 | -- which states we've seen so far in order to detect cycles 1032 | , _propertyStatus :: !(HashSet status) 1033 | -- ^ This stores the internal state of the temporal `Property` 1034 | , _inputHistory :: [ Input global label ] 1035 | } 1036 | 1037 | {-| Run the model checker on a `Coroutine` by supplying a list of starting 1038 | states 1039 | 1040 | If you want to check more than one `Coroutine`, then combine those 1041 | `Coroutine`s using `Applicative` operations or @ApplicativeDo@ notation 1042 | 1043 | >>> model defaultModel -- The default model has no valid execution branches 1044 | *** Exception: Deadlock 1045 | 1046 | >>> -- An example coroutine with one execution branch that does nothing 1047 | >>> exampleCoroutine = Coroutine{ startingLabel = (), startingLocals = pure (), process = mempty } 1048 | >>> model defaultModel{ coroutine = exampleCoroutine } -- Success 1049 | 1050 | 1051 | >>> -- Create a coroutine that never terminates 1052 | >>> endlessCoroutine = Coroutine{ startingLabel = False, startingLocals = pure (), process = while true (yield True) } 1053 | >>> model defaultModel{ coroutine = endlessCoroutine, property = true } 1054 | *** Exception: Nontermination {_history = [HistoryKey {_label = True, _status = Status {_global = (), _local = ()}},HistoryKey {_label = True, _status = Status {_global = (), _local = ()}},HistoryKey {_label = False, _status = Status {_global = (), _local = ()}}]} 1055 | 1056 | >>> -- Enable debugging output for clarity 1057 | >>> model defaultModel{ coroutine = endlessCoroutine, property = true, debug = True } 1058 | Non-termination 1059 | ... 1060 | - { Label: False, Status: { Global: [ ], Local: [ ] } } 1061 | - { Label: True, Status: { Global: [ ], Local: [ ] } } 1062 | - { Label: True, Status: { Global: [ ], Local: [ ] } } 1063 | *** Exception: ExitFailure 1 1064 | 1065 | >>> -- Disable the termination checker if desired 1066 | >>> model defaultModel{ coroutine = endlessCoroutine, property = true, debug = True, termination = False } 1067 | 1068 | >>> -- Check a non-trivial property that succeeds 1069 | >>> exampleProperty = eventually . always . viewing label 1070 | >>> model defaultModel{ coroutine = endlessCoroutine, property = exampleProperty, debug = True, termination = False } 1071 | 1072 | >>> -- Check a non-trivial property that fails 1073 | >>> model defaultModel{ coroutine = endlessCoroutine, property = always . viewing (label . to not), debug = True, termination = False } 1074 | Property failed: unsatisfiable 1075 | ... 1076 | [ { Label: False, State: [ ] }, { Label: True, State: [ ] } ] 1077 | *** Exception: ExitFailure 1 1078 | -} 1079 | model 1080 | :: ( Eq global 1081 | , Eq label 1082 | , Hashable global 1083 | , Hashable label 1084 | , ToJSON label 1085 | , ToJSON global 1086 | , Show global 1087 | , Show label 1088 | ) 1089 | => Model global label 1090 | -- ^ Model checking options 1091 | -> IO () 1092 | model Model 1093 | { debug 1094 | , statistics 1095 | , termination 1096 | , deadlock 1097 | , property 1098 | , startingGlobals 1099 | , coroutine = Coroutine{ startingLabel, startingLocals, process } 1100 | } = do 1101 | terminal <- ANSI.hSupportsANSI IO.stdout 1102 | 1103 | let putDoc doc = 1104 | if terminal 1105 | then Pretty.Terminal.putDoc (doc <> "\n") 1106 | else Pretty.Text.putDoc (doc <> "\n") 1107 | 1108 | redundantStatesReference <- IORef.newIORef 0 1109 | 1110 | case Property.check property of 1111 | Check finalPropertyStatus stepProperty -> do 1112 | hashtable <- HashTable.new @Cuckoo.HashTable 1113 | 1114 | let action = do 1115 | startingGlobal <- lift (lift (select startingGlobals)) 1116 | 1117 | startingLocal <- lift (lift (select startingLocals)) 1118 | 1119 | let startingProcessStatus = Status 1120 | { _global = startingGlobal 1121 | , _local = startingLocal 1122 | } 1123 | 1124 | let startingInput = Input startingGlobal startingLabel 1125 | 1126 | let _inputHistory = [ startingInput ] 1127 | 1128 | let _propertyStatus = HashSet.fromList do 1129 | s <- universe 1130 | 1131 | -- The temporal `Property` only needs to return `True` 1132 | -- for the first output, indicating that the property 1133 | -- holds for the entire sequence 1134 | (True, s') <- State.Lazy.runStateT (stepProperty startingInput) s 1135 | 1136 | return s' 1137 | 1138 | Monad.when (HashSet.null _propertyStatus) do 1139 | let _reason = Unsatisfiable 1140 | 1141 | liftIO (Exception.throw PropertyFailed{ _inputHistory, _reason }) 1142 | 1143 | let historyKey = HistoryKey startingLabel startingProcessStatus 1144 | 1145 | lift (put $! startingProcessStatus) 1146 | 1147 | put $! Timeline 1148 | { _history = [ historyKey ] 1149 | , _historySet = HashSet.singleton historyKey 1150 | , _propertyStatus 1151 | , _inputHistory 1152 | } 1153 | 1154 | loop process 1155 | 1156 | loop (Choice steps) = do 1157 | let wrap 1158 | | deadlock = State.mapStateT progressive 1159 | | otherwise = id 1160 | 1161 | step <- lift (wrap steps) 1162 | 1163 | case step of 1164 | Done () -> do 1165 | Timeline{ _propertyStatus, _inputHistory } <- get 1166 | 1167 | Monad.unless (HashSet.member finalPropertyStatus _propertyStatus) do 1168 | let _reason = UnsatisfyingConclusion 1169 | 1170 | liftIO (Exception.throw PropertyFailed{ _inputHistory, _reason }) 1171 | 1172 | Yield _label rest -> do 1173 | _processStatus <- lift get 1174 | 1175 | Timeline{ _history, _historySet, _propertyStatus, _inputHistory } <- get 1176 | 1177 | let Status{ _global } = _processStatus 1178 | 1179 | let input = Input{ _state = _global, _label } 1180 | 1181 | let newPropertyStatus = HashSet.fromList do 1182 | s <- HashSet.toList _propertyStatus 1183 | 1184 | -- We're uninterested in the output of the 1185 | -- temporal `Property` for subsequent outputs 1186 | -- because we don't care if the temporal 1187 | -- `Property` holds for a suffix of the behavior 1188 | State.Lazy.execStateT (stepProperty input) s 1189 | 1190 | let seenKey = Seen{ _label, _processStatus, _propertyStatus = newPropertyStatus } 1191 | 1192 | let historyKey = HistoryKey _label _processStatus 1193 | 1194 | let newHistory = historyKey : _history 1195 | 1196 | let newInputHistory = input : _inputHistory 1197 | 1198 | Monad.when (HashSet.null newPropertyStatus) do 1199 | let _reason = Unsatisfiable 1200 | liftIO (Exception.throw PropertyFailed{ _inputHistory = newInputHistory, _reason }) 1201 | 1202 | Monad.when (HashSet.member historyKey _historySet && termination) do 1203 | liftIO (Exception.throw (Nontermination newHistory)) 1204 | 1205 | maybeSeen <- liftIO (HashTable.lookup hashtable seenKey) 1206 | 1207 | let member = case maybeSeen of 1208 | Nothing -> False 1209 | Just _ -> True 1210 | 1211 | Monad.when member do 1212 | liftIO (IORef.modifyIORef' redundantStatesReference (+ 1)) 1213 | empty 1214 | 1215 | liftIO (HashTable.insert hashtable seenKey ()) 1216 | 1217 | lift (put $! _processStatus) 1218 | put $! Timeline 1219 | { _history = newHistory 1220 | , _historySet = HashSet.insert historyKey _historySet 1221 | , _propertyStatus = newPropertyStatus 1222 | , _inputHistory = newInputHistory 1223 | } 1224 | 1225 | loop rest 1226 | 1227 | _successfulBranches <- handler 1228 | (Logic.runLogicT 1229 | (State.evalStateT 1230 | (State.evalStateT action uninitializedProcessStatus) 1231 | uninitializedTimeline 1232 | ) 1233 | (\_ m -> do 1234 | !n <- m 1235 | return (n + 1) 1236 | ) 1237 | (return (0 :: Natural)) 1238 | ) 1239 | 1240 | _visitedStates <- HashTable.foldM (\n _ -> return (n + 1)) 0 hashtable 1241 | 1242 | _redundantStates <- IORef.readIORef redundantStatesReference 1243 | 1244 | let stats = Statistics 1245 | { _redundantStates 1246 | , _successfulBranches 1247 | , _visitedStates 1248 | } 1249 | 1250 | Monad.when statistics do 1251 | putDoc (prettyValue (toJSON stats)) 1252 | where 1253 | uninitializedProcessStatus = 1254 | error "Internal error - Uninitialized process status" 1255 | 1256 | uninitializedTimeline = 1257 | error "Internal error - Uninitialized timeline" 1258 | 1259 | handler :: IO a -> IO a 1260 | handler 1261 | | debug = Exception.handle display 1262 | | otherwise = id 1263 | where 1264 | display exception = do 1265 | putDoc (prettyModelException exception) 1266 | 1267 | Exception.throwIO (Exit.ExitFailure 1) 1268 | 1269 | -- | The input to a temporal `Property` 1270 | data Input global label = Input 1271 | { _state :: !global 1272 | -- ^ The current (global) state 1273 | , _label :: !label 1274 | -- ^ The current label 1275 | } deriving stock (Generic, Show) 1276 | deriving anyclass (ToJSON) 1277 | 1278 | -- | A lens for accessing the global state of an `Input` 1279 | state :: Lens (Input global label) (Input global' label) global global' 1280 | state k (Input a b) = fmap (\a' -> Input a' b) (k a) 1281 | {-# INLINABLE state #-} 1282 | 1283 | -- | A lens for accessing the label of an `Input` 1284 | label :: Lens (Input global label) (Input global label') label label' 1285 | label k (Input a b) = fmap (\b' -> Input a b') (k b) 1286 | {-# INLINABLE label #-} 1287 | 1288 | {-| Lift a lens on states to a lens on `Input`s 1289 | 1290 | @ 1291 | `stately` :: Lens' outer inner -> Lens' (`Input` outer label) (`Input` inner label) 1292 | @ 1293 | -} 1294 | stately 1295 | :: Lens outer outer' inner inner' 1296 | -- ^ Lens to lift 1297 | -> Lens (Input outer label) (Input outer' label) (Input inner label) (Input inner' label) 1298 | stately l k (Input a b) = 1299 | unFocusingState (l (\a' -> FocusingState (k (Input a' b))) a) 1300 | 1301 | data FocusingState f local global = 1302 | FocusingState { unFocusingState :: f (Input global local) } 1303 | 1304 | instance Functor f => Functor (FocusingState f local) where 1305 | fmap f (FocusingState x) = FocusingState (fmap adapt x) 1306 | where 1307 | adapt (Input a b) = Input (f a) b 1308 | 1309 | {-| Lift a lens on labels to a lens on `Input`s 1310 | 1311 | @ 1312 | `labelly` :: Lens' outer inner -> Lens' (`Input` state outer) (`Input` state inner) 1313 | @ 1314 | -} 1315 | labelly 1316 | :: Lens outer outer' inner inner' 1317 | -- ^ Lens to lift 1318 | -> Lens (Input state outer) (Input state outer') (Input state inner) (Input state inner') 1319 | labelly l k (Input a b) = 1320 | unFocusingLabel (l (\b' -> FocusingLabel (k (Input a b'))) b) 1321 | 1322 | data FocusingLabel f global local = 1323 | FocusingLabel { unFocusingLabel :: f (Input global local) } 1324 | 1325 | instance Functor f => Functor (FocusingLabel f local) where 1326 | fmap f (FocusingLabel x) = FocusingLabel (fmap adapt x) 1327 | where 1328 | adapt (Input a b) = Input a (f b) 1329 | 1330 | -- | Used internally to detect cycles 1331 | data Seen label processStatus propertyStatus = Seen 1332 | { _label :: !label 1333 | , _processStatus :: !processStatus 1334 | , _propertyStatus :: !propertyStatus 1335 | } deriving stock (Eq, Generic) 1336 | deriving anyclass (Hashable) 1337 | 1338 | data Statistics = Statistics 1339 | { _successfulBranches :: Natural 1340 | , _visitedStates :: Natural 1341 | , _redundantStates :: Natural 1342 | } deriving stock (Generic) 1343 | deriving anyclass (ToJSON) 1344 | --------------------------------------------------------------------------------