├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── driver └── Main.hs ├── examples ├── HIW13 │ ├── first │ │ └── Main.hs │ ├── second │ │ ├── Makefile │ │ ├── plugin │ │ │ ├── LICENSE │ │ │ ├── SecondDemo.hs │ │ │ ├── Setup.hs │ │ │ ├── hermit-second.cabal │ │ │ └── test │ │ │ │ └── sieve │ │ └── sieve.hs │ └── third │ │ ├── Concat.hs │ │ └── Makefile ├── Haskell2012 │ ├── Append.hs │ ├── Append.hss │ ├── Fib.hs │ ├── Fib.hss │ ├── HList.hs │ ├── Makefile │ ├── Reverse.hs │ ├── Reverse.hss │ ├── ReversePrelude.hs │ ├── ReverseWWTactic.hss │ └── paper │ │ └── .placeholder ├── IFL2012 │ ├── .gitignore │ ├── Fib.hs │ ├── Fib.hss │ ├── Makefile │ ├── WWSplitTactic.hss │ └── ifl-paper │ │ └── .placeholder ├── Talks │ ├── demo │ │ ├── Demo.hec │ │ ├── Demo.hs │ │ └── verify-strict-ga.hec │ ├── hermit-machine │ │ ├── Fib.hs │ │ ├── HList.hs │ │ ├── Rev.hs │ │ └── Rev.hss │ ├── hermit-swansea │ │ ├── Fib.hec │ │ ├── Fib.hs │ │ ├── Nat.hs │ │ └── WW-Ass-A.her │ ├── hermit-tree │ │ ├── Fib.hs │ │ ├── Fib.hss │ │ ├── FibWW.hs │ │ ├── Nat.hs │ │ └── WWSplitTactic.hss │ └── interact-with-hermit │ │ ├── DataKinds.hs │ │ ├── DataKinds.hss │ │ ├── Mean.hs │ │ └── Mean.hss ├── casereduce │ ├── CaseReduce.hermit │ ├── Main.hs │ └── Makefile ├── collatz │ └── Main.hs ├── concatVanishes │ ├── ConcatVanishes.hss │ ├── Flatten.hs │ ├── Flatten.hss │ ├── HList.hs │ ├── QSort.hs │ ├── QSort.hss │ ├── Rev.hs │ ├── Rev.hss │ ├── StrictRepH.hss │ └── WW-Ass-A.hss ├── contents.txt ├── dictionaries │ ├── .gitignore │ ├── Dictionaries.hs │ └── Dictionaries.hss ├── evaluation │ ├── Eval.hs │ ├── Eval.hss │ └── WW-Ass-A.hss ├── factorial │ ├── Fac.hs │ ├── Fac.hss │ └── WW-Ass-A.hss ├── fib-stream │ ├── .gitignore │ ├── Fib.hs │ ├── Fib.hss │ ├── Nat.hs │ └── Stream.hs ├── fib-tuple │ ├── Fib.hs │ ├── Fib.hss │ ├── Makefile │ ├── WW-Ass-A.hss │ └── blog.txt ├── fix-fusion │ ├── .gitignore │ ├── FStrict.hss │ ├── Fusion.hs │ ├── Fusion.hss │ ├── PreconditionL.hss │ └── PreconditionR.hss ├── flatten │ ├── Flatten.hec │ ├── Flatten.hs │ ├── HList.hs │ ├── StrictRepH.hss │ └── WW-Ass-A.hss ├── hanoi │ ├── Hanoi.hs │ ├── Hanoi.hss │ └── Makefile ├── induction │ ├── .gitignore │ ├── BaseCase.her │ ├── Induction.hs │ ├── InductiveStep.her │ └── Verify.hec ├── last │ ├── Last.hs │ ├── Last.hss │ ├── NewLast.hss │ ├── WW-Ass-B.hss │ └── last.txt ├── laws │ ├── All.hec │ ├── Identity.hec │ ├── Laws.hs │ ├── List.hec │ ├── ListLaws.hs │ ├── Map-Functor.hec │ ├── Map-Monoid.hec │ ├── Maybe.hec │ ├── MaybeLaws.hs │ ├── MonadLaws.txt │ ├── Start.hec │ ├── Tree.hec │ ├── iverify-map-append.hec │ ├── list-monad-assoc-lhs.her │ ├── list-monad-assoc-rhs.her │ ├── verify-append-assoc.hec │ ├── verify-append-nil.hec │ ├── verify-append-nonempty.hec │ ├── verify-concat-append.hec │ ├── verify-concat-concat.hec │ ├── verify-concat-nonempty.hec │ ├── verify-concat-of-toList.hec │ ├── verify-concat-unit.hec │ ├── verify-left-unit.hec │ ├── verify-list-left-unit.hec │ ├── verify-list-monad-assoc.hec │ ├── verify-list-monoid-assoc.hec │ ├── verify-list-monoid-left.hec │ ├── verify-list-monoid-right.hec │ ├── verify-list-right-unit.hec │ ├── verify-map-append.hec │ ├── verify-map-compose.hec │ ├── verify-map-concat.hec │ ├── verify-map-nonempty.hec │ ├── verify-monad-assoc.hec │ ├── verify-nil-append.hec │ └── verify-right-unit.hec ├── length │ ├── .gitignore │ ├── Length.hs │ ├── Length.hss │ ├── LengthFullBad │ │ ├── LengthFull.hs │ │ ├── LengthFull.hss │ │ ├── StrictRepFull.hss │ │ └── WW-Ass-A-Full.hss │ ├── StrictRep.hss │ └── WW-Ass-A.hss ├── map-fusion │ ├── MapFusion.hec │ ├── MapFusion.hs │ └── README ├── map │ ├── Makefile │ ├── Map.hs │ ├── Map.hss │ └── WWSplitTactic.hss ├── mean │ ├── Mean.hs │ └── Mean.hss ├── new_reverse │ ├── HList.hs │ ├── Reverse.hec │ └── Reverse.hs ├── nub │ ├── Nub.hs │ ├── Nub.hss │ ├── Revised.txt │ └── blog.txt ├── original_reverse │ ├── HList.hs │ ├── Original.hss │ ├── Reverse.hs │ └── Reverse.hss ├── qsort │ ├── HList.hs │ ├── QSort.hs │ └── QSort.hss └── reverse │ ├── HList.hs │ ├── Reverse.hs │ ├── Reverse.hss │ ├── StrictRepH.hss │ └── WW-Ass-A.hss ├── hermit.cabal ├── optimizations ├── README └── pretty │ └── hermit-pretty │ ├── HERMIT │ └── Pretty.hs │ ├── Setup.hs │ └── hermit-pretty.cabal ├── src ├── HERMIT.hs └── HERMIT │ ├── Context.hs │ ├── Core.hs │ ├── Dictionary.hs │ ├── Dictionary │ ├── AlphaConversion.hs │ ├── Common.hs │ ├── Composite.hs │ ├── Debug.hs │ ├── FixPoint.hs │ ├── Fold.hs │ ├── Function.hs │ ├── GHC.hs │ ├── Induction.hs │ ├── Inline.hs │ ├── Kure.hs │ ├── Local.hs │ ├── Local │ │ ├── Bind.hs │ │ ├── Case.hs │ │ ├── Cast.hs │ │ └── Let.hs │ ├── Navigation.hs │ ├── Navigation │ │ └── Crumbs.hs │ ├── New.hs │ ├── Query.hs │ ├── Reasoning.hs │ ├── Remembered.hs │ ├── Rules.hs │ ├── Undefined.hs │ ├── Unfold.hs │ ├── Unsafe.hs │ └── WorkerWrapper │ │ ├── Common.hs │ │ ├── Fix.hs │ │ └── FixResult.hs │ ├── Driver.hs │ ├── External.hs │ ├── GHC.hs │ ├── GHC │ └── Typechecker.hs │ ├── Kernel.hs │ ├── Kure.hs │ ├── Kure │ └── Universes.hs │ ├── Lemma.hs │ ├── Libraries │ ├── Int.hs │ └── WW.hs │ ├── Monad.hs │ ├── Name.hs │ ├── Parser.y │ ├── ParserCore.y │ ├── ParserType.y │ ├── Plugin.hs │ ├── Plugin │ ├── Builder.hs │ ├── Display.hs │ ├── Renderer.hs │ └── Types.hs │ ├── PrettyPrinter │ ├── AST.hs │ ├── Clean.hs │ ├── Common.hs │ ├── GHC.hs │ └── Glyphs.hs │ ├── Shell │ ├── Command.hs │ ├── Completion.hs │ ├── Dictionary.hs │ ├── Externals.hs │ ├── Interpreter.hs │ ├── KernelEffect.hs │ ├── Proof.hs │ ├── ScriptToRewrite.hs │ ├── ShellEffect.hs │ └── Types.hs │ ├── Syntax.hs │ └── Utilities.hs └── tests ├── Main.hs ├── README.md ├── dump └── .keep ├── golden └── golden-ghc-7103 │ ├── concatVanishes_Flatten_hs_Flatten_hss.ref │ ├── concatVanishes_QSort_hs_QSort_hss.ref │ ├── concatVanishes_Rev_hs_Rev_hss.ref │ ├── evaluation_Eval_hs_Eval_hss.ref │ ├── fib-tuple_Fib_hs_Fib_hss.ref │ ├── flatten_Flatten_hs_Flatten_hec.ref │ ├── last_Last_hs_Last_hss.ref │ ├── last_Last_hs_NewLast_hss.ref │ ├── mean_Mean_hs_Mean_hss.ref │ ├── new_reverse_Reverse_hs_Reverse_hec.ref │ ├── qsort_QSort_hs_QSort_hss.ref │ └── reverse_Reverse_hs_Reverse_hss.ref └── prims ├── Makefile ├── Test.expected.out ├── Test.hs └── Test.hss /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | *~ 3 | *.hi 4 | *.o 5 | *.swp 6 | *.swo 7 | *.DS_Store 8 | *.exe 9 | BEFORE.HERMIT.* 10 | AFTER.HERMIT.* 11 | \#* 12 | # example binaries 13 | examples/casereduce/Main 14 | examples/concatVanishes/Flatten 15 | examples/concatVanishes/QSort 16 | examples/concatVanishes/Rev 17 | examples/evaluation/Eval 18 | examples/factorial/Fac 19 | examples/fib-tuple/Fib 20 | examples/flatten/Flatten 21 | examples/hanoi/Hanoi 22 | examples/last/Last 23 | examples/map/Map 24 | examples/mean/Mean 25 | examples/qsort/QSort 26 | examples/reverse/Reverse 27 | examples/new_reverse/Reverse 28 | examples/nub/Nub 29 | examples/Haskell2012/paper/ 30 | examples/Haskell2012/Append 31 | examples/Haskell2012/Fib 32 | examples/Haskell2012/Reverse 33 | examples/IFL2012/ifl-paper/ 34 | # generated files 35 | src/HERMIT/Parser.hs 36 | src/HERMIT/ParserCore.hs 37 | src/HERMIT/ParserType.hs 38 | tests/dump/*.dump 39 | *.dump-simpl 40 | *.dump-prep 41 | .cabal-sandbox 42 | cabal.sandbox.config 43 | tags 44 | 45 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.22 GHCVER=7.10.3 ALEXVER=3.1.4 HAPPYVER=1.19.5 17 | compiler: ": #GHC 7.10.3" 18 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 19 | - env: CABALVER=1.24 GHCVER=8.0.1 ALEXVER=3.1.4 HAPPYVER=1.19.5 20 | compiler: ": #GHC 8.0.1" 21 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 22 | - env: CABALVER=head GHCVER=head ALEXVER=3.1.4 HAPPYVER=1.19.5 23 | compiler: ": #GHC head" 24 | addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 25 | 26 | allow_failures: 27 | - env: CABALVER=1.24 GHCVER=8.0.1 ALEXVER=3.1.4 HAPPYVER=1.19.5 # TODO: Remove this line 28 | - env: CABALVER=head GHCVER=head ALEXVER=3.1.4 HAPPYVER=1.19.5 29 | 30 | before_install: 31 | - unset CC 32 | - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$PATH 33 | 34 | install: 35 | - cabal --version 36 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 37 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 38 | then 39 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 40 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 41 | fi 42 | - travis_retry cabal update -v 43 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 44 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 45 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 46 | 47 | # check whether current requested install-plan matches cached package-db snapshot 48 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; 49 | then 50 | echo "cabal build-cache HIT"; 51 | rm -rfv .ghc; 52 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 53 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 54 | else 55 | echo "cabal build-cache MISS"; 56 | rm -rf $HOME/.cabsnap; 57 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 58 | cabal install -j --only-dependencies --enable-tests --enable-benchmarks; 59 | fi 60 | 61 | # snapshot package-db on cache miss 62 | - if [ ! -d $HOME/.cabsnap ]; 63 | then 64 | echo "snapshotting package-db to build-cache"; 65 | mkdir $HOME/.cabsnap; 66 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 67 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 68 | fi 69 | 70 | # Here starts the actual work to be performed for the package under test; 71 | # any command which exits with a non-zero exit code causes the build to fail. 72 | script: 73 | - if [ -f configure.ac ]; then autoreconf -i; fi 74 | - cabal configure -v2 --enable-tests 75 | - cabal build -j1 76 | - cabal copy 77 | - cabal register 78 | - cabal test -j1 --show-details=streaming 79 | - cabal check 80 | - cabal sdist 81 | 82 | # EOF 83 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, The University of Kansas 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | boot: 2 | cabal build # because newer cabal doesn't show build output with install 3 | cabal install --enable-tests --force-reinstalls --disable-documentation 4 | 5 | install: 6 | cabal install --force-reinstalls --disable-documentation 7 | 8 | clean: 9 | cabal clean 10 | 11 | ghci: 12 | cabal repl 13 | 14 | test: 15 | cabal test --show-details=streaming 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HERMIT [![Hackage version](https://img.shields.io/hackage/v/hermit.svg?style=flat)](http://hackage.haskell.org/package/hermit) [![Build Status](https://img.shields.io/travis/ku-fpg/hermit.svg?style=flat)](https://travis-ci.org/ku-fpg/hermit) 2 | 3 | The Haskell Equational Reasoning Model-to-Implementation Tunnel. 4 | 5 | ## Links 6 | * http://www.ittc.ku.edu/csdl/fpg/Tools/HERMIT 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /driver/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import HERMIT.Driver 4 | 5 | import System.Environment 6 | 7 | main :: IO () 8 | main = getArgs >>= hermitDriver 9 | -------------------------------------------------------------------------------- /examples/HIW13/first/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List (map) 4 | 5 | foo :: [Int] -> Int 6 | foo = foldl (+) 0 . map (+1) 7 | 8 | bar :: [Int] -> [Int] 9 | bar = map (*2) 10 | 11 | main :: IO () 12 | main = print $ foo . bar $ [1..10] 13 | 14 | {-# RULES "map/map" [~] forall f g xs. map f (map g xs) = map (f . g) xs #-} 15 | -------------------------------------------------------------------------------- /examples/HIW13/second/Makefile: -------------------------------------------------------------------------------- 1 | install: 2 | ( cd plugin ; cabal install --force-reinstalls ) 3 | 4 | sieve: 5 | hermit sieve.hs -opt=SecondDemo +Main sieve 6 | -------------------------------------------------------------------------------- /examples/HIW13/second/plugin/LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ku-fpg/hermit/3e7be430fae74a9e3860b8b574f36efbf9648dec/examples/HIW13/second/plugin/LICENSE -------------------------------------------------------------------------------- /examples/HIW13/second/plugin/SecondDemo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module SecondDemo (plugin) where 3 | 4 | import Control.Monad 5 | 6 | import HERMIT.Core 7 | import HERMIT.GHC hiding (display) 8 | import HERMIT.Kure 9 | import HERMIT.Optimize 10 | import HERMIT.Plugin 11 | import HERMIT.Dictionary 12 | 13 | import HERMIT.PrettyPrinter.Common 14 | import HERMIT.Shell.Types 15 | 16 | import Language.Haskell.TH as TH 17 | 18 | plugin = optimize $ \ opts -> do 19 | modifyCLS $ \ st -> st { cl_pretty_opts = updateTypeShowOption Show (cl_pretty_opts st) } 20 | at (return $ pathToSnocPath [ModGuts_Prog]) display 21 | left <- liftM passesLeft getPassInfo 22 | when (notNull left) $ liftIO $ putStrLn $ "=========== " ++ show (head left) ++ " ===========" 23 | lastPass $ interactive [] opts 24 | -------------------------------------------------------------------------------- /examples/HIW13/second/plugin/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/HIW13/second/plugin/hermit-second.cabal: -------------------------------------------------------------------------------- 1 | name: hermit-second 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | license: MIT 6 | license-file: LICENSE 7 | author: Andrew Farmer 8 | maintainer: afarmer@ittc.ku.edu 9 | -- copyright: 10 | category: Development 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: SecondDemo 17 | -- other-modules: 18 | -- other-extensions: 19 | build-depends: base >=4.7 && <4.8, 20 | ghc >= 7.6, 21 | hermit, 22 | template-haskell 23 | 24 | -- hs-source-dirs: 25 | default-language: Haskell2010 26 | -------------------------------------------------------------------------------- /examples/HIW13/second/plugin/test/sieve: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ku-fpg/hermit/3e7be430fae74a9e3860b8b574f36efbf9648dec/examples/HIW13/second/plugin/test/sieve -------------------------------------------------------------------------------- /examples/HIW13/second/sieve.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------- 2 | -- $Id: Primes.hs#1 2005/06/13 15:48:09 REDMOND\\satnams $ 3 | ------------------------------------------------------------------------------- 4 | 5 | -- Satnam reported that this didn't show any speedup up from -N1 to -N4 6 | 7 | module Main where 8 | import System.Time 9 | import Control.Concurrent 10 | import System.Environment 11 | 12 | -- how many primes to calculate in each thread 13 | n_primes :: Int 14 | n_primes = 500 15 | 16 | primes1 n done 17 | = do --putStrLn (show ((sieve [n..])!!n_primes)) 18 | show ((sieve [n..])!!n_primes) `seq` return () 19 | putMVar done () 20 | 21 | sieve (p:xs) = p : sieve [x | x <- xs, not (x `mod` p == 0)] 22 | 23 | main 24 | = runInUnboundThread $ do 25 | [str] <- getArgs 26 | let instances = read str :: Int 27 | dones <- sequence (replicate instances newEmptyMVar) 28 | sequence_ [forkIO (primes1 (i+2) (dones!!i)) | i <- [0..instances-1]] 29 | sequence_ [takeMVar (dones!!i) | i <- [0..instances-1]] 30 | -------------------------------------------------------------------------------- /examples/HIW13/third/Concat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, RankNTypes #-} 2 | {-# OPTIONS_GHC -funbox-strict-fields #-} 3 | {-# OPTIONS_GHC -fspec-constr #-} 4 | {-# OPTIONS_GHC -fdicts-cheap #-} 5 | 6 | {-# OPTIONS_GHC -optlo-O3 -optlc-O3 #-} -- this is fast... 7 | 8 | module Main where 9 | 10 | import Data.Vector.Fusion.Stream as VS 11 | import Data.Vector.Fusion.Stream.Monadic as M 12 | import Data.Vector.Fusion.Stream.Size as VS 13 | 14 | import HERMIT.Optimization.StreamFusion.Vector 15 | 16 | concatTestS :: Int -> Int 17 | concatTestS n = VS.foldl' (+) 0 $ VS.concatMap (\(!x) -> VS.enumFromStepN 1 1 x) $ VS.enumFromStepN 1 1 n 18 | {-# NOINLINE concatTestS #-} 19 | 20 | flattenTest :: Int -> Int 21 | flattenTest !n = VS.foldl' (+) 0 $ VS.flatten mk step Unknown $ VS.enumFromStepN 1 1 n 22 | where 23 | mk !x = (1,x) 24 | {-# INLINE mk #-} 25 | step (!i,!max) 26 | -- | i<=max = VS.Yield i (i+1,max) 27 | | max>(0::Int) = VS.Yield i (i+1,max-1) -- 10% faster 28 | | otherwise = VS.Done 29 | {-# INLINE step #-} 30 | {-# NOINLINE flattenTest #-} 31 | 32 | main :: IO () 33 | main = do 34 | print $ concatTestS 20000 35 | print $ flattenTest 20000 36 | -------------------------------------------------------------------------------- /examples/HIW13/third/Makefile: -------------------------------------------------------------------------------- 1 | install: 2 | ( cd ../../../optimizations/streamfusion/hermit-streamfusion ; cabal install --force-reinstalls ) 3 | 4 | vector: 5 | ghc --make -O2 Concat.hs -fforce-recomp 6 | 7 | hvector: 8 | hermit Concat.hs -opt=HERMIT.Optimization.StreamFusion.Vector +Main 9 | 10 | time: 11 | time ./Concat 12 | -------------------------------------------------------------------------------- /examples/Haskell2012/Append.hs: -------------------------------------------------------------------------------- 1 | {-# RULES "appendNil" forall xs . xs ++ [] = xs #-} 2 | 3 | {-# NOINLINE foo #-} 4 | foo = [1] ++ [] 5 | 6 | main = print foo 7 | -------------------------------------------------------------------------------- /examples/Haskell2012/Append.hss: -------------------------------------------------------------------------------- 1 | consider 'foo 2 | dump "paper/foo-before-rule.tex" "clean" "latex" 60 3 | 4 | any-bu (unfold-rule appendNil) 5 | dump "paper/foo-after-rule.tex" "clean" "latex" 60 6 | -------------------------------------------------------------------------------- /examples/Haskell2012/Fib.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | 3 | fib :: Int -> Int 4 | fib n = if n < 2 then 1 else fib(n-1) + fib(n-2) 5 | 6 | main = defaultMain 7 | [ bench "35" $ whnf fib 35 8 | ] 9 | -------------------------------------------------------------------------------- /examples/Haskell2012/Fib.hss: -------------------------------------------------------------------------------- 1 | -- Test from Haskell paper 2 | any-bu (inline 'fib) 3 | -------------------------------------------------------------------------------- /examples/Haskell2012/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | ) where 6 | 7 | type H a = [a] -> [a] 8 | 9 | {-# INLINE repH #-} 10 | repH :: [a] -> H a 11 | repH xs = (xs ++) 12 | 13 | {-# INLINE absH #-} 14 | absH :: H a -> [a] 15 | absH f = f [] 16 | 17 | -- These two we may get for free via INLINE 18 | {-# RULES "repH" forall xs . repH xs = (xs ++) #-} 19 | {-# RULES "absH" forall f . absH f = f [] #-} 20 | 21 | -- The "Algebra" for repH 22 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 23 | {-# RULES "repH []" repH [] = id #-} 24 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 25 | 26 | -- Should be in the "List" module 27 | {-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-} 28 | {-# RULES "[] ++" forall xs . [] ++ xs = xs #-} 29 | 30 | -- has preconditon 31 | {-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-} 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /examples/Haskell2012/Makefile: -------------------------------------------------------------------------------- 1 | HERMIT = perl ../../scripts/hermit.pl 2 | 3 | haskell-paper:: 4 | - $(HERMIT) Reverse.hs Reverse.hss abort 5 | 6 | test-fib: 7 | - $(HERMIT) Fib.hs resume 8 | ./Fib 9 | 10 | - $(HERMIT) Fib.hs Fib.hss resume 11 | ./Fib 12 | 13 | rev: 14 | - $(HERMIT) Reverse.hs Reverse.hss resume 15 | 16 | interactive-rev: 17 | - $(HERMIT) Reverse.hs 18 | 19 | interactive-fib: 20 | $(HERMIT) Fib.hs 21 | 22 | -------------------------------------------------------------------------------- /examples/Haskell2012/Reverse.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import HList 5 | import Data.Function (fix) 6 | 7 | {-# INLINE unwrap #-} 8 | unwrap :: ([a] -> [a]) -> ([a] -> H a) 9 | unwrap f = repH . f 10 | 11 | {-# INLINE wrap #-} 12 | wrap :: ([a] -> H a) -> ([a] -> [a]) 13 | wrap g = absH . g 14 | 15 | {-# RULES "ww" forall work . fix work = wrap (fix (unwrap . work . wrap)) #-} 16 | {-# RULES "inline-fix" forall f . fix f = let w = f w in w #-} 17 | 18 | rev [] = [] 19 | rev (x:xs) = rev xs ++ [x] 20 | 21 | main = defaultMain 22 | [ bench (show n) $ whnf (\n -> sum $ rev [1..n]) n 23 | | n <- take 8 $ [50,100..] 24 | ] 25 | -------------------------------------------------------------------------------- /examples/Haskell2012/Reverse.hss: -------------------------------------------------------------------------------- 1 | -- set-renderer latex 2 | set-renderer unicode-console 3 | 4 | 5 | -- This is the outer rev, with the big lambda 6 | consider 'rev 7 | dump "paper/0-start-rev.tex" "clean" "latex" 56 8 | 9 | set-pp-type Omit 10 | dump "paper/0b-start-rev.tex" "clean" "latex" 56 11 | 12 | down 13 | consider 'rev 14 | fix-intro 15 | dump "paper/1-fix-intro.tex" "clean" "latex" 56 16 | 17 | prune-td (unfold-rule "ww") 18 | dump "paper/2-after-ww.tex" "clean" "latex" 56 19 | 20 | prune-td (unfold '.) 21 | prune-td (unfold '.) 22 | dump "paper/4-after-unfold-dot.tex" "clean" "latex" 56 23 | 24 | prune-td (unfold 'wrap) ; prune-td (unfold 'wrap) 25 | prune-td (unfold 'unwrap) 26 | prune-td (unfold '.) 27 | dump "paper/7-wrap-unwrap-inlined.tex" "clean" "latex" 56 28 | 29 | bash 30 | dump "paper/7a-wrap-unwrap-bashed.tex" "clean" "latex" 56 31 | 32 | unshadow 33 | dump "paper/7b-wrap-unwrap-unshadow.tex" "clean" "latex" 56 34 | 35 | any-bu (case-float-arg) 36 | dump "paper/8b-case-float-arg.tex" "clean" "latex" 56 37 | 38 | prune-td (unfold-rule "repH ++") 39 | 40 | dump "paper/9-rule-rep-append.tex" "clean" "latex" 56 41 | 42 | prune-td (unfold-rule "rep-abs-fusion") 43 | dump "paper/11-rep-app-fusion.tex" "clean" "latex" 56 44 | 45 | prune-td (unfold 'repH) 46 | prune-td (unfold '.) ; bash 47 | focus (consider case) (eta-expand 'ys) 48 | any-bu case-float-app 49 | prune-td (unfold-rule "(:) ++") 50 | prune-td (unfold-rule "[] ++") 51 | prune-td (unfold 'fix) ; bash ; unshadow 52 | 53 | dump "paper/12-cleanup.tex" "clean" "latex" 56 54 | 55 | -- This is just a setup to all completion 56 | -- unshadow 57 | 58 | resume 59 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /examples/Haskell2012/ReversePrelude.hs: -------------------------------------------------------------------------------- 1 | module ReversePrelude 2 | ( fix 3 | , H 4 | , repH 5 | , absH 6 | , unwrap 7 | , wrap 8 | ) where 9 | 10 | import Data.Function (fix) 11 | 12 | type H a = [a] -> [a] 13 | 14 | {-# NOINLINE repH #-} 15 | repH :: [a] -> H a 16 | repH xs = (xs ++) 17 | 18 | {-# NOINLINE absH #-} 19 | absH :: H a -> [a] 20 | absH f = f [] 21 | 22 | {-# INLINE unwrap #-} 23 | unwrap :: ([a] -> [a]) -> ([a] -> H a) 24 | unwrap f = repH . f 25 | 26 | {-# INLINE wrap #-} 27 | wrap :: ([a] -> H a) -> ([a] -> [a]) 28 | wrap g = absH . g 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /examples/Haskell2012/ReverseWWTactic.hss: -------------------------------------------------------------------------------- 1 | rhs-of 'rev 2 | consider 'rev 3 | load "../fib/WWSplitTactic.hss" 4 | -- proceed with rest of derivation 5 | -------------------------------------------------------------------------------- /examples/Haskell2012/paper/.placeholder: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ku-fpg/hermit/3e7be430fae74a9e3860b8b574f36efbf9648dec/examples/Haskell2012/paper/.placeholder -------------------------------------------------------------------------------- /examples/IFL2012/.gitignore: -------------------------------------------------------------------------------- 1 | Fib 2 | -------------------------------------------------------------------------------- /examples/IFL2012/Fib.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -- so we can fix-intro 4 | import Data.Function (fix) 5 | 6 | import Prelude hiding ((+)) 7 | 8 | data Nat = Z | S Nat 9 | 10 | {-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-} 11 | {-# RULES "precondition" forall w . wrap (unwrap w) = w #-} 12 | 13 | (+) :: Nat -> Nat -> Nat 14 | Z + n = n 15 | (S n') + n = S (n' + n) 16 | 17 | fromInt :: Int -> Nat 18 | fromInt 0 = Z 19 | fromInt i | i < 0 = error "fromInt negative" 20 | | otherwise = S (fromInt (i-1)) 21 | 22 | toInt :: Nat -> Int 23 | toInt Z = 0 24 | toInt (S n) = succ (toInt n) 25 | 26 | -- original fib definition 27 | fib :: Nat -> Nat 28 | fib Z = Z 29 | fib (S Z) = S Z 30 | fib (S (S n)) = fib (S n) + fib n 31 | 32 | -- goal: 33 | -- fib' = fst work 34 | -- where work Z = (Z, S Z) 35 | -- work (S n) = let (x,y) = work n 36 | -- in (y,x+y) 37 | 38 | wrap :: (Nat -> (Nat, Nat)) -> Nat -> Nat 39 | wrap h = fst . h 40 | 41 | unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat) 42 | unwrap h n = (h n, h (S n)) 43 | 44 | main :: IO () 45 | main = print $ toInt $ fib $ fromInt 30 46 | -------------------------------------------------------------------------------- /examples/IFL2012/Fib.hss: -------------------------------------------------------------------------------- 1 | set-pp-type Show 2 | flatten-module 3 | 4 | -- do the w/w split 5 | consider 'fib 6 | dump "ifl-paper/0-start.tex" "clean" "latex" 82 7 | 8 | load "WWSplitTactic.hss" 9 | dump "ifl-paper/1-aftersplit.tex" "clean" "latex" 82 10 | 11 | -- now ready to start neil's derivation 12 | consider 'work ; remember origwork 13 | dump "ifl-paper/2-afterstash.tex" "clean" "latex" 82 14 | 15 | -- work = unwrap (f (wrap work)) 16 | -- extensionality (eta-expand) 17 | 0 ; eta-expand 'n 18 | 19 | -- work n = unwrap (f (wrap work)) n 20 | -- unfold 'unwrap 21 | any-call (unfold 'unwrap) 22 | dump "ifl-paper/3-unfoldunwrap.tex" "clean" "latex" 82 23 | 24 | -- work n = (f (wrap work) n, f (wrap work) (n+1)) 25 | -- case 'n 26 | 0 ; case-split-inline 'n 27 | dump "ifl-paper/4-casesplit.tex" "clean" "latex" 82 28 | 29 | -- work 0 = (f (wrap work) 0, f (wrap work) 1) 30 | -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2)) 31 | -- unfold 'f 32 | { 1 ; any-call (unfold 'f) } 33 | { 2 ; 0 ; 1 ; any-call (unfold 'f) } 34 | simplify 35 | dump "ifl-paper/5-unfoldf.tex" "clean" "latex" 82 36 | 37 | -- work 0 = (0, 1) 38 | -- work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) 39 | -- unfold 'work 40 | 2 ; 0 ; { 1 ; any-call (unfold origwork) } 41 | dump "ifl-paper/6-stashapply.tex" "clean" "latex" 82 42 | 43 | -- work 0 = (0, 1) 44 | -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) 45 | -- wrap . unwrap = id (precondition) 46 | any-call (unfold-rule precondition) 47 | dump "ifl-paper/7-precondition.tex" "clean" "latex" 82 48 | 49 | -- work 0 = (0, 1) 50 | -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n) 51 | -- let-intro x2, let-float-tuple 52 | { 1 ; 1 ; let-intro 'x } 53 | { 0 ; 1 ; let-intro 'y } 54 | innermost let-float 55 | any-call (fold 'y) 56 | dump "ifl-paper/8-xandy.tex" "clean" "latex" 82 57 | 58 | let-tuple 'xy 59 | dump "ifl-paper/9-lettuple.tex" "clean" "latex" 82 60 | 61 | -- work 0 = (0, 1) 62 | -- work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y) 63 | -- fold 'unwrap 64 | any-call (fold 'unwrap) 65 | dump "ifl-paper/10-foldunwrap.tex" "clean" "latex" 82 66 | 67 | -- work 0 = (0, 1) 68 | -- work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y) 69 | -- fold 'work 70 | any-call (fold origwork) 71 | dump "ifl-paper/11-stashfold.tex" "clean" "latex" 82 72 | 73 | -- work 0 = (0, 1) 74 | -- work (n+1) = let (x,y) = work n in (y,x+y) 75 | top ; consider 'fib 76 | innermost let-elim 77 | any-call (unfold 'wrap) ; simplify 78 | dump "ifl-paper/12-final.tex" "clean" "latex" 82 79 | -------------------------------------------------------------------------------- /examples/IFL2012/Makefile: -------------------------------------------------------------------------------- 1 | HERMIT = hermit 2 | 3 | fib: 4 | - $(HERMIT) Fib.hs Fib.hss resume 5 | 6 | interactive: 7 | - $(HERMIT) Fib.hs Fib.hss 8 | 9 | start: 10 | - $(HERMIT) Fib.hs 11 | 12 | test: 13 | - rm *.o *.hi Fib 14 | - ghc --make -O2 -o Fib -fforce-recomp Fib.hs 15 | - ./Fib > timing.txt 16 | - echo "===========================================" >> timing.txt 17 | - $(HERMIT) Fib.hs Fib.hss resume 18 | - ./Fib >> timing.txt 19 | - cat timing.txt 20 | -------------------------------------------------------------------------------- /examples/IFL2012/WWSplitTactic.hss: -------------------------------------------------------------------------------- 1 | -- this is a (pretty general) ww tactic 2 | -- it transforms: 3 | -- 4 | -- rec g = body (where body mentions g) 5 | -- 6 | -- into: 7 | -- 8 | -- g = let f = \g -> body (f is not recursive) 9 | -- rec work = unwrap (f (wrap work)) 10 | -- in wrap work 11 | -- 12 | -- Note: inlining f (and bashing) would result in the same code 13 | -- achieved in the reverse example by applying the "ww" rule. 14 | -- 15 | -- The original function g is now a non-recursive wrapping of the worker. 16 | -- The worker makes use of the original body, and is recursive. 17 | -- 18 | -- So what have we gained doing it this way? Mainly, the noise of the 19 | -- original body is all tidily hidden in f, and we can focus on manipulating 20 | -- the wrap and unwrap functions, which is what we want to do. 21 | -- 22 | -- I've tested this on reverse, and it also works, so I think the 23 | -- next step is to formulate it as an actual rewrite, or otherwise 24 | -- bundle it up as a one-liner. 25 | -- 26 | -- TODO: this relies on a RULES pragmas: 27 | -- 28 | -- {-# RULES "ww" forall work . fix work = wrap (fix (unwrap . work . wrap)) #-} 29 | -- 30 | -- We either need to provide this somehow, or implement it as a rewrite. 31 | -- 32 | -- BEGIN: ww tactic 33 | { 34 | fix-intro 35 | consider lam 36 | let-intro 'f 37 | up 38 | let-float-arg 39 | 1 40 | apply-rule ww 41 | simplify 42 | { 1; let-intro 'w } 43 | let-float-arg 44 | { rhs-of 'w 45 | unfold 'fix ; alpha-let ['work] 46 | simplify 47 | } 48 | let-subst 49 | let-float-arg 50 | } 51 | -- END: ww tactic 52 | -------------------------------------------------------------------------------- /examples/IFL2012/ifl-paper/.placeholder: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ku-fpg/hermit/3e7be430fae74a9e3860b8b574f36efbf9648dec/examples/IFL2012/ifl-paper/.placeholder -------------------------------------------------------------------------------- /examples/Talks/demo/Demo.hec: -------------------------------------------------------------------------------- 1 | binding-of 'f 2 | 3 | { consider case 4 | 5 | { case-alt 0 ; alt-rhs 6 | one-td (inline 'wild) 7 | unfold '&& 8 | case-reduce 9 | } 10 | 11 | -- case-elim-merge-alts 12 | 13 | } 14 | 15 | { consider app 16 | -- case-float-arg-unsafe 17 | rule-to-lemma "strict-ga" 18 | load-and-run "verify-strict-ga.hec" 19 | case-float-arg (forward (lemma "strict-ga")) 20 | 21 | } 22 | -------------------------------------------------------------------------------- /examples/Talks/demo/Demo.hs: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | -------------------------------------------- 4 | 5 | -- Part 1 6 | 7 | f :: Bool -> Bool -> Int 8 | f a b = g a (if b then True else b && True) 9 | 10 | -------------------------------------------- 11 | 12 | -- Part 2 13 | 14 | g :: Bool -> Bool -> Int 15 | g a True = 1 16 | g a False = g False True 17 | 18 | {-# RULES "strict-ga" [1] forall a. g a undefined = undefined #-} 19 | 20 | -------------------------------------------- 21 | -------------------------------------------------------------------------------- /examples/Talks/demo/verify-strict-ga.hec: -------------------------------------------------------------------------------- 1 | define-script "strict-ga-proof" "unfold 'g ; undefined-case" 2 | 3 | verify-lemma "strict-ga" (script-to-proof "strict-ga-proof") 4 | 5 | 6 | 7 | -- verify-lemma "strict-ga" (rewrite-to-proof (unfold 'g >>> undefined-case)) -------------------------------------------------------------------------------- /examples/Talks/hermit-machine/Fib.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | fib :: Int -> Int 4 | fib n = if n < 2 5 | then 1 6 | else fib (n-1) + fib (n-2) 7 | 8 | main :: IO () 9 | main = putStrLn $ "fib 30 = " ++ show (fib 30) 10 | -------------------------------------------------------------------------------- /examples/Talks/hermit-machine/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( repH 3 | , absH 4 | ) where 5 | 6 | {-# INLINE repH #-} 7 | repH :: [a] -> [a] -> [a] 8 | repH xs = (xs ++) 9 | 10 | {-# INLINE absH #-} 11 | absH :: ([a] -> [a]) -> [a] 12 | absH f = f [] 13 | 14 | {-# RULES "repH ++" forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-} 15 | 16 | {-# RULES "(:) ++" forall x xs ys. (x:xs) ++ ys = x : (xs ++ ys) #-} 17 | {-# RULES "[] ++" forall xs. [] ++ xs = xs #-} 18 | 19 | -- has preconditon 20 | {-# RULES "rep-abs-fusion" forall w . repH (absH w) = w #-} 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /examples/Talks/hermit-machine/Rev.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import HList 4 | import Data.Function (fix) 5 | 6 | -- rev :: [a] -> [a] 7 | rev [] = [] 8 | rev (x:xs) = rev xs ++ [x] 9 | 10 | wrap :: ([a] -> [a] -> [a]) -> ([a] -> [a]) 11 | wrap g = absH . g 12 | 13 | unwrap :: ([a] -> [a]) -> ([a] -> [a] -> [a]) 14 | unwrap f = repH . f 15 | 16 | {-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-} 17 | 18 | main :: IO () 19 | main = putStrLn $ "Successfully reversed a list of " 20 | ++ show (length $ rev [1..15000]) 21 | ++ " elements." 22 | 23 | -------------------------------------------------------------------------------- /examples/Talks/hermit-machine/Rev.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | consider 'rev 3 | { 4 | consider 'rev 5 | fix-intro 6 | down 7 | unfold-rule "ww" 8 | any-td (unfold '.) 9 | any-td (unfold 'wrap) 10 | one-td (unfold 'unwrap) 11 | any-td (unfold '.) 12 | bash 13 | unshadow 14 | down 15 | one-td case-float-arg 16 | one-td (unfold-rule "repH ++") 17 | one-td (unfold-rule "rep-abs-fusion") 18 | any-td (unfold 'repH) 19 | any-td (unfold '.) 20 | focus (consider case) (eta-expand 'acc) 21 | one-td case-float-app 22 | one-td (unfold-rule "(:) ++") 23 | any-td (unfold-rule "[] ++") 24 | one-td (unfold 'fix) 25 | bash 26 | alpha-let ['work] 27 | one-td (unfold 'absH) 28 | down ; down ; down 29 | alpha-lam 'ys 30 | down 31 | } 32 | bash 33 | -------------------------------------------------------------------------------- /examples/Talks/hermit-swansea/Fib.hec: -------------------------------------------------------------------------------- 1 | -- "hermit Fib.hs +Main Fib.hec" 2 | 3 | flatten-module 4 | 5 | binding-of 'fib 6 | { 7 | 8 | load-as-rewrite "WWA" "WW-Ass-A.her" 9 | ww-split [| wrap |] [| unwrap |] (ww-AssA-to-AssC WWA) 10 | 11 | binding-of 'work ; remember origwork 12 | 13 | def-rhs ; eta-expand 'n 14 | 15 | any-call (unfold 'unwrap) 16 | 17 | lam-body ; case-split-inline 'n 18 | 19 | { case-alt 0 ; any-call (unfold 'f) } 20 | { [ case-alt 1, alt-rhs, app-arg] ; any-call (unfold 'f) } 21 | simplify 22 | 23 | [ case-alt 1, alt-rhs ] 24 | { app-arg ; any-call (unfold-remembered origwork) } 25 | 26 | any-bu (forward (ww-assumption-A [| wrap |] [| unwrap |] WWA )) 27 | 28 | { arg 3 ; arg 1 ; let-intro 'x } 29 | { arg 2 ; let-intro 'y } 30 | innermost let-float 31 | try (reorder-lets ['x,'y]) 32 | one-td (fold 'y) 33 | let-tuple 'xy 34 | 35 | one-td (fold 'unwrap) 36 | 37 | one-td (fold-remembered origwork) 38 | 39 | } 40 | 41 | { def-rhs ; let-elim } 42 | 43 | any-call (unfold 'wrap) 44 | 45 | 46 | -------------------------------------------------------------------------------- /examples/Talks/hermit-swansea/Fib.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -- So that we can use the worker/wrapper transformation. 4 | import Data.Function (fix) 5 | 6 | import Prelude hiding ((+)) 7 | import Nat 8 | 9 | -------------------------------------------- 10 | 11 | fib :: Nat -> Nat 12 | fib Zero = Zero 13 | fib (Succ Zero) = Succ Zero 14 | fib (Succ (Succ n)) = fib (Succ n) + fib n 15 | 16 | -------------------------------------------- 17 | 18 | main :: IO () 19 | main = print (fromNat $ fib $ toNat 30) 20 | 21 | -------------------------------------------- 22 | 23 | wrap :: (Nat -> (Nat, Nat)) -> Nat -> Nat 24 | wrap h n = fst (h n) 25 | 26 | unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat) 27 | unwrap h n = (h n, h (Succ n)) 28 | 29 | -------------------------------------------- 30 | -------------------------------------------------------------------------------- /examples/Talks/hermit-swansea/Nat.hs: -------------------------------------------------------------------------------- 1 | module Nat where 2 | 3 | import Prelude hiding ((+)) 4 | 5 | -------------------------------------------- 6 | 7 | data Nat = Zero | Succ Nat deriving (Eq,Show) 8 | 9 | (+) :: Nat -> Nat -> Nat 10 | Zero + n = n 11 | (Succ m) + n = Succ (m + n) 12 | 13 | toNat :: Integer -> Nat 14 | toNat 0 = Zero 15 | toNat i | i < 0 = error "toNat: negative integer" 16 | | otherwise = Succ (toNat (pred i)) 17 | 18 | fromNat :: Nat -> Integer 19 | fromNat Zero = 0 20 | fromNat (Succ n) = succ (fromNat n) 21 | 22 | -------------------------------------------- 23 | -------------------------------------------------------------------------------- /examples/Talks/hermit-swansea/WW-Ass-A.her: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper Assumption A: wrap (unwrap h) => h 2 | 3 | -- wrap (unwrap h) 4 | { eta-expand 'n } 5 | -- \ n -> wrap (unwrap h) n 6 | { any-call (unfold 'wrap) } 7 | -- \ n -> fst (unwrap h n) 8 | { any-call (unfold 'unwrap) } 9 | -- \ n -> fst (h n, h (S n)) 10 | { bash } 11 | -- h 12 | -------------------------------------------------------------------------------- /examples/Talks/hermit-tree/Fib.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding ((+)) 4 | import Nat 5 | 6 | fib :: Nat -> Nat 7 | fib Zero = Zero 8 | fib (Succ Zero) = Succ Zero 9 | fib (Succ (Succ n)) = fib (Succ n) + fib n 10 | 11 | main :: IO () 12 | main = print (fromNat $ fib $ toNat 30) 13 | -------------------------------------------------------------------------------- /examples/Talks/hermit-tree/Fib.hss: -------------------------------------------------------------------------------- 1 | set-pp-type Show 2 | flatten-module 3 | consider 'fib 4 | { 5 | load-and-run "WWSplitTactic.hss" 6 | consider 'work 7 | remember origwork 8 | 0 9 | eta-expand 'n 10 | any-call (unfold 'unwrap) 11 | 0 12 | case-split-inline 'n 13 | { 1 ; any-call (unfold 'f) } 14 | { 2 ; 0 ; 1 ; any-call (unfold 'f) } 15 | simplify 16 | 2 ; 0 ; { 1 ; any-call (unfold origwork) } 17 | any-call (unfold-rule precondition) 18 | { 1 ; 1 ; let-intro 'x } 19 | { 0 ; 1 ; let-intro 'y } 20 | innermost let-float 21 | try (reorder-lets ['x,'y]) 22 | any-call (fold 'y) 23 | let-tuple 'xy 24 | any-call (fold 'unwrap) 25 | any-call (fold origwork) 26 | } 27 | innermost let-elim 28 | any-call (unfold 'wrap) 29 | simplify 30 | 31 | -------------------------------------------------------------------------------- /examples/Talks/hermit-tree/FibWW.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding ((+)) 4 | import GHC.Tuple 5 | import Data.Function (fix) 6 | import Nat 7 | 8 | fib :: Nat -> Nat 9 | fib Zero = Zero 10 | fib (Succ Zero) = Succ Zero 11 | fib (Succ (Succ n)) = fib (Succ n) + fib n 12 | 13 | wrap :: (Nat -> (Nat, Nat)) -> Nat -> Nat 14 | wrap h = fst . h 15 | 16 | unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat) 17 | unwrap h n = (h n, h (Succ n)) 18 | 19 | {-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-} 20 | {-# RULES "precondition" forall w. wrap (unwrap w) = w #-} 21 | 22 | main :: IO () 23 | main = print (fromNat $ fib $ toNat 30) 24 | -------------------------------------------------------------------------------- /examples/Talks/hermit-tree/Nat.hs: -------------------------------------------------------------------------------- 1 | module Nat where 2 | 3 | import Prelude hiding ((+)) 4 | 5 | data Nat = Zero | Succ Nat deriving (Eq,Show) 6 | 7 | (+) :: Nat -> Nat -> Nat 8 | Zero + n = n 9 | (Succ m) + n = Succ (m + n) 10 | 11 | toNat :: Integer -> Nat 12 | toNat 0 = Zero 13 | toNat n = Succ (toNat (pred n)) 14 | 15 | fromNat :: Nat -> Integer 16 | fromNat Zero = 0 17 | fromNat (Succ n) = succ (fromNat n) -------------------------------------------------------------------------------- /examples/Talks/hermit-tree/WWSplitTactic.hss: -------------------------------------------------------------------------------- 1 | { 2 | fix-intro 3 | consider lam 4 | let-intro 'f 5 | up 6 | let-float-arg 7 | 1 8 | apply-rule ww 9 | simplify 10 | { 1; let-intro 'w } 11 | let-float-arg 12 | { rhs-of 'w 13 | unfold 'fix ; alpha-let ['work] 14 | simplify 15 | } 16 | let-subst 17 | let-float-arg 18 | } 19 | -------------------------------------------------------------------------------- /examples/Talks/interact-with-hermit/DataKinds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, KindSignatures, DataKinds, TypeFamilies, TypeOperators #-} 2 | 3 | module Main where 4 | 5 | import Prelude hiding ((++),zipWith) 6 | 7 | 8 | data Nat = Zero | Succ Nat 9 | 10 | 11 | data Vec :: * -> Nat -> * where 12 | Nil :: Vec a Zero 13 | Cons :: a -> Vec a n -> Vec a (Succ n) 14 | 15 | 16 | type family (m :: Nat) :+: (n :: Nat) :: Nat 17 | type instance Zero :+: n = n 18 | type instance (Succ m) :+: n = Succ (m :+: n) 19 | 20 | 21 | (++) :: Vec a m -> Vec a n -> Vec a (m :+: n) 22 | Nil ++ bs = bs 23 | (a `Cons` as) ++ bs = a `Cons` (as ++ bs) 24 | 25 | zipWith :: (a -> b -> c) -> Vec a n -> Vec b n -> Vec c n 26 | zipWith f Nil Nil = Nil 27 | zipWith f (Cons a as) (Cons b bs) = Cons (f a b) (zipWith f as bs) 28 | 29 | ------------------------------------------------ 30 | 31 | main :: IO () 32 | main = print "hello world" 33 | 34 | ------------------------------------------------ 35 | -------------------------------------------------------------------------------- /examples/Talks/interact-with-hermit/DataKinds.hss: -------------------------------------------------------------------------------- 1 | unshadow 2 | consider '++ 3 | set-pp-type Show 4 | -------------------------------------------------------------------------------- /examples/Talks/interact-with-hermit/Mean.hs: -------------------------------------------------------------------------------- 1 | module Main (main, mean) where 2 | 3 | import Prelude hiding (sum, length) 4 | 5 | mean :: [Int] -> Int 6 | mean xs = sum xs `div` length xs 7 | 8 | sum :: [Int] -> Int 9 | sum [] = 0 10 | sum (x:xs) = x + sum xs 11 | 12 | length :: [Int] -> Int 13 | length [] = 0 14 | length (x:xs) = 1 + length xs 15 | 16 | main :: IO () 17 | main = print $ mean [1..10] 18 | -------------------------------------------------------------------------------- /examples/Talks/interact-with-hermit/Mean.hss: -------------------------------------------------------------------------------- 1 | {rhs-of 'mean ; 0 2 | { 1 ; let-intro 'l } 3 | { 0 ; 1 ; let-intro 's } 4 | innermost let-float 5 | try (reorder-lets ['s,'l]) 6 | let-tuple 'sl 7 | { 0 ; abstract 'xs ; 0 ; let-intro 'sumlength } 8 | } 9 | innermost let-float 10 | consider 'sumlength 11 | nonrec-to-rec -- since we intend sumlength to be a recursive function 12 | 0 13 | remember sumlen 14 | { 0 ; 0 15 | case-split-inline 'xs 16 | any-call (unfold 'sum) 17 | any-call (unfold 'length) 18 | simplify 19 | 2 20 | alpha-alt ['y,'ys] 21 | 0 22 | { 1 ; 1 ; let-intro 'l } 23 | { 0 ; 1 ; 1 ; let-intro 's } 24 | innermost let-float 25 | try (reorder-lets ['s,'l]) 26 | let-tuple 'sl 27 | { 0 ; fold sumlen } 28 | } 29 | -------------------------------------------------------------------------------- /examples/casereduce/CaseReduce.hermit: -------------------------------------------------------------------------------- 1 | consider 'foo 2 | anybu inline 3 | anytd caseReduce 4 | . 5 | -------------------------------------------------------------------------------- /examples/casereduce/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | data Foo = Bar Int Float | Baz String 4 | 5 | main = print foo 6 | 7 | bar = Bar 5 2.1 8 | foo = case bar of 9 | Bar x f -> show x 10 | Baz s -> s 11 | -------------------------------------------------------------------------------- /examples/casereduce/Makefile: -------------------------------------------------------------------------------- 1 | boot:: 2 | (cd ../.. ; make boot ) 3 | make comp 4 | 5 | comp:: 6 | ghc-7.4.1 -fplugin=Language.HERMIT.Plugin Main.hs \ 7 | -fplugin-opt=Language.HERMIT.Plugin:main:Main/CaseReduce.hermit \ 8 | -fforce-recomp -dcore-lint 9 | -------------------------------------------------------------------------------- /examples/collatz/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | collatz :: Integer -> Integer 4 | collatz n | even n = n `div` 2 5 | | odd n = 3 * n + 1 6 | 7 | chop :: [Integer] -> [Integer] 8 | chop (x:xs) = x : if x == 1 then [] else chop xs 9 | 10 | chain :: Integer -> [Integer] 11 | chain = chop . iterate collatz 12 | 13 | {-# RULES "map !!" forall f xs n . map f xs !! n = f (xs !! n) #-} 14 | 15 | {-# RULES "!! [n..]" forall n x . [n..] !! x = x + n #-} 16 | 17 | -- ww : [[Integer]] ~~> Map Int [Integer] 18 | 19 | chains :: [[Integer]] 20 | chains = map chain [1..] 21 | 22 | lengths :: [Int] 23 | lengths = map length chains 24 | 25 | longest_chain :: Int -> Int 26 | longest_chain n = maximum (take n lengths) 27 | 28 | main = print $ head [ i 29 | | (x,i) <- lengths `zip` [1..] 30 | , x == longest_chain 1000000 31 | ] 32 | -------------------------------------------------------------------------------- /examples/concatVanishes/ConcatVanishes.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | define-rewrite "WWC" "ww-result-AssA-to-AssC WWA" 3 | load-as-rewrite "StrictRepH" "StrictRepH.hss" 4 | 5 | run-script "do-the-ww-split" -- ugly hack because we lack paramaterisable scripts 6 | 7 | bash 8 | { rhs-of 'work 9 | lam-body 10 | eta-expand 'acc 11 | lam-body 12 | bash-extended-with [ push 'repH StrictRepH, forward ww-result-fusion, unfold-rules-unsafe ["repH ++","repH (:)","repH []"] ] 13 | try (bash-extended-with [push-unsafe 'work]) 14 | } 15 | one-td (unfold 'absH) 16 | -------------------------------------------------------------------------------- /examples/concatVanishes/Flatten.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import HList 5 | 6 | data Tree a = Node (Tree a) (Tree a) | Leaf a 7 | 8 | flatten :: Tree a -> [a] 9 | flatten (Leaf a) = [a] 10 | flatten (Node l r) = flatten l ++ flatten r 11 | 12 | main :: IO () 13 | main = print (flatten (Node (Leaf 'h') (Leaf 'i'))) 14 | 15 | 16 | -- Should be in the "List" module 17 | {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 18 | {-# RULES "++ strict" (++) undefined = undefined #-} 19 | 20 | -- The "Algebra" for repH 21 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 22 | {-# RULES "repH []" repH [] = id #-} 23 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 24 | 25 | -------------------------------------------------------------------------------- /examples/concatVanishes/Flatten.hss: -------------------------------------------------------------------------------- 1 | define-script "do-the-ww-split" "binding-of 'flatten ; ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC" 2 | load-and-run "ConcatVanishes.hss" 3 | -------------------------------------------------------------------------------- /examples/concatVanishes/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | ) where 6 | 7 | type H a = [a] -> [a] 8 | 9 | {-# INLINE repH #-} 10 | repH :: [a] -> H a 11 | repH xs = (xs ++) 12 | 13 | {-# INLINE absH #-} 14 | absH :: H a -> [a] 15 | absH f = f [] 16 | 17 | -- -- Should be in the "List" module 18 | -- {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 19 | -- {-# RULES "++ strict" (++) undefined = undefined #-} 20 | 21 | -- -- The "Algebra" for repH 22 | -- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 23 | -- {-# RULES "repH []" repH [] = id #-} 24 | -- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 25 | -------------------------------------------------------------------------------- /examples/concatVanishes/QSort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import HList 5 | import Data.List 6 | 7 | data Tree a = Node (Tree a) (Tree a) | Leaf a 8 | 9 | qsort :: Ord a => [a] -> [a] 10 | qsort [] = [] 11 | qsort (a:as) = qsort bs ++ [a] ++ qsort cs 12 | where 13 | (bs , cs) = partition (< a) as 14 | 15 | main :: IO () 16 | main = print (qsort [8,3,5,7,2,9,4,6,3,2]) 17 | 18 | -- Should be in the "List" module 19 | {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 20 | {-# RULES "++ strict" (++) undefined = undefined #-} 21 | 22 | -- The "Algebra" for repH 23 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 24 | {-# RULES "repH []" repH [] = id #-} 25 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 26 | -------------------------------------------------------------------------------- /examples/concatVanishes/QSort.hss: -------------------------------------------------------------------------------- 1 | define-script "do-the-ww-split" "binding-of 'qsort ; ww-result-split-static-arg 2 [0] [| absH |] [| repH |] WWC" 2 | load-and-run "ConcatVanishes.hss" 3 | -------------------------------------------------------------------------------- /examples/concatVanishes/Rev.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import HList 5 | 6 | rev :: [a] -> [a] 7 | rev [] = [] 8 | rev (y:ys) = rev ys ++ [y] 9 | 10 | main :: IO () 11 | main = print $ rev [1..10] 12 | 13 | 14 | -- Should be in the "List" module 15 | {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 16 | {-# RULES "++ strict" (++) undefined = undefined #-} 17 | 18 | -- The "Algebra" for repH 19 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 20 | {-# RULES "repH []" repH [] = id #-} 21 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 22 | 23 | -------------------------------------------------------------------------------- /examples/concatVanishes/Rev.hss: -------------------------------------------------------------------------------- 1 | define-script "do-the-ww-split" "binding-of 'rev ; ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC" 2 | load-and-run "ConcatVanishes.hss" 3 | -------------------------------------------------------------------------------- /examples/concatVanishes/StrictRepH.hss: -------------------------------------------------------------------------------- 1 | -- Proof that "repH" is strict 2 | 3 | 4 | -- repH ty (undefined [ty]) 5 | { unfold 'repH } 6 | -- (++) ty (undefined [ty]) 7 | { unfold-rule-unsafe "++ strict" } 8 | -- undefined ([ty] -> [ty]) 9 | -------------------------------------------------------------------------------- /examples/concatVanishes/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper (Result Variant) Assumption A: absH (repH x) <=> x 2 | 3 | -- absH (repH x) 4 | { unfold 'absH } 5 | -- repH x [] 6 | { unfold 'repH } 7 | -- x ++ [] 8 | { unfold-rule-unsafe "++ []" } 9 | -- x 10 | -------------------------------------------------------------------------------- /examples/dictionaries/.gitignore: -------------------------------------------------------------------------------- 1 | Dictionaries 2 | -------------------------------------------------------------------------------- /examples/dictionaries/Dictionaries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, InstanceSigs, ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Prelude hiding (abs) 6 | 7 | import Data.Function (fix) 8 | 9 | import Unsafe.Coerce 10 | 11 | data TypeRep = T_Int | T_List TypeRep | T_Fun TypeRep TypeRep -- deriving Eq 12 | 13 | eqTyRep :: TypeRep -> TypeRep -> Bool 14 | eqTyRep T_Int T_Int = True 15 | eqTyRep (T_List t1) (T_List t2) = eqTyRep t1 t2 16 | eqTyRep (T_Fun t1 t1') (T_Fun t2 t2') = eqTyRep t1 t2 && eqTyRep t1' t2' 17 | eqTyRep _ _ = False 18 | 19 | class Data a where 20 | gmapT :: (forall b. (Data b) => b -> b) -> a -> a 21 | typeOf :: a -> TypeRep 22 | 23 | instance Data Int where 24 | gmapT _ x = x 25 | typeOf _ = T_Int 26 | 27 | instance Data a => Data [a] where 28 | gmapT h [] = [] 29 | gmapT h (x : xs) = h x : h xs 30 | typeOf x = T_List (typeOf (head x)) 31 | 32 | inc :: (forall b. (Data b) => b -> b) 33 | inc = undefined 34 | 35 | everywhere :: (Data a) => a -> a 36 | everywhere x = inc (gmapT everywhere x) 37 | 38 | -- everywhere' :: forall a. Data a => a -> a 39 | -- everywhere' = undefined 40 | -- where fix' :: ((forall x. Data x => x -> x) -> (forall y. Data y => y -> y)) -> (forall z. Data z => z -> z) 41 | -- fix' = fix 42 | 43 | -- everywhereListInt :: [Int] -> [Int] 44 | -- everywhereListInt = everywhere 45 | 46 | ------ 47 | 48 | -- everywhere2Int :: Int -> Int 49 | -- everywhere2Int = mkT inc 50 | 51 | -- everywhere2ListInt :: [Int] -> [Int] 52 | -- everywhere2ListInt [] = [] 53 | -- everywhere2ListInt (x : xs) = mkT inc (everywhere2Int x : everywhere2ListInt xs) 54 | 55 | ----- 56 | 57 | gmapTInt :: Int -> Int 58 | gmapTInt = id 59 | 60 | gmapTListInt :: [Int] -> [Int] 61 | gmapTListInt [] = [] 62 | gmapTListInt (x : xs) = everywhereInt x : everywhereListInt xs 63 | 64 | everywhereInt :: Int -> Int 65 | everywhereInt x = inc (gmapTInt x) 66 | 67 | everywhereListInt :: [Int] -> [Int] 68 | everywhereListInt x = inc (gmapTListInt x) 69 | 70 | ----- 71 | 72 | 73 | type T1 = forall a. (Data a) => a -> a 74 | type T2 = (Int -> Int, [Int] -> [Int]) 75 | 76 | rep :: T1 -> T2 77 | rep t1 = (t1 :: Int -> Int, t1 :: [Int] -> [Int]) 78 | 79 | -- abs (f1, f2) = mkT f1 `extT` f2 80 | abs :: T2 -> T1 81 | abs (f1, f2) x = if T_Int `eqTyRep` typeOf x 82 | then unsafeCoerce (f1 (unsafeCoerce x)) 83 | else if T_List T_Int `eqTyRep` typeOf x 84 | then unsafeCoerce (f2 (unsafeCoerce x)) 85 | else x 86 | 87 | 88 | f :: T1 -> T1 89 | f f' x = inc (gmapT f' x) 90 | 91 | {- 92 | fix (abs . rep . f) = fix f 93 | <=> 94 | abs (rep ( t1) x == t1 x 95 | <=> 96 | abs (t1 :: Int -> Int, t1 :: [Int] -> [Int]) x == t1 x 97 | <=> 98 | -} 99 | 100 | absrep :: T1 -> T1 101 | absrep t1 x = abs (rep t1) x 102 | 103 | absrepf :: T1 -> T1 104 | absrepf t1 x = abs (rep (f t1)) x 105 | 106 | repfabs :: T2 -> T2 107 | repfabs t2 = rep (f (abs t2)) 108 | 109 | main :: IO () 110 | main = print "hello" -------------------------------------------------------------------------------- /examples/dictionaries/Dictionaries.hss: -------------------------------------------------------------------------------- 1 | rhs-of 'repfabs 2 | any-call (unfold 'rep) 3 | lam-body 4 | arg 3 5 | any-call (unfold 'f) 6 | bash 7 | any-call (unfold 'gmapT) 8 | lam-body 9 | { app-arg 10 | bash-extended-with [ inline [ '$dData, '"$fData[]", '$fDataInt ] ] 11 | one-td (inline '$cgmapT) 12 | bash 13 | any-call (unfold 'abs) 14 | bash 15 | any-call (unfold 'typeOf) 16 | bash-extended-with [ inline [ '"$fData[]", '$ctypeOf ] ] 17 | any-call (inline 'eqTyRep) 18 | bash 19 | any-call (inline 'typeOf) 20 | bash 21 | one-td (unfold 'eqTyRep) 22 | bash 23 | } 24 | { consider case ; case-alt 1 ; alt-rhs 25 | case-split-inline 't2 26 | { case-alt 0 ; alpha-alt ['f1 , 'f2 ] } 27 | bash 28 | } 29 | -------------------------------------------------------------------------------- /examples/evaluation/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Prelude hiding (abs) 5 | 6 | data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr 7 | 8 | type Mint = Maybe Int 9 | 10 | eval :: Expr -> Mint 11 | eval (Val n) = Just n 12 | eval Throw = Nothing 13 | eval (Catch x y) = case eval x of 14 | Nothing -> eval y 15 | Just n -> Just n 16 | eval (Add x y) = case eval x of 17 | Nothing -> Nothing 18 | Just m -> case eval y of 19 | Nothing -> Nothing 20 | Just n -> Just (m + n) 21 | 22 | abs :: ((Int -> Mint) -> Mint -> Mint) -> Mint 23 | abs h = h Just Nothing 24 | 25 | rep :: Mint -> (Int -> Mint) -> Mint -> Mint 26 | rep mn s f = case mn of 27 | Nothing -> f 28 | Just n -> s n 29 | 30 | main :: IO () 31 | main = print (eval $ Val 5) 32 | -------------------------------------------------------------------------------- /examples/evaluation/Eval.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | flatten-module 3 | binding-of 'eval 4 | ww-result-split [| abs |] [| rep |] (ww-result-AssA-to-AssC WWA) 5 | { def-rhs 6 | let-subst 7 | { let-body 8 | alpha-lam 'e 9 | lam-body 10 | unfold 'abs 11 | } 12 | { rhs-of 'work 13 | alpha-lam 'e ; lam-body 14 | unfold 'rep 15 | bash 16 | [lam-body, lam-body] 17 | { consider case ; [ case-alt 1, alt-rhs ] ; abstract 'm 18 | consider case ; [ case-alt 1, alt-rhs ] ; abstract 'n 19 | } 20 | any-bu (fold 'rep) 21 | any-td (forward ww-result-fusion) 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /examples/evaluation/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper (Result Variant) Assumption A: abs (rep a) <=> a 2 | 3 | -- abs (rep a) 4 | { unfold 'abs } 5 | -- rep a Just Nothing 6 | { unfold 'rep } 7 | -- case a of 8 | -- Nothing -> Nothing 9 | -- Just n -> Just n 10 | { case-elim-merge-alts } 11 | -- a 12 | -------------------------------------------------------------------------------- /examples/factorial/Fac.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module Main where 5 | 6 | import Prelude hiding ((*),(-)) 7 | import GHC.Exts 8 | 9 | ------------------------------------ 10 | 11 | fac :: Int -> Int 12 | fac 0 = 1 13 | fac n = n * fac (n -1) 14 | 15 | unwrap :: (Int -> Int) -> Int# -> Int# 16 | unwrap h x = case h (I# x) of 17 | I# y -> y 18 | 19 | wrap :: (Int# -> Int#) -> Int -> Int 20 | wrap h (I# x) = I# (h x) 21 | 22 | main :: IO () 23 | main = print (fac 10) 24 | 25 | 26 | (*) :: Int -> Int -> Int 27 | (I# x) * (I# y) = I# (x *# y) 28 | 29 | (-) :: Int -> Int -> Int 30 | (I# x) - (I# y) = I# (x -# y) 31 | 32 | ------------------------------------ 33 | -------------------------------------------------------------------------------- /examples/factorial/Fac.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | flatten-module 3 | binding-of 'fac 4 | ww-split [| wrap |] [| unwrap |] (ww-AssA-to-AssC WWA) 5 | bash-extended-with [ case-elim-inline-scrutinee , inline [ 'unwrap, 'wrap, '*, '- ] ] 6 | 7 | { [def-rhs, let-body] ; alpha-lam 'n } -- cosmetic 8 | -------------------------------------------------------------------------------- /examples/factorial/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper Assumption A: wrap (unwrap h) <=> h 2 | 3 | bash-extended-with [ inline ['wrap,'unwrap] ] 4 | any-bu (case-elim-merge-alts) 5 | eta-reduce 6 | -------------------------------------------------------------------------------- /examples/fib-stream/.gitignore: -------------------------------------------------------------------------------- 1 | Fib 2 | -------------------------------------------------------------------------------- /examples/fib-stream/Fib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Prelude hiding ((+),map,(!!)) 5 | import Nat 6 | import Stream 7 | 8 | fib :: Nat -> Nat 9 | fib Zero = Zero 10 | fib (Succ Zero) = Succ Zero 11 | fib (Succ (Succ n)) = fib (Succ n) + fib n 12 | 13 | wrap :: Stream a -> (Nat -> a) 14 | wrap s n = s !! n 15 | 16 | unwrap :: (Nat -> a) -> Stream a 17 | unwrap f = map f nats 18 | 19 | main :: IO () 20 | main = print (fromNat $ fib $ toNat 30) 21 | -------------------------------------------------------------------------------- /examples/fib-stream/Fib.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | binding-of 'fib 3 | { 4 | ww-split-unsafe [| wrap Nat |] [| unwrap Nat |] 5 | {rhs-of 'work 6 | unfold 'unwrap 7 | any-call (unfold 'f) 8 | { consider lam ; alpha-lam 'm } 9 | } 10 | simplify 11 | any-call (unfold 'wrap) 12 | } -------------------------------------------------------------------------------- /examples/fib-stream/Nat.hs: -------------------------------------------------------------------------------- 1 | module Nat where 2 | 3 | import Prelude hiding ((+)) 4 | 5 | data Nat = Zero | Succ Nat deriving (Eq,Show) 6 | 7 | (+) :: Nat -> Nat -> Nat 8 | Zero + n = n 9 | (Succ m) + n = Succ (m + n) 10 | 11 | toNat :: Integer -> Nat 12 | toNat 0 = Zero 13 | toNat n = Succ (toNat (pred n)) 14 | 15 | fromNat :: Nat -> Integer 16 | fromNat Zero = 0 17 | fromNat (Succ n) = succ (fromNat n) -------------------------------------------------------------------------------- /examples/fib-stream/Stream.hs: -------------------------------------------------------------------------------- 1 | module Stream where 2 | 3 | import Prelude hiding (map,(!!)) 4 | import Nat 5 | 6 | data Stream a = Cons a (Stream a) 7 | 8 | map :: (a -> b) -> Stream a -> Stream b 9 | map f (Cons a s) = Cons (f a) (map f s) 10 | 11 | (!!) :: Stream a -> Nat -> a 12 | (Cons a _) !! Zero = a 13 | (Cons _ s) !! (Succ n) = s !! n 14 | 15 | nats :: Stream Nat 16 | nats = Zero `Cons` map Succ nats 17 | -------------------------------------------------------------------------------- /examples/fib-tuple/Fib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Prelude hiding ((+)) 5 | 6 | data Nat = Z | S Nat 7 | 8 | (+) :: Nat -> Nat -> Nat 9 | Z + n = n 10 | (S n') + n = S (n' + n) 11 | 12 | fromInt :: Int -> Nat 13 | fromInt 0 = Z 14 | fromInt i | i < 0 = error "fromInt negative" 15 | | otherwise = S (fromInt (i-1)) 16 | 17 | toInt :: Nat -> Int 18 | toInt Z = 0 19 | toInt (S n) = succ (toInt n) 20 | 21 | -- original fib definition 22 | fib :: Nat -> Nat 23 | fib Z = Z 24 | fib (S Z) = S Z 25 | fib (S (S n)) = fib (S n) + fib n 26 | 27 | -- goal: 28 | -- fib' = fst work 29 | -- where work Z = (Z, S Z) 30 | -- work (S n) = let (x,y) = work n 31 | -- in (y,x+y) 32 | 33 | wrap :: (Nat -> (Nat, Nat)) -> Nat -> Nat 34 | wrap h n = fst (h n) 35 | 36 | unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat) 37 | unwrap h n = (h n, h (S n)) 38 | 39 | main :: IO () 40 | main = print $ toInt $ fib (fromInt 30) 41 | -------------------------------------------------------------------------------- /examples/fib-tuple/Fib.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | flatten-module 3 | 4 | binding-of 'fib 5 | 6 | { 7 | 8 | ww-split [| wrap |] [| unwrap |] (ww-AssA-to-AssC WWA) 9 | binding-of 'work ; remember origwork 10 | 11 | -- work = unwrap (f (wrap work)) 12 | 13 | def-rhs ; eta-expand 'n 14 | 15 | -- work n = unwrap (f (wrap work)) n 16 | 17 | any-call (unfold 'unwrap) 18 | 19 | -- work n = (f (wrap work) n, f (wrap work) (n+1)) 20 | 21 | lam-body ; case-split-inline 'n 22 | 23 | -- work 0 = (f (wrap work) 0, f (wrap work) 1) 24 | -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2)) 25 | 26 | { case-alt 0 ; any-call (unfold 'f) } 27 | { [ case-alt 1, alt-rhs, app-arg] ; any-call (unfold 'f) } 28 | simplify 29 | 30 | -- work 0 = (0, 1) 31 | -- work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) 32 | 33 | [ case-alt 1, alt-rhs ] 34 | { app-arg ; any-call (unfold-remembered origwork) } 35 | 36 | -- work 0 = (0, 1) 37 | -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) 38 | 39 | any-bu (forward (ww-assumption-A [| wrap |] [| unwrap |] WWA )) 40 | 41 | -- work 0 = (0, 1) 42 | -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n) 43 | 44 | { arg 3 ; arg 1 ; let-intro 'x } 45 | { arg 2 ; let-intro 'y } 46 | innermost let-float 47 | try (reorder-lets ['x,'y]) 48 | one-td (fold 'y) 49 | let-tuple 'xy 50 | 51 | -- work 0 = (0, 1) 52 | -- work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y) 53 | 54 | one-td (fold 'unwrap) 55 | 56 | -- work 0 = (0, 1) 57 | -- work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y) 58 | 59 | one-td (fold-remembered origwork) 60 | 61 | -- work 0 = (0, 1) 62 | -- work (n+1) = let (x,y) = work n in (y,x+y) 63 | 64 | } 65 | 66 | { def-rhs ; let-elim } 67 | 68 | any-call (unfold 'wrap) 69 | -------------------------------------------------------------------------------- /examples/fib-tuple/Makefile: -------------------------------------------------------------------------------- 1 | HERMIT = perl ../../scripts/hermit.pl 2 | 3 | fib: 4 | - $(HERMIT) Fib.hs Fib.hss resume 5 | 6 | interactive: 7 | - $(HERMIT) Fib.hs Fib.hss 8 | 9 | start: 10 | - $(HERMIT) Fib.hs 11 | 12 | test: 13 | - rm *.o *.hi Fib 14 | - ghc --make -O2 -o Fib -fforce-recomp Fib.hs 15 | - ./Fib > timing.txt 16 | - echo "===========================================" >> timing.txt 17 | - $(HERMIT) Fib.hs Fib.hss resume 18 | - ./Fib >> timing.txt 19 | - cat timing.txt 20 | -------------------------------------------------------------------------------- /examples/fib-tuple/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper Assumption A: wrap (unwrap h) <=> h 2 | 3 | -- wrap (unwrap h) 4 | { eta-expand 'n } 5 | -- \ n -> wrap (unwrap h) n 6 | { any-call (unfold 'wrap) } 7 | -- \ n -> fst (unwrap h n) 8 | { any-call (unfold 'unwrap) } 9 | -- \ n -> fst (h n, h (S n)) 10 | { bash } 11 | -- h 12 | -------------------------------------------------------------------------------- /examples/fix-fusion/.gitignore: -------------------------------------------------------------------------------- 1 | Fusion 2 | -------------------------------------------------------------------------------- /examples/fix-fusion/FStrict.hss: -------------------------------------------------------------------------------- 1 | unfold 'f 2 | undefined-case 3 | -------------------------------------------------------------------------------- /examples/fix-fusion/Fusion.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Function (fix) 4 | import GHC.Err (undefined) 5 | 6 | data A = A 7 | data B = B 8 | 9 | f :: A -> B 10 | f A = B 11 | 12 | g :: A -> A 13 | g A = A 14 | 15 | h :: B -> B 16 | h B = B 17 | 18 | prog :: B 19 | prog = f (fix g) 20 | 21 | main :: IO () 22 | main = return () 23 | -------------------------------------------------------------------------------- /examples/fix-fusion/Fusion.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "FStrict" "FStrict.hss" 2 | load-as-rewrite "PreconditionL" "PreconditionL.hss" 3 | load-as-rewrite "PreconditionR" "PreconditionR.hss" 4 | 5 | binding-of 'prog 6 | { rhs-of 'prog 7 | fix-fusion-rule [| f |] [| g |] [| h |] PreconditionL PreconditionR FStrict 8 | } 9 | -------------------------------------------------------------------------------- /examples/fix-fusion/PreconditionL.hss: -------------------------------------------------------------------------------- 1 | unfold 'f 2 | case-elim 3 | -------------------------------------------------------------------------------- /examples/fix-fusion/PreconditionR.hss: -------------------------------------------------------------------------------- 1 | unfold 'h 2 | case-elim 3 | -------------------------------------------------------------------------------- /examples/flatten/Flatten.hec: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | define-rewrite "WWC" "ww-result-AssA-to-AssC WWA" 3 | load-as-rewrite "StrictRepH" "StrictRepH.hss" 4 | 5 | -- module main:Main where 6 | -- flatten :: forall a . Tree a -> [a] 7 | -- $dShow :: Show [Char] 8 | -- main :: IO () 9 | -- main :: IO () 10 | 11 | binding-of 'flatten 12 | 13 | -- flatten = \ * ds -> 14 | -- case ds of wild * 15 | -- Node l r -> (++) * (flatten * l) (flatten * r) 16 | -- Leaf a -> (:) * a ([] *) 17 | 18 | ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC 19 | 20 | -- flatten = \ * ds -> 21 | -- (let f = \ flatten' ds -> 22 | -- case ds of wild * 23 | -- Node l r -> (++) * (flatten' l) (flatten' r) 24 | -- Leaf a -> (:) * a ([] *) 25 | -- rec work = \ x1 -> repH * (f (\ x2 -> absH * (work x2)) x1) 26 | -- in \ x0 -> absH * (work x0)) ds 27 | 28 | bash 29 | { 30 | 31 | -- flatten = \ * -> 32 | -- let rec work = \ x1 -> 33 | -- repH * 34 | -- (case x1 of wild * 35 | -- Node l r -> (++) * (absH * (work l)) (absH * (work r)) 36 | -- Leaf a -> (:) * a ([] *)) 37 | -- in \ x0 -> absH * (work x0) 38 | 39 | rhs-of 'work 40 | 41 | -- \ x1 -> 42 | -- repH * 43 | -- (case x1 of wild * 44 | -- Node l r -> (++) * (absH * (work l)) (absH * (work r)) 45 | -- Leaf a -> (:) * a ([] *)) 46 | 47 | alpha-lam 'tree 48 | 49 | -- \ tree -> 50 | -- repH * 51 | -- (case tree of wild * 52 | -- Node l r -> (++) * (absH * (work l)) (absH * (work r)) 53 | -- Leaf a -> (:) * a ([] *)) 54 | 55 | lam-body 56 | 57 | -- repH * 58 | -- (case tree of wild * 59 | -- Node l r -> (++) * (absH * (work l)) (absH * (work r)) 60 | -- Leaf a -> (:) * a ([] *)) 61 | 62 | eta-expand 'acc 63 | 64 | -- \ acc -> 65 | -- repH * 66 | -- (case tree of wild * 67 | -- Node l r -> (++) * (absH * (work l)) (absH * (work r)) 68 | -- Leaf a -> (:) * a ([] *)) 69 | -- acc 70 | 71 | lam-body 72 | 73 | -- repH * 74 | -- (case tree of wild * 75 | -- Node l r -> (++) * (absH * (work l)) (absH * (work r)) 76 | -- Leaf a -> (:) * a ([] *)) 77 | -- acc 78 | 79 | bash-extended-with [push 'repH StrictRepH,forward ww-result-fusion,unfold-rules-unsafe ["repH ++","repH (:)","repH []"]] 80 | 81 | -- case tree of wild * 82 | -- Node l r -> work l (work r acc) 83 | -- Leaf a -> (:) * a acc 84 | 85 | } 86 | 87 | -- flatten = \ * -> 88 | -- let rec work = \ tree acc -> 89 | -- case tree of wild * 90 | -- Node l r -> work l (work r acc) 91 | -- Leaf a -> (:) * a acc 92 | -- in \ x0 -> absH * (work x0) 93 | 94 | one-td (unfold 'absH) 95 | 96 | -- flatten = \ * -> 97 | -- let rec work = \ tree acc -> 98 | -- case tree of wild * 99 | -- Node l r -> work l (work r acc) 100 | -- Leaf a -> (:) * a acc 101 | -- in \ x0 -> work x0 ([] *) 102 | 103 | -------------------------------------------------------------------------------- /examples/flatten/Flatten.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import HList 5 | 6 | data Tree a = Node (Tree a) (Tree a) | Leaf a 7 | 8 | flatten :: Tree a -> [a] 9 | flatten (Leaf a) = [a] 10 | flatten (Node l r) = flatten l ++ flatten r 11 | 12 | main :: IO () 13 | main = print (flatten (Node (Leaf 'h') (Leaf 'i'))) 14 | 15 | 16 | -- Should be in a "List" module 17 | {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 18 | {-# RULES "++ strict" (++) undefined = undefined #-} 19 | 20 | -- The "Algebra" for repH 21 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 22 | {-# RULES "repH []" repH [] = id #-} 23 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 24 | 25 | -------------------------------------------------------------------------------- /examples/flatten/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | ) where 6 | 7 | type H a = [a] -> [a] 8 | 9 | {-# INLINE repH #-} 10 | repH :: [a] -> H a 11 | repH xs = (xs ++) 12 | 13 | {-# INLINE absH #-} 14 | absH :: H a -> [a] 15 | absH f = f [] 16 | 17 | -- -- Should be in a "List" module 18 | -- {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 19 | -- {-# RULES "++ strict" (++) undefined = undefined #-} 20 | 21 | -- -- The "Algebra" for repH 22 | -- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 23 | -- {-# RULES "repH []" repH [] = id #-} 24 | -- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 25 | -------------------------------------------------------------------------------- /examples/flatten/StrictRepH.hss: -------------------------------------------------------------------------------- 1 | -- Proof that "repH" is strict 2 | 3 | 4 | -- repH ty (undefined [ty]) 5 | { unfold 'repH } 6 | -- (++) ty (undefined [ty]) 7 | { unfold-rule-unsafe "++ strict" } 8 | -- undefined ([ty] -> [ty]) 9 | -------------------------------------------------------------------------------- /examples/flatten/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper (Result Variant) Assumption A: absH (repH x) <=> x 2 | 3 | -- absH (repH x) 4 | { unfold 'absH } 5 | -- repH x [] 6 | { unfold 'repH } 7 | -- x ++ [] 8 | { unfold-rule-unsafe "++ []" } 9 | -- x 10 | -------------------------------------------------------------------------------- /examples/hanoi/Hanoi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | -- import Criterion.Main 5 | 6 | import Control.Monad (forM_) 7 | 8 | data Nat = Z | S Nat 9 | 10 | toInt :: Nat -> Int 11 | toInt Z = 0 12 | toInt (S m) = 1 + toInt m 13 | 14 | fromInt :: Int -> Nat 15 | fromInt 0 = Z 16 | fromInt i = S (fromInt (i-1)) 17 | 18 | instance Show Nat where 19 | show = show . toInt 20 | 21 | main :: IO () 22 | main = do 23 | forM_ [0..20] $ \i -> do 24 | let h = hanoi (fromInt i) A B C 25 | h' = hanoi' (fromInt i) A B C 26 | h'' = wrap (unwrap hanoi) (fromInt i) A B C 27 | if h == h' 28 | then do putStrLn $ show i ++ " good." 29 | if h == h'' 30 | then do putStrLn $ show i ++ " wrap/unwrap good." 31 | else do print h 32 | print h'' 33 | else do print h 34 | print h' 35 | 36 | -- defaultMain 37 | -- [ bench "4" $ whnf hanoi 4 38 | -- ] 39 | 40 | {-# RULES "++ []" forall l. l ++ [] = l #-} 41 | {-# RULES "[] ++" forall l. [] ++ l = l #-} 42 | 43 | data Peg = A | B | C deriving (Show, Eq) 44 | type Moves = [(Peg,Peg)] 45 | 46 | -- this is a candidate for tupling 47 | hanoi :: Nat -> Peg -> Peg -> Peg -> Moves 48 | hanoi Z _ _ _ = [] 49 | hanoi (S n) d b c = hanoi n d c b ++ [(d,b)] ++ hanoi n c b d 50 | 51 | -- this is the goal 52 | hanoi' Z _ _ _ = [] 53 | hanoi' (S Z) d b _ = [(d,b)] 54 | hanoi' (S (S n)) d b c = u ++ [(d,c)] ++ v ++ [(d,b)] ++ w ++ [(c,b)] ++ u 55 | where (u,v,w) = worker n d b c 56 | 57 | worker :: Nat -> Peg -> Peg -> Peg -> (Moves, Moves, Moves) 58 | worker Z _ _ _ = ([],[],[]) 59 | worker (S Z) d b c = ([(d,b)], [(b,c)], [(c,d)]) 60 | worker (S (S n)) d b c = 61 | let (u,v,w) = worker n d b c 62 | in (u ++ [(d,c)] ++ v ++ [(d,b)] ++ w ++ [(c,b)] ++ u 63 | ,v ++ [(b,d)] ++ w ++ [(b,c)] ++ u ++ [(d,c)] ++ v 64 | ,w ++ [(c,b)] ++ u ++ [(c,d)] ++ v ++ [(b,d)] ++ w) 65 | 66 | unwrap :: (Nat -> Peg -> Peg -> Peg -> Moves) 67 | -> (Nat -> Peg -> Peg -> Peg -> (Moves, Moves, Moves)) 68 | unwrap f n d b c = (f n d b c, f n b c d, f n c d b) 69 | 70 | wrap :: (Nat -> Peg -> Peg -> Peg -> (Moves, Moves, Moves)) 71 | -> (Nat -> Peg -> Peg -> Peg -> Moves) 72 | wrap _ Z _ _ _ = [] 73 | wrap _ (S Z) d b _ = [(d,b)] 74 | wrap f (S (S n)) d b c = let (u,v,w) = f n d b c 75 | in u ++ [(d,c)] ++ v ++ [(d,b)] ++ w ++ [(c,b)] ++ u 76 | -------------------------------------------------------------------------------- /examples/hanoi/Hanoi.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | 3 | -- do the w/w split 4 | binding-of 'hanoi 5 | { ww-split-unsafe [| wrap |] [| unwrap |] } 6 | 7 | { binding-of 'work 8 | remember origwork 9 | 10 | any-call (unfold 'unwrap) 11 | 12 | -- establish the zero base case 13 | [ def-rhs, lam-body, lam-body, lam-body, lam-body] 14 | case-split-inline 'n 15 | { case-alt 0 ; any-call (unfold 'f) ; simplify } 16 | 17 | -- establish the one base case 18 | { [case-alt 1, alt-rhs] ; case-split-inline 'a 19 | { case-alt 0 ; any-call (unfold 'f) ; simplify 20 | any-call (unfold-remembered origwork) 21 | any-call (forward (ww-assumption-A-unsafe [| wrap |] [| unwrap |])) 22 | any-call (unfold 'f) 23 | simplify 24 | any-call (unfold-rule "[] ++") 25 | -- any-call (unfold-rule "++ []") 26 | assume 27 | } 28 | { case-alt 1 ; any-call (unfold 'f) ; simplify 29 | 30 | any-call (unfold-remembered origwork) 31 | any-call (forward (ww-assumption-A-unsafe [| wrap |] [| unwrap |])) 32 | any-call (unfold 'f) 33 | innermost let-subst ; simplify 34 | 35 | -- recursion decrements by two, so must do this again 36 | any-call (unfold-remembered origwork) 37 | any-call (forward (ww-assumption-A-unsafe [| wrap |] [| unwrap |])) 38 | 39 | -- time to let intro 40 | -- need a "occurance 'work" like consider 41 | { alt-rhs 42 | { arg 5 43 | { arg 1 44 | { arg 1 ; let-intro 'u } 45 | { arg 2 ; arg 2 ; let-intro 'v } 46 | } 47 | { arg 2 ; arg 2 ; arg 1 ; let-intro 'w } 48 | } 49 | innermost let-float 50 | try (reorder-lets ['u,'v,'w]) 51 | any-call (fold 'u) 52 | any-call (fold 'v) 53 | -- any-call (fold 'w) 54 | let-tuple 'uvw 55 | any-call (fold 'unwrap) 56 | any-call (fold-remembered origwork) 57 | } 58 | } 59 | } 60 | } 61 | --innermost let-elim 62 | innermost let-subst 63 | -------------------------------------------------------------------------------- /examples/hanoi/Makefile: -------------------------------------------------------------------------------- 1 | hanoi: 2 | - hermit Hanoi.hs Hanoi.hss resume 3 | 4 | interactive: 5 | - hermit Hanoi.hs Hanoi.hss 6 | 7 | test: 8 | - rm Hanoi *.o *.hi 9 | - ghc --make Hanoi.hs -O2 -o Hanoi 10 | - ./Hanoi 11 | - rm Hanoi *.o *.hi 12 | - hermit Hanoi.hs Hanoi.hss resume 13 | - ./Hanoi 14 | -------------------------------------------------------------------------------- /examples/induction/.gitignore: -------------------------------------------------------------------------------- 1 | Induction 2 | -------------------------------------------------------------------------------- /examples/induction/BaseCase.her: -------------------------------------------------------------------------------- 1 | -- Base Case 2 | -- 3 | -- [] ++ [] => [] 4 | 5 | one-bu (unfold '++) 6 | smash 7 | -------------------------------------------------------------------------------- /examples/induction/Induction.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding ((++)) 4 | 5 | {-# RULES "++ []" forall xs. xs ++ [] = xs #-} 6 | 7 | (++) :: [a] -> [a] -> [a] 8 | [] ++ bs = bs 9 | (a:as) ++ bs = a : (as ++ bs) 10 | 11 | main :: IO () 12 | main = print (replicate 5 True ++ []) 13 | -------------------------------------------------------------------------------- /examples/induction/InductiveStep.her: -------------------------------------------------------------------------------- 1 | -- Inductive Step 2 | -- 3 | -- (y:ys) ++ [] => y:ys 4 | -- 5 | 6 | unfold '++ 7 | smash 8 | app-arg 9 | --ind-hyp-0 10 | -------------------------------------------------------------------------------- /examples/induction/Verify.hec: -------------------------------------------------------------------------------- 1 | --load "BaseCase" "BaseCase.her" 2 | --load "InductiveStep" "InductiveStep.her" 3 | load-as-rewrite "BaseCase" "BaseCase.her" 4 | load-as-rewrite "InductiveStep" "InductiveStep.her" 5 | 6 | { prog-end 7 | rule-to-lemma "++ []" 8 | -- verify-lemma "++ []" (inductive-proof 'xs [ '"[]" , ': ] [ BaseCase , InductiveStep ]) 9 | prove-lemma "++ []" 10 | induction 'xs 11 | forall-body 12 | -- undefined case 13 | { conj-lhs 14 | BaseCase 15 | } 16 | 17 | -- nil case 18 | { [conj-rhs, conj-lhs] 19 | BaseCase 20 | } 21 | 22 | -- cons case 23 | { [conj-rhs, conj-rhs, forall-body, consequent] 24 | { eq-lhs 25 | InductiveStep 26 | { [app-arg] 27 | lemma-forward ind-hyp-0 28 | } 29 | } 30 | reflexivity 31 | } 32 | end-proof 33 | } 34 | 35 | -------------------------------------------------------------------------------- /examples/last/Last.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Prelude hiding (last) 5 | 6 | ------------------------------------------------- 7 | 8 | unwrap :: ([a] -> a) -> a -> [a] -> a 9 | unwrap f a as = f (a:as) 10 | 11 | wrap :: (a -> [a] -> a) -> [a] -> a 12 | wrap f [] = undefined 13 | wrap f (a:as) = f a as 14 | 15 | last :: [a] -> a 16 | last [] = undefined 17 | last [a] = a 18 | last (_:a:as) = last (a:as) 19 | 20 | main :: IO () 21 | main = print (last "hello") 22 | 23 | ------------------------------------------------- 24 | -------------------------------------------------------------------------------- /examples/last/Last.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWB" "WW-Ass-B.hss" 2 | define-rewrite "WWC" "ww-AssB-to-AssC WWB" 3 | flatten-module 4 | binding-of 'last 5 | ww-split-static-arg 1 [0] [| wrap |] [| unwrap |] WWC 6 | bash-extended-with [ inline [ 'f, 'wrap, 'unwrap ] ] 7 | unshadow 8 | -------------------------------------------------------------------------------- /examples/last/NewLast.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | set-pp-type Show 3 | 4 | binding-of 'last 5 | fix-intro 6 | { application-of 'fix 7 | split-1-beta last [| wrap |] [| unwrap |] 8 | -- prove the assumption 9 | lhs (repeat (any-call (unfold ['., 'wrap, 'unwrap]))) 10 | both smash 11 | end-proof 12 | 13 | repeat (any-call (unfold ['g, 'wrap, 'unwrap, 'fix])) 14 | bash 15 | } 16 | -------------------------------------------------------------------------------- /examples/last/WW-Ass-B.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper Assumption B: wrap (unwrap (f h)) <=> f h 2 | 3 | -- wrap (unwrap (f h)) 4 | { eta-expand 'xs } 5 | -- \ xs -> wrap (unwrap (f h)) xs 6 | { lam-body 7 | -- wrap (unwrap (f h)) xs 8 | { unfold 'wrap } 9 | -- case xs of 10 | -- [] -> undefined 11 | -- a:as -> unwrap (f h) a as 12 | { case-alt 1 ; alt-rhs 13 | -- unwrap (f h) a as 14 | { unfold 'unwrap } 15 | -- f h (a:as) 16 | { unfold 'f ; bash } 17 | -- case as of 18 | -- [] -> a 19 | -- a:as -> h (a:as) 20 | } 21 | -- case xs of 22 | -- [] -> undefined 23 | -- a:as -> case as of 24 | -- [] -> a 25 | -- a:as -> h (a:as) 26 | { fold 'f } 27 | -- f h xs 28 | } 29 | -- \ xs -> f h xs 30 | { eta-reduce } 31 | -- f h 32 | -------------------------------------------------------------------------------- /examples/laws/All.hec: -------------------------------------------------------------------------------- 1 | load-and-run "Start.hec" 2 | load-and-run "List.hec" 3 | load-and-run "Maybe.hec" 4 | -------------------------------------------------------------------------------- /examples/laws/Identity.hec: -------------------------------------------------------------------------------- 1 | -- set-pp-type Show 2 | 3 | rule-to-lemma fmap-id 4 | inst-lemma fmap-id 'f [| Identity |] 5 | inst-lemma-dictionaries fmap-id 6 | prove-lemma fmap-id 7 | lhs unfold 8 | both smash 9 | lhs unfold 10 | -------------------------------------------------------------------------------- /examples/laws/Laws.hs: -------------------------------------------------------------------------------- 1 | module Laws where 2 | 3 | import Control.Applicative (pure, (<*>), Applicative) 4 | import Control.Monad (liftM) 5 | import Data.Map 6 | import Data.Monoid ((<>), mempty, Monoid(..)) 7 | 8 | main :: IO () 9 | main = return () 10 | 11 | -- Since we can't unfold (++) 12 | {-# RULES "append-fix" [~] (++) = myAppend #-} 13 | myAppend :: [a] -> [a] -> [a] 14 | myAppend [] ys = ys 15 | myAppend (x:xs) ys = x : myAppend xs ys 16 | 17 | -- Since we can't unfold map 18 | {-# RULES "map-fix" [~] Prelude.map = myMap #-} 19 | myMap :: (a -> b) -> [a] -> [b] 20 | myMap _ [] = [] 21 | myMap f (x:xs) = f x : myMap f xs 22 | 23 | -- useful auxilliary lemmas 24 | {-# RULES "append-right" [~] forall x. x ++ [] = x #-} 25 | {-# RULES "pure-singleton" [~] forall x. pure x = [x] #-} 26 | {-# RULES "append-single-left" [~] forall x xs. [x] ++ xs = x:xs #-} 27 | {-# RULES "bind-left-nil" [~] forall k. [] >>= k = [] #-} 28 | {-# RULES "bind-left-cons" [~] forall x xs k. (x:xs) >>= k = k x ++ (xs >>= k) #-} 29 | {-# RULES "bind-append" [~] forall m n k. (m >>= k) ++ (n >>= k) = (m ++ n) >>= k #-} 30 | {-# RULES "foldr-id" [~] Prelude.foldr (:) [] = id #-} 31 | {-# RULES "append-undefined" [~] forall xs. undefined ++ xs = undefined #-} 32 | {-# RULES "ap-nil" [~] forall f. [f] <*> [] = [] #-} 33 | {-# RULES "ap-cons" [~] forall f x xs. [f] <*> (x:xs) = f x : ([f] <*> xs) #-} 34 | {-# RULES "nil-ap" [~] forall xs. [] <*> xs = [] #-} 35 | {-# RULES "cons-ap" [~] forall f fs xs. (f:fs) <*> xs = ([f] <*> xs) ++ (fs <*> xs) #-} 36 | 37 | -- functor 38 | {-# RULES "fmap-id" [~] fmap id = id #-} 39 | {-# RULES "fmap-distrib" [~] forall g h. fmap (g.h) = fmap g . fmap h #-} 40 | 41 | -- applicative 42 | {-# RULES "identity" [~] forall v. pure id <*> v = v #-} 43 | {-# RULES "homomorphism" [~] forall f x. pure f <*> pure x = pure (f x) #-} 44 | {-# RULES "interchange" [~] forall u y. u <*> pure y = pure ($ y) <*> u #-} 45 | {-# RULES "composition" [~] forall u v w. u <*> (v <*> w) = pure (.) <*> u <*> v <*> w #-} 46 | -- note: switched lhs/rhs to get proper constraints (mention in paper) 47 | {-# RULES "fmap-pure" [~] forall g x. pure g <*> x = fmap g x #-} 48 | 49 | -- monad 50 | {-# RULES "return-left" [~] forall k x. return x >>= k = k x #-} 51 | {-# RULES "return-right" [~] forall k. k >>= return = k #-} 52 | {-# RULES "bind-assoc" [~] forall j k l. (j >>= k) >>= l = j >>= (\x -> k x >>= l) #-} 53 | 54 | -- note: can only prove this once Applicative is superclass of Monad 55 | -- reason: need both a Monad and Functor constraint on f, but constraints only 56 | -- seem to be generated for left-hand side uses. (This is why fmap-pure and tcompose 57 | -- RULES need to be flipped.) If Applicative was a superclass of Monad, 58 | -- the Monad constraint generated by the following (flipped) ordering 59 | -- would result in the proper Functor constraint needed by the right-hand side 60 | -- because Functor is a superclass of Applicative. 61 | -- {-# RULES "fmap-liftm" [~] forall f x. liftM f x = fmap f x #-} 62 | 63 | -- this doesn't work because a,b,m don't appear on LHS of RULE. 64 | -- {-# RULES "fmap-liftm" [~] forall a b m (f :: a -> b) (x :: (Monad m, Functor m) => m a). liftM f x = fmap f x #-} 65 | 66 | -- additional note: maybe this behavior is a bug in typechecking RULES, 67 | -- surely constraints should be collected from both sides and unioned. 68 | 69 | -- monoid 70 | {-# RULES "mempty-left" [~] forall x. mempty <> x = x #-} 71 | {-# RULES "mempty-right" [~] forall x. x <> mempty = x #-} 72 | {-# RULES "mappend-assoc" [~] forall x y z. (x <> y) <> z = x <> (y <> z) #-} 73 | -------------------------------------------------------------------------------- /examples/laws/ListLaws.hs: -------------------------------------------------------------------------------- 1 | module ListLaws where 2 | 3 | import Prelude hiding (map,id, concat, (++)) 4 | 5 | {-# RULES "left-unit" forall x f. retur x `bind` f = f x #-} 6 | 7 | {-# RULES "right-unit" forall m. m `bind` retur = m #-} 8 | 9 | {-# RULES "monad-assoc" forall m f g. (m `bind` f) `bind` g = m `bind` \x -> (f x `bind` g) #-} 10 | {-# RULES "monoid-left" forall x. mempt `mappen` x = x #-} 11 | 12 | {-# RULES "monoid-right" forall x. x `mappen` mempt = x #-} 13 | 14 | {-# RULES "monoid-assoc" forall x y z. x `mappen` (y `mappen` z) = (x `mappen` y) `mappen` z #-} 15 | 16 | {-# RULES "nil-append" forall xs. [] ++ xs = xs #-} 17 | {-# RULES "append-nil" forall xs. xs ++ [] = xs #-} 18 | {-# RULES "append-nonempty" forall x1 xs ys. x1 : (xs ++ ys) = (x1:xs) ++ ys #-} 19 | {-# RULES "append-assoc" forall x y z. x ++ (y ++ z) = (x++y) ++ z #-} 20 | 21 | {-# RULES "concat-unit" forall x. concat [x] = x #-} 22 | {-# RULES "concat-of-toList" forall xs. concat (map toList xs) = xs #-} 23 | 24 | {-# RULES "map-nonempty" forall f a as. map f (a:as) = f a : map f as #-} 25 | 26 | -- I'm using a slightly different specification for this rule, 27 | -- so that I can case-split on 'xs 28 | -- {-# RULES "map-compose" forall f g xs. map (f . g) xs = (map f . map g) xs #-} 29 | {-# RULES "map-compose" forall f g xs. map (f . g) xs = map f (map g xs) #-} 30 | -- {-# RULES "map-compose" forall f g xs. map (\y -> f (g y)) xs = map f (map g xs) #-} 31 | {-# RULES "map-append" forall f x y. map f (x ++ y) = map f x ++ map f y #-} 32 | {-# RULES "map-concat" forall f xs. map f (concat xs) = concat (map (map f) xs) #-} 33 | {-# RULES "concat-concat" forall x. concat (concat x) = concat (map concat x) #-} 34 | {-# RULES "concat-append" forall x y. concat (x ++ y) = concat x ++ concat y #-} 35 | {-# RULES "concat-nonempty" forall x xs. concat (x:xs) = x ++ (concat xs) #-} 36 | {-# RULES #-} 37 | 38 | bind :: [a] -> (a -> [b]) -> [b] 39 | bind as k = concat (map k as) 40 | 41 | retur :: a -> [a] 42 | retur = toList 43 | 44 | toList :: a -> [a] 45 | toList x = [x] 46 | 47 | (++) :: [a] -> [a] -> [a] 48 | (++) [] ys = ys 49 | (++) (x:xs) ys = x : xs ++ ys 50 | 51 | map :: (a -> b) -> [a] -> [b] 52 | map _ [] = [] 53 | map f (a:as) = f a : map f as 54 | 55 | concat :: [[a]] -> [a] 56 | concat [] = [] 57 | concat (x:xs) = x ++ (concat xs) 58 | 59 | mempt :: [a] 60 | mempt = [] 61 | 62 | mappen :: [a] -> [a] -> [a] 63 | mappen xs ys = xs ++ ys 64 | -------------------------------------------------------------------------------- /examples/laws/Map-Functor.hec: -------------------------------------------------------------------------------- 1 | set-pp-type Show 2 | 3 | -- fmap-id 4 | rule-to-lemma fmap-id 5 | inst-lemma fmap-id 'f [| Map k |] 6 | inst-lemma-dictionaries fmap-id 7 | prove-lemma fmap-id 8 | extensionality 'm 9 | lhs (replicate 2 (one-td unfold)) 10 | both smash 11 | lhs (replicate 2 (one-td unfold) >>> smash) 12 | induction 'm 13 | lhs undefined-case ; end-case 14 | lhs simplify 15 | rhs (one-td (backward (lemma ind-hyp-0))) 16 | rhs (one-td (backward (lemma ind-hyp-1))) 17 | lhs (any-bu (unfold 'map)) 18 | both smash ; end-case 19 | lhs simplify ; end-case 20 | 21 | -- fmap-distrib 22 | rule-to-lemma fmap-distrib 23 | inst-lemma fmap-distrib 'f [| Map k |] 24 | inst-lemma-dictionaries fmap-distrib 25 | prove-lemma fmap-distrib 26 | extensionality 'm 27 | both smash 28 | lhs (unfold >>> smash >>> unfold) 29 | both (unfold >>> smash) 30 | rhs (replicate 3 (one-td unfold)) 31 | both smash 32 | rhs (replicate 2 (one-td unfold)) 33 | both smash 34 | induction 'm 35 | -- undefined 36 | both undefined-case ; end-case 37 | -- Bin 38 | lhs (any-bu (unfold 'map)) 39 | lhs smash 40 | lhs (one-td (forward (lemma ind-hyp-0))) 41 | lhs (one-td (forward (lemma ind-hyp-1))) 42 | rhs (any-bu (unfold 'map)) 43 | both smash ; end-case 44 | -- Tip 45 | both smash ; end-case 46 | -------------------------------------------------------------------------------- /examples/laws/Map-Monoid.hec: -------------------------------------------------------------------------------- 1 | set-pp-type Show 2 | 3 | -- mempty-left 4 | rule-to-lemma mempty-left 5 | copy-lemma mempty-left mempty-left-map 6 | inst-lemma mempty-left-map 'm [| Map k v |] 7 | inst-lemma-dictionaries mempty-left-map 8 | prove-lemma mempty-left-map 9 | lhs (repeat (smash <+ one-td unfold)) 10 | end-proof 11 | 12 | -- mempty-right 13 | rule-to-lemma mempty-right 14 | copy-lemma mempty-right mempty-right-map 15 | inst-lemma mempty-right-map 'm [| Map k v |] 16 | inst-lemma-dictionaries mempty-right-map 17 | prove-lemma mempty-right-map 18 | lhs (repeat (smash <+ one-td unfold)) 19 | end-proof 20 | 21 | -- mappend-assoc 22 | rule-to-lemma mappend-assoc 23 | copy-lemma mappend-assoc mappend-assoc-map 24 | inst-lemma mappend-assoc-map 'm [| Map k v |] 25 | inst-lemma-dictionaries mappend-assoc-map 26 | prove-lemma mappend-assoc-map 27 | -------------------------------------------------------------------------------- /examples/laws/Maybe.hec: -------------------------------------------------------------------------------- 1 | -- return left unit law 2 | copy-lemma return-left return-left-maybe 3 | inst-lemma return-left-maybe 'm [| Maybe |] 4 | inst-lemma-dictionaries return-left-maybe 5 | prove-lemma return-left-maybe 6 | lhs (repeat (one-td unfold <+ simplify)) 7 | end-proof 8 | 9 | -- return right unit law 10 | copy-lemma return-right return-right-maybe 11 | inst-lemma return-right-maybe 'm [| Maybe |] 12 | inst-lemma-dictionaries return-right-maybe 13 | prove-lemma return-right-maybe 14 | lhs (repeat (one-td unfold <+ smash)) 15 | end-proof 16 | 17 | -- bind associativity law 18 | copy-lemma bind-assoc bind-assoc-maybe 19 | inst-lemma bind-assoc-maybe 'm [| Maybe |] 20 | inst-lemma-dictionaries bind-assoc-maybe 21 | prove-lemma bind-assoc-maybe 22 | both (repeat (one-td unfold <+ smash)) 23 | end-proof 24 | 25 | -- mappend-assoc law 26 | -- copy-lemma mappend-assoc mappend-assoc-maybe 27 | -- inst-lemma mappend-assoc-maybe 'm [| Maybe |] -- problem, superclass 28 | 29 | copy-lemma fmap-id fmap-id-maybe 30 | inst-lemma fmap-id-maybe 'f [| Maybe |] 31 | inst-lemma-dictionaries fmap-id-maybe 32 | prove-lemma fmap-id-maybe 33 | lhs (repeat (one-td unfold <+ simplify)) 34 | extensionality 'x 35 | both smash 36 | end-proof 37 | 38 | -- mempty-left 39 | copy-lemma mempty-left mempty-left-maybe 40 | inst-lemma mempty-left-maybe 'm [| Maybe a |] 41 | inst-lemma-dictionaries mempty-left-maybe 42 | prove-lemma mempty-left-maybe 43 | lhs (repeat (smash <+ one-td unfold)) 44 | end-proof 45 | 46 | -- mempty-right 47 | copy-lemma mempty-right mempty-right-maybe 48 | inst-lemma mempty-right-maybe 'm [| Maybe a |] 49 | inst-lemma-dictionaries mempty-right-maybe 50 | prove-lemma mempty-right-maybe 51 | lhs (repeat (smash <+ one-td unfold)) 52 | end-proof 53 | 54 | -- we can't do, need implications 55 | -- mappend-assoc 56 | -- copy-lemma mappend-assoc mappend-assoc-maybe 57 | -- inst-lemma mappend-assoc-maybe 'm [| Maybe a |] 58 | -- inst-lemma-dictionaries mappend-assoc-maybe 59 | -- prove-lemma mappend-assoc-maybe 60 | -- stop-script 61 | 62 | -- fmap-distrib 63 | copy-lemma fmap-distrib fmap-distrib-maybe 64 | inst-lemma fmap-distrib-maybe 'f [| Maybe |] 65 | inst-lemma-dictionaries fmap-distrib-maybe 66 | prove-lemma fmap-distrib-maybe 67 | extensionality 'mb 68 | induction 'mb 69 | both (repeat (one-td unfold <+ smash)) ; end-case -- undefined 70 | both (repeat (one-td unfold <+ smash)) ; end-case -- Nothing 71 | both (repeat (one-td unfold <+ smash)) ; end-case -- Just 72 | 73 | -- identity 74 | copy-lemma identity identity-maybe 75 | inst-lemma identity-maybe 'f [| Maybe |] 76 | inst-lemma-dictionaries identity-maybe 77 | prove-lemma identity-maybe 78 | induction 'v 79 | both (repeat (one-td unfold <+ smash)) ; end-case -- undefined 80 | both (repeat (one-td unfold <+ smash)) ; end-case -- Nothing 81 | both (repeat (one-td unfold <+ smash)) ; end-case -- Just 82 | 83 | -- homomorphism 84 | copy-lemma homomorphism homomorphism-maybe 85 | inst-lemma homomorphism-maybe 'f [| Maybe |] 86 | inst-lemma-dictionaries homomorphism-maybe 87 | prove-lemma homomorphism-maybe 88 | both (repeat (one-td unfold <+ smash)) 89 | end-proof 90 | 91 | -- interchange 92 | copy-lemma interchange interchange-maybe 93 | inst-lemma interchange-maybe 'f [| Maybe |] 94 | inst-lemma-dictionaries interchange-maybe 95 | prove-lemma interchange-maybe 96 | both (repeat (one-td unfold <+ smash)) 97 | end-proof 98 | 99 | -- composition 100 | copy-lemma composition composition-maybe 101 | inst-lemma composition-maybe 'f [| Maybe |] 102 | inst-lemma-dictionaries composition-maybe 103 | prove-lemma composition-maybe 104 | both (repeat (one-td unfold <+ smash)) 105 | end-proof 106 | 107 | -- fmap-pure 108 | copy-lemma fmap-pure fmap-pure-maybe 109 | inst-lemma fmap-pure-maybe 'f [| Maybe |] 110 | inst-lemma-dictionaries fmap-pure-maybe 111 | prove-lemma fmap-pure-maybe 112 | both (repeat (one-td unfold <+ simplify)) -- something in smash caused a core lint error 113 | end-proof 114 | -------------------------------------------------------------------------------- /examples/laws/MaybeLaws.hs: -------------------------------------------------------------------------------- 1 | module MaybeLaws where 2 | 3 | {-# RULES "left-unit" forall x f. retur x `bind` f = f x #-} 4 | 5 | {-# RULES "right-unit" forall m. m `bind` retur = m #-} 6 | 7 | {-# RULES "monad-assoc" forall m f g. (m `bind` f) `bind` g = m `bind` \x -> (f x `bind` g) #-} 8 | 9 | bind :: Maybe a -> (a -> Maybe b) -> Maybe b 10 | bind Nothing k = Nothing 11 | bind (Just a) k = k a 12 | 13 | retur :: a -> Maybe a 14 | retur = Just 15 | -------------------------------------------------------------------------------- /examples/laws/MonadLaws.txt: -------------------------------------------------------------------------------- 1 | return x >>= f == f x 2 | 3 | m >>= return == m 4 | 5 | 6 | (m >>= f) >>= g == m >>= \x -> (f x >>= g) 7 | -------------------------------------------------------------------------------- /examples/laws/Start.hec: -------------------------------------------------------------------------------- 1 | set-pp-type Show 2 | 3 | -- functor 4 | rule-to-lemma fmap-id 5 | rule-to-lemma fmap-distrib 6 | 7 | -- applicative 8 | rule-to-lemma identity 9 | rule-to-lemma homomorphism 10 | rule-to-lemma interchange 11 | rule-to-lemma composition 12 | rule-to-lemma fmap-pure 13 | 14 | -- monad 15 | rule-to-lemma return-left 16 | rule-to-lemma return-right 17 | rule-to-lemma bind-assoc 18 | 19 | -- monoid 20 | rule-to-lemma mempty-left 21 | rule-to-lemma mempty-right 22 | rule-to-lemma mappend-assoc 23 | -------------------------------------------------------------------------------- /examples/laws/iverify-map-append.hec: -------------------------------------------------------------------------------- 1 | rule-to-lemma map-append 2 | set-pp-type Show 3 | prove-lemma map-append 4 | induction x 5 | -- undefined case 6 | both unfold 7 | both (one-td unfold) 8 | both smash 9 | both undefined-expr 10 | -- nil case 11 | both unfold 12 | both (one-td unfold) 13 | both smash 14 | rhs unfold 15 | -- inductive case 16 | both unfold 17 | both (one-td unfold) 18 | both smash 19 | lhs (one-td (forward (lemma ind-hyp-0))) 20 | -- done 21 | show-lemmas 22 | -------------------------------------------------------------------------------- /examples/laws/list-monad-assoc-lhs.her: -------------------------------------------------------------------------------- 1 | any-call (unfold 'bind) 2 | any-call (unfold 'bind) 3 | any-bu (forward (lemma map-concat)) 4 | any-bu (forward (lemma concat-concat)) 5 | -------------------------------------------------------------------------------- /examples/laws/list-monad-assoc-rhs.her: -------------------------------------------------------------------------------- 1 | any-call (unfold 'bind) 2 | { 3 | consider lam 4 | lams-body 5 | { 6 | app-arg 7 | abstract x 8 | } 9 | fold '. 10 | } 11 | { 12 | consider lam 13 | eta-reduce 14 | } 15 | one-bu (forward (lemma map-compose)) 16 | { 17 | consider lam 18 | { 19 | lams-body 20 | fold '. 21 | } 22 | eta-reduce 23 | } 24 | one-bu (forward (lemma map-compose)) 25 | -------------------------------------------------------------------------------- /examples/laws/verify-append-assoc.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify append-assoc 3 | -- 4 | -- forall x y z. x ++ (y ++ z) = (x ++ y) ++ z 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-append-assoc.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "append-assoc" 14 | 15 | load-and-run "verify-nil-append.hec" 16 | 17 | -- first do the proof interactively 18 | -- 19 | 20 | -- Begin with the lhs 21 | -- {rule-lhs-intro "append-assoc" 22 | -- consider lam ; lams-body 23 | 24 | -- case-split-inline 'x 25 | -- {case-alt 0 26 | -- any-bu (forward (lemma "nil-append")) 27 | -- yields: [] → (++) y z 28 | -- } 29 | -- {case-alt 1 30 | -- one-bu (inline '++) ; smash 31 | -- one-bu (forward (lemma-unsafe append-assoc)) -- use ind-hyp-0 in script 32 | -- yields: (:) a b → (:) a ((++) ((++) b y) z) 33 | -- } 34 | --} 35 | 36 | -- Now, for the rhs 37 | -- {rule-rhs-intro "append-assoc" 38 | -- consider lam ; lams-body 39 | 40 | -- case-split-inline 'x 41 | -- {case-alt 0 42 | -- any-bu (forward (lemma "nil-append")) 43 | -- yields: [] → (++) y z 44 | -- } 45 | -- {case-alt 1 46 | -- one-bu (inline '++) ; smash 47 | -- one-bu (inline '++) ; smash 48 | -- yields: (:) a b → (:) a ((++) ((++) b y) z) 49 | -- } 50 | -- } 51 | -- 52 | ---- then encode the proof as a rewrite or script 53 | define-script "append-assoc-nil" "any-bu (lemma-forward nil-append)" 54 | define-script "append-assoc-cons-left" "one-bu (inline '++) ; smash ; one-bu (lemma-forward ind-hyp-0)" 55 | 56 | define-script "append-assoc-cons-right" "one-bu (inline '++) ; smash ; one-bu (inline '++) ; smash " 57 | 58 | --verify-lemma "append-assoc" (inductive-proof-both-sides 'x [ '"[]" , ': ] [ append-assoc-nil , append-assoc-cons-left ] [ append-assoc-nil , append-assoc-cons-right ] ) 59 | 60 | script-to-rewrite append-assoc-nil "append-assoc-nil" 61 | script-to-rewrite append-assoc-cons-left "append-assoc-cons-left" 62 | 63 | prove-lemma "append-assoc" 64 | induction 'x 65 | 66 | { [forall-body] 67 | 68 | -- undefined case 69 | { [conj-lhs] 70 | { [forall-body] 71 | { [eq-lhs] 72 | one-bu (inline '++) 73 | } 74 | { [eq-rhs] 75 | one-bu (inline '++) 76 | } 77 | smash 78 | { [eq-rhs] 79 | one-td (inline '++) 80 | } 81 | smash 82 | } 83 | } 84 | 85 | -- nil case 86 | { [conj-rhs, conj-lhs] 87 | { [forall-body] 88 | { [eq-lhs] 89 | one-bu (inline '++) 90 | } 91 | smash 92 | { [eq-rhs, app-fun, app-arg] 93 | lemma-forward nil-append 94 | } 95 | reflexivity 96 | } 97 | } 98 | 99 | -- cons case 100 | { [conj-rhs, conj-rhs, forall-body, consequent] 101 | one-td (inline '++) 102 | smash 103 | one-bu (lemma-forward ind-hyp-0) 104 | 105 | -- Float (:) call out: 106 | { [eq-rhs] 107 | one-bu (inline '++) 108 | smash 109 | one-bu (inline '++) 110 | smash 111 | } 112 | 113 | reflexivity 114 | } 115 | smash -- 'a => true' is true 116 | } 117 | end-proof 118 | 119 | -------------------------------------------------------------------------------- /examples/laws/verify-append-nil.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify append-nil 3 | -- 4 | -- forall xs. xs ++ [] = xs 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-append-nil.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "append-nil" 14 | 15 | -- first do the proof interactively 16 | -- 17 | -- rule-lhs-intro "append-nil" 18 | -- consider lam ; lams-body 19 | -- case-split-inline 'xs 20 | -- {case-alt 0 21 | -- one-bu (inline '++); smash 22 | -- } 23 | -- {case-alt 1 24 | -- one-bu (inline '++); smash 25 | -- one-bu (forward ind-hyp-0) 26 | -- } 27 | 28 | -- then encode the proof as a rewrite or script 29 | define-script "append-nil-nil" "one-bu (inline '++); smash" 30 | define-script "append-nil-cons" "one-bu (inline '++); smash; one-bu (forward ind-hyp-0)" 31 | 32 | --verify-lemma "append-nil" (inductive-proof 'xs [ '"[]" , ': ] [ append-nil-nil , append-nil-cons ] ) 33 | 34 | prove-lemma "append-nil" 35 | induction 'xs 36 | forall-body 37 | { conj-lhs -- undefined case 38 | one-bu (inline '++) ; smash 39 | } 40 | 41 | { [conj-rhs, conj-lhs] -- nil case 42 | one-bu (inline '++) ; smash 43 | } 44 | 45 | { [conj-rhs, conj-rhs, forall-body, consequent] -- cons case 46 | -- XXX: Is it ok that we don't need to do anything with the antecedent here? 47 | 48 | one-bu (inline '++) ; smash 49 | one-bu (lemma-forward ind-hyp-0) 50 | reflexivity 51 | } 52 | end-proof 53 | 54 | -------------------------------------------------------------------------------- /examples/laws/verify-append-nonempty.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify append-nonempty 3 | -- 4 | -- forall x1 xs ys. x1 : (xs ++ ys) = (x1:xs) ++ ys 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "append-nonempty" 9 | 10 | define-script "append-nonempty-rhs" "unfold '++ ; smash" 11 | 12 | verify-lemma "append-nonempty" (flip-proof (script-to-proof append-nonempty-rhs)) 13 | -------------------------------------------------------------------------------- /examples/laws/verify-concat-append.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify concat-append 3 | -- 4 | -- forall x y. concat (x ++ y) = concat x ++ concat y 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "concat-append" 9 | 10 | load-and-run "verify-append-assoc.hec" 11 | 12 | -- set-auto-corelint True; set-pp-type Omit; prog-end 13 | -- rule-to-lemma "concat-append" ; rule-lhs-intro "concat-append"; consider lam ; lams-body 14 | 15 | define-script "concat-append-nil-left" "any-call (unfold '++ ); smash" 16 | define-script "concat-append-cons-left" "any-call (unfold '++ ); smash ; any-call (unfold 'concat) ; smash; one-bu (forward ind-hyp-0)" 17 | -- Yields: (++) a ((++) (concat b) (concat y)) 18 | define-script "concat-append-nil-right" "one-bu (unfold 'concat) ; smash ; any-call (unfold '++) ; smash" 19 | define-script "concat-append-cons-right" "one-bu (unfold 'concat) ; smash; one-bu (backward (lemma 'append-assoc))" 20 | 21 | verify-lemma "concat-append" (inductive-proof-both-sides 'x [ '"[]" , ': ] [ concat-append-nil-left , concat-append-cons-left ] [ concat-append-nil-right , concat-append-cons-right ] ) 22 | -------------------------------------------------------------------------------- /examples/laws/verify-concat-concat.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify concat-concat 3 | -- 4 | -- forall x. concat (concat x) = concat (map concat x) 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "concat-concat" 9 | 10 | load-and-run "verify-concat-append.hec" 11 | 12 | define-script "concat-concat-nil-left" "any-call (unfold 'concat) ; smash" 13 | define-script "concat-concat-cons-left" "{app-arg ; one-bu (inline 'concat) ; smash}" 14 | -- Yields: concat ((++) a (concat b)) 15 | define-script "concat-concat-nil-right" "any-call (unfold 'map) ; smash ; one-bu (inline 'concat) ; smash" 16 | define-script "concat-concat-cons-right" "any-call (unfold 'map) ; smash ; one-bu (inline 'concat) ; smash ; one-bu (backward ind-hyp-0); one-bu (backward (lemma 'concat-append))" 17 | 18 | verify-lemma "concat-concat" (inductive-proof-both-sides 'x [ '"[]" , ': ] [ concat-concat-nil-left , concat-concat-cons-left ] [ concat-concat-nil-right , concat-concat-cons-right ] ) 19 | -------------------------------------------------------------------------------- /examples/laws/verify-concat-nonempty.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify concat-nonempty 3 | -- 4 | -- forall x1 xs. concat (x:xs) = x ++ (concat xs) 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "concat-nonempty" 9 | 10 | define-script "concat-nonempty-rhs" "unfold 'concat ; smash" 11 | 12 | verify-lemma "concat-nonempty" (script-to-proof concat-nonempty-rhs) 13 | -------------------------------------------------------------------------------- /examples/laws/verify-concat-of-toList.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify concat-of-toList 3 | -- 4 | -- forall xs. concat (map toList xs) = xs 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-concat-of-toList.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "concat-of-toList" 14 | 15 | -- first do the proof interactively 16 | -- 17 | prove-lemma "concat-of-toList" 18 | consider lam ; lams-body 19 | case-split-inline 'xs 20 | {case-alt 0 21 | one-bu (inline 'map); smash 22 | one-bu (inline 'concat); smash 23 | } 24 | {case-alt 1 25 | one-bu (inline 'map); smash 26 | one-bu (inline 'concat); smash 27 | one-bu (inline 'toList); smash 28 | one-bu (inline '++); smash 29 | one-bu (inline '++); smash 30 | one-bu (forward ind-hyp-0) 31 | } 32 | 33 | -- then encode the proof as a rewrite or script 34 | --define-script "concat-of-toList-nil" "any-bu (inline 'map <+ inline 'concat); smash" 35 | --define-script "concat-of-toList-cons" "any-bu (inline 'map <+ inline 'concat); smash; any-bu (forward ind-hyp-0); repeat (any-bu (unfold 'toList <+ unfold '++ <+ smash))" 36 | -- 37 | --verify-lemma "concat-of-toList" (inductive-proof 'xs [ '"[]" , ': ] [ concat-of-toList-nil , concat-of-toList-cons ] ) 38 | -------------------------------------------------------------------------------- /examples/laws/verify-concat-unit.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify concat-unit 3 | -- 4 | -- forall x. concat [x] = x 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-concat-unit.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "concat-unit" 14 | 15 | load-and-run "verify-append-nil.hec" 16 | 17 | -- first do the proof interactively 18 | -- 19 | -- rule-lhs-intro "concat-unit" 20 | -- consider lam ; lams-body 21 | 22 | -- one-bu (inline 'concat); smash 23 | -- one-bu (inline 'concat); smash 24 | -- one-bu (forward (lemma append-nil)) 25 | 26 | define-script "concat-unit-proof" "one-bu (inline 'concat); smash; 27 | one-bu (inline 'concat); smash; 28 | one-bu (forward (lemma append-nil))" 29 | 30 | verify-lemma "concat-unit" (script-to-proof concat-unit-proof) 31 | -------------------------------------------------------------------------------- /examples/laws/verify-left-unit.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify left-unit 3 | -- 4 | -- 5 | -- forall f x. bind (retur x) f = f x 6 | -- 7 | -------------------------------------------- 8 | 9 | -- To test this script: 10 | -- prog-end 11 | -- load-and-run "verify-left-unit.hec" 12 | -- show-lemmas 13 | 14 | rule-to-lemma "left-unit" 15 | 16 | -- first do the proof interactively 17 | -- 18 | -- rule-lhs-intro "left-unit" -- TODO: add "lemma-lhs-intro" 19 | -- { consider lam ; lams-body 20 | -- -- Now we're focused on the expression that we want the proof to rewrite 21 | -- any-bu (inline [ 'bind, 'retur ]) 22 | -- smash 23 | -- -- Now we're done. 24 | -- } 25 | 26 | -- then encode the proof as a rewrite or script 27 | define-rewrite "left-unit-proof" "any-bu (inline [ 'bind, 'retur ]) ; smash" 28 | 29 | -- verify-lemma "left-unit" (script-to-proof left-unit-proof) 30 | 31 | prove-lemma "left-unit" 32 | left-unit-proof 33 | --end-proof 34 | 35 | -------------------------------------------------------------------------------- /examples/laws/verify-list-left-unit.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify list-left-unit 3 | -- 4 | -- 5 | -- forall f x. bind (retur x) f = f x 6 | -- 7 | -------------------------------------------- 8 | 9 | -- To test this script: 10 | -- prog-end 11 | -- load-and-run "verify-list-left-unit.hec" 12 | -- show-lemmas 13 | 14 | rule-to-lemma "left-unit" 15 | 16 | load-and-run "verify-concat-unit.hec" 17 | 18 | -- first do the proof interactively 19 | -- 20 | -- rule-lhs-intro "left-unit" 21 | -- consider lam ; lams-body 22 | 23 | -- any-bu (inline [ 'bind, 'retur ]) ; smash 24 | -- any-bu (inline 'toList) ; smash 25 | -- any-bu (inline 'map) ; smash 26 | -- any-bu (inline 'map) ; smash 27 | 28 | -- forward (lemma concat-unit) 29 | 30 | -- then encode the proof as a rewrite or script 31 | define-script "list-left-unit-proof" "any-bu (inline [ 'bind, 'retur ]) ; smash ; 32 | any-bu (inline 'toList) ; smash ; 33 | any-bu (inline 'map) ; smash ; 34 | any-bu (inline 'map) ; smash ; 35 | forward (lemma concat-unit)" 36 | 37 | verify-lemma "left-unit" (script-to-proof list-left-unit-proof) 38 | 39 | -------------------------------------------------------------------------------- /examples/laws/verify-list-monad-assoc.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify monad-assoc (for List) 3 | -- 4 | -- 5 | -- forall m f g. (m `bind` f) `bind` g = m `bind` \x -> (f x `bind` g) 6 | 7 | -- OR, using Kleisli composition 8 | -- (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c 9 | -- (m >=> n) x = m x >>= n 10 | -- 11 | -- Associativity: (f >=> g) >=> h ≡ f >=> (g >=> h) 12 | -- 13 | -- 14 | -- 15 | -- TO BE COMPLETED. 16 | -- 17 | -- 18 | -- See: http://mvanier.livejournal.com/4647.html 19 | -- "Yet Another Monad Tutorial (part 4: The Maybe and List Monads)" 20 | -- by Mike Vanier 21 | -- for a clear and detailed proof of this monad law for List. 22 | -- 23 | -- He factors this problem (in a way convenient for us) with: 24 | -- "In addition, I'll be using several identities involving map and concat applied to lists. 25 | -- You should just take these on faith for now, though I'll show how to derive them below._ 26 | -- -- equation 1: 27 | -- map (f . g) = map f . map g 28 | -- -- equation 2: 29 | -- map f . concat = concat . map (map f) 30 | -- \f x -> map f (concat x) == \f x -> concat (map (map f) x) 31 | -- -- equation 3: 32 | -- concat . concat = concat . map concato 33 | -- \x -> concat (concat x) == \x -> concat (map concat x) 34 | 35 | -------------------------------------------- 36 | 37 | -- To test this script: 38 | -- prog-end 39 | -- load-and-run "verify-list-monad-assoc.hec" 40 | -- show-lemmas 41 | 42 | rule-to-lemma "monad-assoc" 43 | load-and-run verify-map-compose.hec 44 | load-and-run verify-concat-nonempty.hec 45 | load-and-run verify-concat-concat.hec 46 | load-and-run verify-map-concat.hec 47 | 48 | load "list-monad-assoc-left-proof" "list-monad-assoc-lhs.her" 49 | load "list-monad-assoc-right-proof" "list-monad-assoc-rhs.her" 50 | 51 | verify-lemma "monad-assoc" (script-both-sides-to-proof list-monad-assoc-left-proof list-monad-assoc-right-proof) 52 | -------------------------------------------------------------------------------- /examples/laws/verify-list-monoid-assoc.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify list-monoid-assoc 3 | -- 4 | -- forall x y z. x `mappen` (y `mappen` z) = (x `mappen` y) `mappen` z 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-list-monoid-assoc.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "monoid-assoc" 14 | 15 | load-and-run "verify-append-assoc.hec" 16 | 17 | -- first do the proof interactively 18 | -- 19 | -- rule-lhs-intro "monoid-assoc" 20 | -- consider lam ; lams-body 21 | -- any-bu (inline 'mappen) ; smash 22 | -- any-bu (forward (lemma append-assoc)) 23 | 24 | -- then encode the proof as a rewrite or script 25 | define-script "list-monoid-assoc-left-proof" "any-bu (inline 'mappen) ; smash ; 26 | any-bu (forward (lemma append-assoc))" 27 | define-script "list-monoid-assoc-right-proof" "any-bu (inline 'mappen) ; smash" 28 | 29 | verify-lemma "monoid-assoc" (script-both-sides-to-proof list-monoid-assoc-left-proof list-monoid-assoc-right-proof) 30 | 31 | -------------------------------------------------------------------------------- /examples/laws/verify-list-monoid-left.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify list-monoid-left 3 | -- 4 | -- forall x. mempt `mappen` x = x 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-list-monoid-left.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "monoid-left" 14 | 15 | load-and-run "verify-nil-append.hec" 16 | 17 | -- first do the proof interactively 18 | -- 19 | -- rule-lhs-intro "monoid-left" 20 | -- consider lam ; lams-body 21 | -- any-bu (inline [ 'mempt, 'mappen ]) ; smash 22 | -- any-bu (forward (lemma "nil-append")) 23 | 24 | -- then encode the proof as a rewrite or script 25 | define-script "list-monoid-left-proof" "any-bu (inline [ 'mempt, 'mappen ]) ; smash ; 26 | any-bu (forward (lemma nil-append))" 27 | 28 | verify-lemma "monoid-left" (script-to-proof list-monoid-left-proof) 29 | 30 | -------------------------------------------------------------------------------- /examples/laws/verify-list-monoid-right.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify list-monoid-right 3 | -- 4 | -- forall x. x `mappen` mempt = x 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-list-monoid-right.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "monoid-right" 14 | 15 | load-and-run "verify-append-nil.hec" 16 | 17 | -- first do the proof interactively 18 | -- 19 | -- rule-lhs-intro "monoid-right" 20 | -- consider lam ; lams-body 21 | -- any-bu (inline [ 'mempt, 'mappen ]) ; smash 22 | -- any-bu (forward (lemma "append-nil")) 23 | 24 | -- then encode the proof as a rewrite or script 25 | define-script "list-monoid-right-proof" "any-bu (inline [ 'mempt, 'mappen ]) ; smash ; 26 | any-bu (forward (lemma append-nil))" 27 | 28 | verify-lemma "monoid-right" (script-to-proof list-monoid-right-proof) 29 | 30 | -------------------------------------------------------------------------------- /examples/laws/verify-list-right-unit.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify list-right-unit 3 | -- 4 | -- 5 | -- forall m. m `bind` retur = m 6 | -- 7 | -------------------------------------------- 8 | 9 | -- To test this script: 10 | -- prog-end 11 | -- load-and-run "verify-list-right-unit.hec" 12 | -- show-lemmas 13 | 14 | rule-to-lemma "right-unit" 15 | 16 | load-and-run "verify-concat-of-toList.hec" 17 | 18 | -- first do the proof interactively 19 | -- 20 | -- rule-lhs-intro "right-unit" 21 | -- consider lam ; lams-body 22 | 23 | -- case-split-inline 'm 24 | -- { case-alt 0 25 | -- any-bu (inline [ 'bind, 'retur ]) ; smash 26 | -- } 27 | -- {case-alt 1 28 | -- any-bu (inline [ 'bind, 'retur ]) ; smash 29 | -- any-bu (forward (lemma concat-of-toList)) 30 | -- } 31 | 32 | -- then encode the proof as a rewrite or script 33 | define-script "list-right-unit-nil" "any-bu (inline ['bind, 'retur]) ; smash" 34 | define-script "list-right-unit-cons" "any-bu (inline ['bind, 'retur]) ; smash ; any-bu (forward (lemma concat-of-toList))" 35 | 36 | verify-lemma "right-unit" (inductive-proof 'm [ '"[]" , ': ] [ list-right-unit-nil , list-right-unit-cons ] ) 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /examples/laws/verify-map-append.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify map-append 3 | -- 4 | -- forall f x y. map f (x ++ y) = map f x ++ map f y 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "map-append" 9 | 10 | load-and-run "verify-append-nonempty.hec" 11 | load-and-run "verify-map-nonempty.hec" 12 | 13 | -- rule-to-lemma "map-append" ; rule-lhs-intro "map-append" ; consider lam ; lams-body 14 | -- case-split-inline 'x 15 | 16 | define-script "map-append-nil-left" "any-call (unfold '++) ; smash" 17 | 18 | define-script "map-append-nil-right" "{app-fun ; app-arg ; unfold 'map ; smash } unfold '++; smash" 19 | 20 | define-script "map-append-cons-left" "one-bu (inline '++) ; smash ; one-bu (inline 'map) ; smash ; one-bu (forward ind-hyp-0) ; forward (lemma append-nonempty) ; one-bu (backward (lemma map-nonempty))" 21 | -- Yields: (++) (map f ((:) a b)) (map f y) 22 | 23 | define-script "map-append-cons-right" "id" 24 | 25 | verify-lemma "map-append" (inductive-proof-both-sides 'x [ '"[]" , ': ] [ map-append-nil-left , map-append-cons-left ] [map-append-nil-right , map-append-cons-right]) 26 | -------------------------------------------------------------------------------- /examples/laws/verify-map-compose.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify map-compose 3 | -- 4 | -- forall f g xs. map (f . g) xs = map f (map g xs) 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "map-compose" 9 | 10 | define-script "map-compose-left" "one-bu (inline 'map) ; smash" 11 | 12 | define-script "map-compose-nil-right" "{app-arg ; one-bu (inline 'map) ; smash } one-bu (inline 'map) ; smash" 13 | define-script "map-compose-cons-right" "{app-arg ; one-bu (inline 'map) ; smash } one-bu (inline 'map) ; smash ; one-bu (backward ind-hyp-0) ; one-bu (inline '.) ; smash" 14 | 15 | verify-lemma "map-compose" (inductive-proof-both-sides 'xs [ '"[]" , ': ] [ map-compose-left , map-compose-left ] [map-compose-nil-right , map-compose-cons-right]) 16 | -------------------------------------------------------------------------------- /examples/laws/verify-map-concat.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify map-concat 3 | -- 4 | -- forall f xs. map f (concat xs) = concat (map (map f) xs) 5 | -- forall f. map f . concat = concat . map (map f) 6 | 7 | -- 8 | -------------------------------------------- 9 | 10 | rule-to-lemma "map-concat" 11 | 12 | load-and-run "verify-map-append.hec" 13 | 14 | -- rule-to-lemma "map-concat" ; rule-lhs-intro "map-concat" ; consider lam ; lams-body 15 | -- case-split-inline 'xs 16 | 17 | define-script "map-concat-nil-left" "any-call (unfold ['concat, 'map]) ; smash" 18 | 19 | define-script "map-concat-cons-left" "any-call (unfold 'concat); smash; forward (lemma map-append); one-bu (forward ind-hyp-0)" 20 | -- Yields: (++) (map f a) (concat (map (map f) b)) 21 | 22 | define-script "map-concat-nil-right" "{app-arg ; one-bu (unfold 'map) ; smash } unfold 'concat; smash" 23 | 24 | define-script "map-concat-cons-right" "{app-arg ; unfold 'map ; smash } ; forward (lemma concat-nonempty)" 25 | -- Yields: (++) (map f a) (concat (map (map f) b)) 26 | 27 | verify-lemma "map-concat" (inductive-proof-both-sides 'xs [ '"[]" , ': ] [ map-concat-nil-left , map-concat-cons-left ] [map-concat-nil-right , map-concat-cons-right]) 28 | -------------------------------------------------------------------------------- /examples/laws/verify-map-nonempty.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify map-nonempty 3 | -- 4 | -- forall f a as. map f (a:as) = f a : map f as 5 | -- 6 | -------------------------------------------- 7 | 8 | rule-to-lemma "map-nonempty" 9 | 10 | define-script "map-nonempty-lhs" "unfold 'map ; smash" 11 | 12 | verify-lemma "map-nonempty" (script-to-proof map-nonempty-lhs) 13 | -------------------------------------------------------------------------------- /examples/laws/verify-monad-assoc.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify monad-assoc 3 | -- 4 | -- 5 | -- forall m f g. (m `bind` f) `bind` g = m `bind` \x -> (f x `bind` g) 6 | -- 7 | -------------------------------------------- 8 | 9 | -- To test this script: 10 | -- prog-end 11 | -- load-and-run "verify-monad-assoc.hec" 12 | -- show-lemmas 13 | 14 | rule-to-lemma "monad-assoc" 15 | 16 | -- first do the proof interactively 17 | -- 18 | TBD 19 | 20 | -- then encode the proof as a rewrite or script 21 | -- define-script "monad-assoc-proof" "any-bu (inline [ 'bind, 'retur ]) ; smash" 22 | 23 | -- verify-lemma "monad-assoc" (script-both-sides-to-proof monad-assoc-proof monad-assoc-proof) 24 | 25 | -------------------------------------------------------------------------------- /examples/laws/verify-nil-append.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify nil-append 3 | -- 4 | -- forall xs. [] ++ xs = xs 5 | -- 6 | -------------------------------------------- 7 | 8 | -- To test this script: 9 | -- prog-end 10 | -- load-and-run "verify-nil-append.hec" 11 | -- show-lemmas 12 | 13 | rule-to-lemma "nil-append" 14 | 15 | -- first do the proof interactively 16 | -- 17 | -- rule-lhs-intro "nil-append" 18 | -- consider lam ; lams-body 19 | -- any-bu (inline '++) ; smash 20 | 21 | -- then encode the proof as a rewrite or script 22 | 23 | prove-lemma "nil-append" 24 | any-bu (inline '++) ; smash 25 | end-proof 26 | 27 | -------------------------------------------------------------------------------- /examples/laws/verify-right-unit.hec: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | -- Verify right-unit 3 | -- 4 | -- 5 | -- forall m. m `bind` retur = m 6 | -- 7 | -------------------------------------------- 8 | 9 | -- To test this script: 10 | -- prog-end 11 | -- load-and-run "verify-right-unit.hec" 12 | -- show-lemmas 13 | 14 | rule-to-lemma "right-unit" 15 | 16 | -- first do the proof interactively 17 | -- 18 | -- rule-lhs-intro "right-unit" -- TODO: add "lemma-lhs-intro" 19 | -- { consider lam ; lams-body 20 | -- -- Now we're focused on the expression that we want the proof to rewrite 21 | -- any-bu (inline [ 'bind, 'retur ]) 22 | -- smash 23 | -- -- Now we're done. 24 | -- } 25 | 26 | -- then encode the proof as a rewrite or script 27 | define-script "right-unit-proof" "any-bu (inline [ 'bind, 'retur ]) ; smash" 28 | 29 | verify-lemma "right-unit" (script-to-proof right-unit-proof) 30 | 31 | -------------------------------------------------------------------------------- /examples/length/.gitignore: -------------------------------------------------------------------------------- 1 | Length 2 | -------------------------------------------------------------------------------- /examples/length/Length.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Prelude hiding (length,abs) 5 | 6 | import GHC.Err (undefined) 7 | 8 | length :: [a] -> Int 9 | length [] = zero 10 | length (a:as) = length as + 1 11 | 12 | main :: IO () 13 | main = print (length [1..1000000]) 14 | 15 | -- Goal 16 | -- length :: [a] -> Int 17 | -- length as = work as 0 18 | -- where 19 | -- work [] acc = acc 20 | -- work (b:bs) acc = acc `seq` work bs (1 + acc) 21 | 22 | -- This definition, despite being tail recursive, still stack overflows. 23 | -- The addition of the "seq" is crucial. 24 | -- length' :: [a] -> Int 25 | -- length' as = work as zero 26 | -- where 27 | -- work [] acc = acc 28 | -- work (b:bs) acc = work bs (1 + acc) 29 | 30 | rep :: Int -> Int -> Int 31 | rep n = (n +) 32 | 33 | abs :: (Int -> Int) -> Int 34 | abs f = f zero 35 | 36 | {-# NOINLINE zero #-} 37 | zero :: Int 38 | zero = 0 39 | 40 | {-# RULES "+ zero" forall n. n + zero = n #-} 41 | {-# RULES "zero +" forall n. zero + n = n #-} 42 | {-# RULES "assocLtoR" forall l m n. (l + m) + n = l + (m + n) #-} 43 | -------------------------------------------------------------------------------- /examples/length/Length.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | define-rewrite "WWC" "ww-result-AssA-to-AssC WWA" 3 | load-as-rewrite "StrictRep" "StrictRep.hss" 4 | flatten-module 5 | binding-of 'length 6 | ww-result-split-static-arg 1 [] [| abs |] [| rep |] WWC 7 | bash 8 | { rhs-of 'work 9 | alpha-lam 'as 10 | lam-body 11 | push 'rep StrictRep 12 | eta-expand 'acc 13 | lam-body 14 | case-float-app 15 | any-td (unfold 'rep) 16 | { [case-alt 0, alt-rhs] ; unfold-rule "zero +"} 17 | { [case-alt 1, alt-rhs] 18 | unfold-rule "assocLtoR" 19 | { app-fun ; fold 'rep ; ww-result-fusion } 20 | case-intro-seq 'acc 21 | } 22 | } 23 | one-td (unfold 'abs) 24 | one-td (inline 'zero) 25 | -------------------------------------------------------------------------------- /examples/length/LengthFullBad/LengthFull.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding (length,abs) 4 | 5 | import Data.Function (fix) 6 | import GHC.Err(undefined) 7 | 8 | length :: [a] -> Int 9 | length [] = zero 10 | length (a:as) = length as + 1 11 | 12 | main :: IO () 13 | main = print (length [1..1000000]) 14 | 15 | -- Goal 16 | -- length :: [a] -> Int 17 | -- length as = work as zero 18 | -- where 19 | -- work [] acc = acc 20 | -- work (b:bs) acc = acc `seq` work bs (1 + acc) 21 | 22 | -- This definition, despite being tail recursive, still stack overflows. 23 | -- The addition of the "seq" is crucial. 24 | -- length' :: [a] -> Int 25 | -- length' as = work as zero 26 | -- where 27 | -- work [] acc = acc 28 | -- work (b:bs) acc = work bs (1 + acc) 29 | 30 | -- I don't think putting the rep here is helpful. 31 | rep :: Int -> Int -> Int 32 | rep n acc = acc `seq` (n + acc) 33 | 34 | abs :: (Int -> Int) -> Int 35 | abs f = f zero 36 | 37 | {-# NOINLINE zero #-} 38 | zero :: Int 39 | zero = 0 40 | 41 | {-# RULES "+ zero" forall n. n + zero = n #-} 42 | {-# RULES "zero +" forall n. zero + n = n #-} 43 | {-# RULES "assocLtoR" forall l m n. (l + m) + n = l + (m + n) #-} 44 | -------------------------------------------------------------------------------- /examples/length/LengthFullBad/LengthFull.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A-Full.hss" 2 | load-as-rewrite "StrictRep" "StrictRepFull.hss" 3 | flatten-module 4 | consider 'length 5 | static-arg 6 | consider let 7 | { [let-bind, rec-def 0] 8 | ww-result-split [| abs |] [| rep |] (ww-result-AssA-to-AssC WWA) 9 | } 10 | bash 11 | { rhs-of 'work 12 | alpha-lam 'as 13 | lam-body 14 | push 'rep StrictRep 15 | eta-expand 'acc 16 | lam-body 17 | case-float-app 18 | any-td (unfold 'rep) 19 | { [case-alt 0, alt-rhs] 20 | one-td (unfold-rule "zero +") 21 | case-elim-inline-scrutinee 22 | } 23 | { [case-alt 1, alt-rhs, case-alt 0, alt-rhs] 24 | unfold-rule "assocLtoR" 25 | -- TODO: doesn't work because in this version, rep needs to fold a "seq" as well 26 | -- { app-fun ; fold 'rep ; ww-result-fusion } 27 | } 28 | } 29 | { let-body 30 | unfold 'abs 31 | one-td (inline 'zero) 32 | } -------------------------------------------------------------------------------- /examples/length/LengthFullBad/StrictRepFull.hss: -------------------------------------------------------------------------------- 1 | -- Proof that "rep" is strict 2 | 3 | unfold 'rep 4 | { consider alt ; alt-rhs 5 | unfold '+ 6 | bash 7 | unfold 8 | } 9 | bash-extended-with [undefined-expr] 10 | -------------------------------------------------------------------------------- /examples/length/LengthFullBad/WW-Ass-A-Full.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper (Result Variant) Assumption A: abs (rep n) <=> n 2 | 3 | -- abs (rep n) 4 | { unfold 'abs } 5 | -- rep n zero 6 | { unfold 'rep } 7 | -- case zero of acc {_} -> n + zero 8 | { case-elim-inline-scrutinee } 9 | -- n + zero 10 | { unfold-rule "+ zero" } 11 | -- n 12 | -------------------------------------------------------------------------------- /examples/length/StrictRep.hss: -------------------------------------------------------------------------------- 1 | -- Proof that "rep" is strict 2 | 3 | unfold 'rep 4 | unfold '+ 5 | bash 6 | unfold 7 | bash-extended-with [undefined-expr] 8 | -------------------------------------------------------------------------------- /examples/length/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper (Result Variant) Assumption A: abs (rep n) <=> n 2 | 3 | -- abs (rep n) 4 | { unfold 'abs } 5 | -- rep n zero 6 | { unfold 'rep } 7 | -- n + zero 8 | { unfold-rule "+ zero" } 9 | -- n 10 | -------------------------------------------------------------------------------- /examples/map-fusion/MapFusion.hec: -------------------------------------------------------------------------------- 1 | binding-of 'map 2 | set-pp-type "Omit" 3 | top 4 | rule-to-lemma "map-fusion" 5 | prove-lemma "map-fusion" 6 | -- forall f g. map f . map g = map (f . g) 7 | extensionality 'xs 8 | -- forall f g xs. (map f . map g) xs = map (f . g) xs 9 | lhs (unfold '.) 10 | -- forall f g xs. map f (map g xs) = map (f . g) xs 11 | induction 'xs 12 | 13 | -- Case undefined 14 | -- forall f g. map f (map g undefined) = map (f . g) undefined 15 | rhs (unfold 'map) 16 | 17 | -- forall f g. 18 | -- map f (map g undefined) 19 | -- = 20 | -- case undefined of 21 | -- [] -> [] 22 | -- a:as -> (f . g) a : map (f . g) as 23 | rhs undefined-case 24 | 25 | -- forall f g. map f (map g undefined) = undefined 26 | lhs (any-bu (unfold 'map >>> undefined-case)) 27 | end-proof 28 | 29 | -- Case [] 30 | -- forall f g. map f (map g []) = map (f . g) [] 31 | both (any-bu (unfold 'map >>> case-reduce)) 32 | end-proof 33 | 34 | -- Case (:) 35 | -- induction hypothesis: map f (map g ys) = map (f . g) ys 36 | 37 | -- forall f g. map f (map g (y:ys)) = map (f . g) (y:ys) 38 | both (any-bu (unfold 'map >>> case-reduce)) 39 | 40 | -- forall f g. f (g y) : map f (map g ys) = (f . g) y : map (f . g) ys 41 | rhs (one-td (backward (lemma ind-hyp-0))) 42 | 43 | -- forall f g. f (g y) : map f (map g ys) = (f . g) y : map f (map g ys) 44 | rhs (one-td (unfold '.)) 45 | end-proof 46 | 47 | -- Successfully proven 48 | -------------------------------------------------------------------------------- /examples/map-fusion/MapFusion.hs: -------------------------------------------------------------------------------- 1 | module MapFusion where 2 | 3 | import Prelude hiding (map) 4 | 5 | {-# RULES "map-fusion" forall f g. map f . map g = map (f . g) #-} 6 | 7 | map :: (a -> b) -> [a] -> [b] 8 | map f [] = [] 9 | map f (a:as) = f a : map f as 10 | -------------------------------------------------------------------------------- /examples/map-fusion/README: -------------------------------------------------------------------------------- 1 | Note: this example requires GHC >= 7.8 to run. 2 | 3 | First install HERMIT, which can be done via Cabal: 4 | 5 | > cabal install hermit 6 | 7 | To run the example, invoke HERMIT as follows: 8 | 9 | > hermit MapFusion.hs MapFusion.hec 10 | 11 | If it runs successfully, you can use the HERMIT command "show-lemmas" to display the map-fusion lemma (which should be noted as proved). 12 | 13 | hermit> show-lemmas 14 | -------------------------------------------------------------------------------- /examples/map/Makefile: -------------------------------------------------------------------------------- 1 | HERMIT = perl ../../scripts/hermit.pl 2 | 3 | last: 4 | - $(HERMIT) Map.hs Map.hss resume 5 | 6 | interactive: 7 | - $(HERMIT) Map.hs Map.hss 8 | 9 | start: 10 | - $(HERMIT) Map.hs 11 | -------------------------------------------------------------------------------- /examples/map/Map.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Function(fix) 4 | import Prelude hiding (abs, map) 5 | 6 | data List2 a = Cons2 a a (List2 a) 7 | | Singleton a 8 | | Nil 9 | 10 | rep :: [a] -> List2 a 11 | rep [] = Nil 12 | rep [x] = Singleton x 13 | rep (x:y:xs) = Cons2 x y (rep xs) 14 | 15 | abs :: List2 a -> [a] 16 | abs Nil = [] 17 | abs (Singleton x) = [x] 18 | abs (Cons2 x y xs) = x : y : abs xs 19 | 20 | unwrap :: ([a] -> [b]) -> (List2 a -> List2 b) 21 | unwrap f = rep . f . abs 22 | 23 | wrap :: (List2 a -> List2 b) -> ([a] -> [b]) 24 | wrap f = abs . f . rep 25 | 26 | -- needed for WWSplitTactic.hss 27 | {-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-} 28 | {-# RULES "inline-fix" forall f . fix f = let work = f work in work #-} 29 | {-# RULES "precondition1" forall xs . abs (rep xs) = xs #-} 30 | {-# RULES "precondition2" forall xs . rep (abs xs) = xs #-} 31 | 32 | -- can apply "ww" rule to this 33 | mapPlus1Int :: [Int] -> [Int] 34 | mapPlus1Int [] = [] 35 | mapPlus1Int (x:xs) = (x+1) : mapPlus1Int xs 36 | 37 | {- can't apply "ww" rule to either of these... is it because of the forall type? 38 | unwrap :: ((a -> b) -> [a] -> [b]) -> ((a -> b) -> [a] -> List2 b) 39 | unwrap g f = rep . g f 40 | 41 | wrap :: ((a -> b) -> [a] -> List2 b) -> ((a -> b) -> [a] -> [b]) 42 | wrap g f = abs . g f 43 | -} 44 | mapPlus1 :: Num a => [a] -> [a] 45 | mapPlus1 [] = [] 46 | mapPlus1 (x:xs) = (x+1) : mapPlus1 xs 47 | 48 | map :: (a -> b) -> [a] -> [b] 49 | map _ [] = [] 50 | map f (x:xs) = f x : map f xs 51 | 52 | main :: IO () 53 | main = print (map (+1) [1..10::Int]) 54 | -------------------------------------------------------------------------------- /examples/map/Map.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | -- consider 'mapPlus1Int 3 | binding-of 'mapPlus1Int 4 | consider def 5 | {load-and-run "WWSplitTactic.hss" 6 | consider 'work 7 | 8 | remember origwork 9 | 0 10 | one-td (unfold 'unwrap) 11 | any-call (unfold '.) 12 | innermost (beta-reduce <+ safe-let-subst) 13 | 0 14 | case-split-inline 'x 15 | { 3 -- Nil case 16 | any-call (unfold 'abs) 17 | any-call (unfold 'f) 18 | any-call (unfold 'rep) 19 | simplify 20 | } 21 | { 2 -- Singleton case 22 | any-call (unfold 'abs) 23 | any-call (unfold 'f) 24 | any-call (unfold 'wrap) 25 | any-call (unfold 'rep) 26 | -- here we make use of the already solved Nil case 27 | any-call (unfold 'work) 28 | simplify 29 | any-call (unfold 'abs) 30 | simplify 31 | } 32 | { 1 -- Cons2 case 33 | any-call (unfold 'abs) 34 | any-call (unfold 'f) 35 | any-call (unfold 'wrap) 36 | simplify 37 | any-bu (unfold origwork) 38 | any-call (unfold 'unwrap) 39 | simplify 40 | innermost (unfold-rule precondition1) 41 | any-call (unfold 'f) 42 | innermost case-reduce 43 | any-call (unfold 'rep) 44 | innermost case-reduce 45 | any-call (unfold 'wrap) 46 | simplify 47 | innermost (unfold-rule precondition2) 48 | } 49 | } 50 | simplify 51 | -------------------------------------------------------------------------------- /examples/map/WWSplitTactic.hss: -------------------------------------------------------------------------------- 1 | { 2 | fix-intro 3 | consider lam 4 | let-intro 'f 5 | up 6 | let-float-arg 7 | 1 8 | apply-rule ww 9 | simplify 10 | { 1; let-intro 'w } 11 | let-float-arg 12 | { rhs-of 'w 13 | unfold 'fix ; alpha-let ['work] 14 | simplify 15 | } 16 | let-subst 17 | let-float-arg 18 | } 19 | -------------------------------------------------------------------------------- /examples/mean/Mean.hs: -------------------------------------------------------------------------------- 1 | module Main (main, mean) where 2 | 3 | import Prelude hiding (sum, length) 4 | 5 | mean :: [Int] -> Int 6 | mean xs = sum xs `div` length xs 7 | 8 | sum :: [Int] -> Int 9 | sum [] = 0 10 | sum (x:xs) = x + sum xs 11 | 12 | length :: [Int] -> Int 13 | length [] = 0 14 | length (x:xs) = 1 + length xs 15 | 16 | main :: IO () 17 | main = print $ mean [1..10] 18 | -------------------------------------------------------------------------------- /examples/mean/Mean.hss: -------------------------------------------------------------------------------- 1 | {rhs-of 'mean ; lam-body 2 | { arg 2 ; let-intro 's } 3 | { arg 3 ; let-intro 'l } 4 | innermost let-float 5 | try (reorder-lets ['s,'l]) 6 | let-tuple 'sl 7 | { case-expr ; abstract 'xs ; app-fun ; let-intro 'sumlength } 8 | } 9 | innermost let-float 10 | binding-group-of 'sumlength 11 | nonrec-to-rec -- since we intend sumlength to be a recursive function 12 | binding-of 'sumlength 13 | remember sumlen 14 | { [def-rhs, lam-body] 15 | case-split-inline 'xs 16 | any-call (unfold 'sum) 17 | any-call (unfold 'length) 18 | simplify 19 | case-alt 1 20 | alpha-alt ['y,'ys] 21 | alt-rhs 22 | { arg 3 ; arg 3 ; let-intro 'l } 23 | { arg 2 ; arg 3 ; let-intro 's } 24 | innermost let-float 25 | try (reorder-lets ['s,'l]) 26 | let-tuple 'sl 27 | { case-expr ; fold-remembered sumlen } 28 | } 29 | -------------------------------------------------------------------------------- /examples/new_reverse/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | , myAppend 6 | ) where 7 | 8 | type H a = [a] -> [a] 9 | 10 | -- {-# INLINABLE repH #-} 11 | repH :: [a] -> H a 12 | repH xs = (xs ++) 13 | 14 | -- {-# INLINABLE absH #-} 15 | absH :: H a -> [a] 16 | absH f = f [] 17 | 18 | -- Because we can't get unfolding for ++ 19 | myAppend :: [a] -> [a] -> [a] 20 | myAppend [] ys = ys 21 | myAppend (x:xs) ys = x : myAppend xs ys 22 | -- {-# RULES "appendFix" [~] (++) = myAppend #-} 23 | 24 | -- -- Algebra for repH 25 | -- {-# RULES "repH []" [~] repH [] = id #-} 26 | -- {-# RULES "repH (:)" [~] forall x xs. repH (x:xs) = (x:) . repH xs #-} 27 | -- {-# RULES "repH ++" [~] forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-} 28 | 29 | -- -- Needed because the fusion rule we generate isn't too useful yet. 30 | -- {-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-} 31 | -------------------------------------------------------------------------------- /examples/new_reverse/Reverse.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import HList 4 | import Data.Function (fix) 5 | 6 | {-# INLINE repR #-} 7 | repR :: ([a] -> [a]) -> ([a] -> H a) 8 | repR f = repH . f 9 | 10 | {-# INLINE absR #-} 11 | absR :: ([a] -> H a) -> ([a] -> [a]) 12 | absR g = absH . g 13 | 14 | rev :: [a] -> [a] 15 | rev [] = [] 16 | rev (x:xs) = rev xs ++ [x] 17 | 18 | main :: IO () 19 | main = print $ rev [1..10] 20 | 21 | -- useful auxilliary lemma for proving the w/w assumption 22 | {-# RULES "++ []" [~] forall xs. xs ++ [] = xs #-} 23 | {-# RULES "myAppend-assoc" [~] forall xs ys zs. myAppend (myAppend xs ys) zs = myAppend xs (myAppend ys zs) #-} 24 | 25 | 26 | {-# RULES "appendFix" [~] (++) = myAppend #-} 27 | 28 | -- Algebra for repH 29 | {-# RULES "repH []" [~] repH [] = id #-} 30 | {-# RULES "repH (:)" [~] forall x xs. repH (x:xs) = (x:) . repH xs #-} 31 | {-# RULES "repH ++" [~] forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-} 32 | 33 | -- Needed because the fusion rule we generate isn't too useful yet. 34 | {-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-} 35 | 36 | -------------------------------------------------------------------------------- /examples/nub/Nub.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Set as Set 4 | import Data.Set (Set) 5 | 6 | import Prelude hiding (filter) -- because we can't get unfolding for filter 7 | 8 | filter :: (a -> Bool) -> [a] -> [a] 9 | filter _ [] = [] 10 | filter p (x:xs) = if p x then x : filter p xs else filter p xs 11 | 12 | nub :: [Int] -> [Int] 13 | nub [] = [] 14 | nub (x:xs) = x : nub (filter (/= x) xs) 15 | 16 | absN :: ([Int] -> Set Int -> [Int]) -> [Int] -> [Int] 17 | absN h [] = [] 18 | absN h (x:xs) = x : h xs (Set.singleton x) 19 | 20 | repN :: ([Int] -> [Int]) -> [Int] -> Set Int -> [Int] 21 | repN h xs s = h (filter (`Set.notMember` s) xs) 22 | 23 | main :: IO () 24 | main = print (nub [ x | n <- [1..1000], x <- [1..n] ]) 25 | 26 | {-# RULES "filter-fusion" [~] forall p q ys. filter p (filter q ys) = filter (\y -> p y && q y) ys #-} 27 | {-# RULES "member-fusion" [~] forall y x s. (y /= x) && (y `Set.notMember` s) = y `Set.notMember` (Set.insert x s) #-} 28 | -------------------------------------------------------------------------------- /examples/nub/Nub.hss: -------------------------------------------------------------------------------- 1 | set-pp-type Show 2 | 3 | flatten-module 4 | 5 | binding-of 'nub 6 | fix-intro ; def-rhs 7 | split-2-beta nub [| absN |] [| repN |] ; assume 8 | 9 | -- this bit to essentially undo the fix-intro 10 | { application-of 'repN ; app-arg ; let-intro 'nub ; one-td (unfold 'fix) ; simplify } 11 | innermost let-float 12 | alpha-let ['nub'] -- rename x to nub' 13 | 14 | -- back to the derivation 15 | binding-of 'worker 16 | one-td (unfold 'repN) 17 | remember origworker 18 | one-td (unfold 'filter) 19 | one-td (case-float-arg-lemma nubStrict) 20 | 21 | -- prove strictness condition 22 | lhs unfold ; smash ; end-proof 23 | 24 | one-td (unfold 'nub') 25 | simplify 26 | 27 | one-td (case-float-arg-lemma nubStrict) 28 | 29 | -- prove strictness condition 30 | lhs unfold ; smash ; end-proof 31 | 32 | { consider case ; consider case ; case-alt 1 ; alt-rhs 33 | unfold ; simplify 34 | one-td (unfold-rule "filter-fusion") ; assume 35 | simplify 36 | one-td (unfold-rule "member-fusion") ; assume 37 | } 38 | nonrec-to-rec 39 | any-td (fold-remembered origworker) 40 | 41 | -------------------------------------------------------------------------------- /examples/original_reverse/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | ) where 6 | 7 | type H a = [a] -> [a] 8 | 9 | {-# INLINE repH #-} 10 | repH :: [a] -> H a 11 | repH xs = (xs ++) 12 | 13 | {-# INLINE absH #-} 14 | absH :: H a -> [a] 15 | absH f = f [] 16 | 17 | -- Because we can't get unfolding for ++ 18 | myAppend :: [a] -> [a] -> [a] 19 | myAppend [] ys = ys 20 | myAppend (x:xs) ys = x : myAppend xs ys 21 | {-# RULES "appendFix" forall xs ys. xs ++ ys = myAppend xs ys #-} 22 | 23 | -- These two we may get for free via INLINE 24 | {-# RULES "repH" forall xs . repH xs = (xs ++) #-} 25 | {-# RULES "absH" forall f . absH f = f [] #-} 26 | 27 | -- The "Algebra" for repH 28 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 29 | {-# RULES "repH []" repH [] = id #-} 30 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 31 | 32 | -- Should be in the "List" module 33 | {-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-} 34 | {-# RULES "[] ++" forall xs . [] ++ xs = xs #-} 35 | 36 | -- has preconditon 37 | {-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-} 38 | 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /examples/original_reverse/Original.hss: -------------------------------------------------------------------------------- 1 | -- set-renderer latex 2 | -- set-renderer unicode-console 3 | -- unicode-terminal 4 | 5 | flatten-module 6 | 7 | -- This is the outer rev, with the big lambda 8 | consider 'rev 9 | consider 'rev 10 | fix-intro 11 | any-call (unfold-rule "ww") 12 | any-call (unfold '.) 13 | any-call (unfold 'wrap) 14 | any-call (unfold 'unwrap) 15 | any-call (unfold '.) 16 | unshadow ; bash 17 | any-bu case-float-arg 18 | any-bu (apply-rule "repH ++") ; bash 19 | any-bu (apply-rule "repH []") ; bash 20 | any-bu (unfold-rule "rep-abs-fusion") 21 | 22 | -- This is just a setup to all completion 23 | { consider case ; eta-expand 'ys ; any-bu case-float-app } 24 | any-call (unfold 'repH) 25 | any-call (unfold '.) 26 | any-call (unfold-rule "(:) ++") 27 | any-call (unfold-rule "[] ++") 28 | any-call (unfold 'fix) ; bash 29 | unshadow 30 | any-call (unfold 'absH) 31 | -------------------------------------------------------------------------------- /examples/original_reverse/Reverse.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import HList 5 | import Data.Function (fix) 6 | 7 | {-# INLINE repR #-} 8 | repR :: ([a] -> [a]) -> ([a] -> H a) 9 | repR f = repH . f 10 | 11 | {-# INLINE absR #-} 12 | absR :: ([a] -> H a) -> ([a] -> [a]) 13 | absR g = absH . g 14 | 15 | {-# RULES "ww" forall body. fix body = absR (fix (repR . body . absR)) #-} 16 | -- {-# RULES "inline-fix" forall f . fix f = let w = f w in w #-} 17 | 18 | -- rev :: [a] -> [a] 19 | rev [] = [] 20 | rev (x:xs) = rev xs ++ [x] 21 | 22 | main = defaultMain 23 | [ bench (show n) $ whnf (\n -> sum $ rev [1..n]) n 24 | | n <- take 8 $ [50,100..] 25 | ] 26 | -------------------------------------------------------------------------------- /examples/original_reverse/Reverse.hss: -------------------------------------------------------------------------------- 1 | -- set-renderer latex 2 | -- set-renderer unicode-console 3 | -- unicode-terminal 4 | 5 | flatten-module 6 | 7 | -- This is the outer rev, with the big lambda 8 | binding-of 'rev 9 | binding-of 'rev 10 | fix-intro 11 | any-call (unfold-rule "ww") 12 | any-call (unfold '.) 13 | any-call (unfold 'absR) 14 | any-call (unfold 'repR) 15 | any-call (unfold '.) 16 | unshadow ; bash 17 | stop-script 18 | any-bu (case-float-arg-lemma "test") 19 | any-bu (apply-rule "repH ++") ; bash 20 | any-bu (apply-rule "repH []") ; bash 21 | any-bu (unfold-rule "rep-abs-fusion") 22 | 23 | -- This is just a setup to all completion 24 | { consider case ; eta-expand 'ys ; any-bu case-float-app } 25 | any-call (unfold 'repH) 26 | any-call (unfold-rule "(:) ++") 27 | any-call (unfold-rule "[] ++") 28 | any-call (unfold 'fix) ; bash 29 | unshadow 30 | any-call (unfold 'absH) 31 | { consider let ; alpha-let ["rev'"] } 32 | -------------------------------------------------------------------------------- /examples/qsort/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | ) where 6 | 7 | type H a = [a] -> [a] 8 | 9 | -- {-# INLINE repH #-} 10 | repH :: [a] -> H a 11 | repH xs = (xs ++) 12 | 13 | -- {-# INLINE absH #-} 14 | absH :: H a -> [a] 15 | absH f = f [] 16 | 17 | -- -- Should be in a "List" module 18 | -- {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 19 | -- {-# RULES "++ strict" (++) undefined = undefined #-} 20 | 21 | -- -- The "Algebra" for repH 22 | -- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 23 | -- {-# RULES "repH []" repH [] = id #-} 24 | -- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 25 | 26 | -- -- Needed because the fusion rule we generate isn't too useful yet. 27 | -- {-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-} 28 | -------------------------------------------------------------------------------- /examples/qsort/QSort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import HList 5 | 6 | import Data.List 7 | 8 | data Tree a = Node (Tree a) (Tree a) | Leaf a 9 | 10 | {-# INLINE repR #-} 11 | repR :: ([a] -> [a]) -> ([a] -> H a) 12 | repR f = repH . f 13 | 14 | {-# INLINE absR #-} 15 | absR :: ([a] -> H a) -> ([a] -> [a]) 16 | absR g = absH . g 17 | 18 | qsort :: Ord a => [a] -> [a] 19 | qsort [] = [] 20 | qsort (a:as) = qsort bs ++ [a] ++ qsort cs 21 | where 22 | (bs , cs) = partition (< a) as 23 | 24 | main :: IO () 25 | main = print (qsort [8,3,5,7,2,9,4,6,3,2]) 26 | 27 | -- Should be in a "List" module 28 | {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 29 | {-# RULES "++ strict" (++) undefined = undefined #-} 30 | 31 | -- The "Algebra" for repH 32 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 33 | {-# RULES "repH []" repH [] = id #-} 34 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 35 | 36 | -- Needed because the fusion rule we generate isn't too useful yet. 37 | {-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-} 38 | 39 | -------------------------------------------------------------------------------- /examples/qsort/QSort.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | binding-of 'qsort 3 | static-arg 4 | { 5 | binding-of 'qsort' 6 | fix-intro 7 | def-rhs 8 | split-1-beta qsort [|absR|] [|repR|] ; assume 9 | rhs-of 'worker 10 | repeat (any-call (unfold ['.,'fix,'g,'repR,'absR])) 11 | simplify 12 | one-td (case-float-arg-lemma repHstrict) ; assume 13 | innermost let-float 14 | any-td (unfold-rule "repH ++") ; assume 15 | any-call (unfold-rule repH-absH-fusion) ; assume 16 | unshadow 17 | any-td (inline 'ds1) 18 | simplify 19 | alpha-let [worker] 20 | repeat (any-call (unfold-rules ["repH (:)","repH []"])) 21 | assume ; assume 22 | } 23 | repeat (any-call (unfold ['.,'absR, 'absH])) 24 | innermost let-float 25 | bash 26 | -------------------------------------------------------------------------------- /examples/reverse/HList.hs: -------------------------------------------------------------------------------- 1 | module HList 2 | ( H 3 | , repH 4 | , absH 5 | ) where 6 | 7 | type H a = [a] -> [a] 8 | 9 | -- {-# INLINE repH #-} 10 | repH :: [a] -> H a 11 | repH xs = (xs ++) 12 | 13 | -- {-# INLINE absH #-} 14 | absH :: H a -> [a] 15 | absH f = f [] 16 | 17 | -- -- Should be in a "List" module 18 | -- {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 19 | -- {-# RULES "++ strict" (++) undefined = undefined #-} 20 | 21 | -- -- The "Algebra" for repH 22 | -- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 23 | -- {-# RULES "repH []" repH [] = id #-} 24 | -- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 25 | -------------------------------------------------------------------------------- /examples/reverse/Reverse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import HList 5 | -- import Seq 6 | 7 | rev :: [a] -> [a] 8 | rev [] = [] 9 | rev (x:xs) = rev xs ++ [x] 10 | 11 | main :: IO () 12 | main = print $ rev "hello" 13 | 14 | 15 | -- Should be in a "List" module 16 | {-# RULES "++ []" forall xs . xs ++ [] = xs #-} 17 | {-# RULES "++ strict" (++) undefined = undefined #-} 18 | 19 | -- The "Algebra" for repH 20 | {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} 21 | {-# RULES "repH []" repH [] = id #-} 22 | {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} 23 | -------------------------------------------------------------------------------- /examples/reverse/Reverse.hss: -------------------------------------------------------------------------------- 1 | load-as-rewrite "WWA" "WW-Ass-A.hss" 2 | define-rewrite "WWC" "ww-result-AssA-to-AssC WWA" 3 | load-as-rewrite "StrictRepH" "StrictRepH.hss" 4 | binding-of 'rev 5 | ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC 6 | bash 7 | { rhs-of 'work 8 | alpha-lam 'ys 9 | lam-body 10 | eta-expand 'acc 11 | lam-body 12 | bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, unfold-rules-unsafe ["repH ++", "repH (:)", "repH []"] ] 13 | } 14 | one-td (unfold 'absH) 15 | -------------------------------------------------------------------------------- /examples/reverse/StrictRepH.hss: -------------------------------------------------------------------------------- 1 | -- Proof that "repH" is strict 2 | 3 | 4 | -- repH ty (undefined [ty]) 5 | { unfold 'repH } 6 | -- (++) ty (undefined [ty]) 7 | { unfold-rule-unsafe "++ strict" } 8 | -- undefined ([ty] -> [ty]) 9 | -------------------------------------------------------------------------------- /examples/reverse/WW-Ass-A.hss: -------------------------------------------------------------------------------- 1 | -- Worker/Wrapper (Result Variant) Assumption A: absH (repH x) <=> x 2 | 3 | -- absH (repH x) 4 | { unfold 'absH } 5 | -- repH x [] 6 | { unfold 'repH } 7 | -- x ++ [] 8 | { unfold-rule-unsafe "++ []" } 9 | -- x 10 | -------------------------------------------------------------------------------- /optimizations/README: -------------------------------------------------------------------------------- 1 | This directory contains various optimization plugins implemented 2 | with the HERMIT Plugin DSL. 3 | -------------------------------------------------------------------------------- /optimizations/pretty/hermit-pretty/HERMIT/Pretty.hs: -------------------------------------------------------------------------------- 1 | module HERMIT.Pretty where 2 | 3 | import GhcPlugins hiding (display) 4 | 5 | import Control.Monad 6 | 7 | import Language.HERMIT.Optimize 8 | import Language.HERMIT.Plugin 9 | import Language.HERMIT.Primitive.Navigation 10 | 11 | import Language.Haskell.TH as TH 12 | 13 | plugin :: Plugin 14 | plugin = optimize $ \ fns -> after SpecConstr $ 15 | forM_ fns $ \ fn -> at (considerName $ TH.mkName fn) display 16 | -------------------------------------------------------------------------------- /optimizations/pretty/hermit-pretty/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /optimizations/pretty/hermit-pretty/hermit-pretty.cabal: -------------------------------------------------------------------------------- 1 | name: hermit-pretty 2 | version: 0.1.0.0 3 | author: Andrew Farmer 4 | maintainer: afarmer@ittc.ku.edu 5 | build-type: Simple 6 | cabal-version: >=1.14 7 | 8 | library 9 | exposed-modules: 10 | HERMIT.Pretty 11 | build-depends: 12 | base, 13 | ghc >= 7.6, 14 | hermit, 15 | template-haskell 16 | default-language: Haskell2010 17 | ghc-options: -Wall 18 | -------------------------------------------------------------------------------- /src/HERMIT.hs: -------------------------------------------------------------------------------- 1 | module HERMIT (plugin) where 2 | 3 | import Data.Maybe (fromMaybe) 4 | 5 | import HERMIT.GHC 6 | import HERMIT.Plugin.Builder (getPassFlag) 7 | import HERMIT.Plugin 8 | 9 | plugin :: Plugin 10 | plugin = hermitPlugin $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPassFlag options) 11 | in pass pn $ interactive [] opts 12 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module HERMIT.Dictionary.Debug 3 | ( -- * Debugging Rewrites 4 | externals 5 | , bracketR 6 | , observeR 7 | , observeFailureR 8 | , traceR 9 | ) where 10 | 11 | import Control.Arrow 12 | 13 | import HERMIT.Context 14 | import HERMIT.Core 15 | import HERMIT.External 16 | import HERMIT.Kure 17 | import HERMIT.Monad 18 | 19 | -- | Exposed debugging 'External's. 20 | externals :: [External] 21 | externals = map (.+ Debug) 22 | [ external "trace" (traceR :: String -> RewriteH LCoreTC) 23 | [ "give a side-effect message as output when processing this command" ] 24 | , external "observe" (observeR :: String -> RewriteH LCoreTC) 25 | [ "give a side-effect message as output, and observe the value being processed" ] 26 | , external "observe-failure" (observeFailureR :: String -> RewriteH LCoreTC -> RewriteH LCoreTC) 27 | [ "give a side-effect message if the rewrite fails, including the failing input" ] 28 | , external "bracket" (bracketR :: String -> RewriteH LCoreTC -> RewriteH LCoreTC) 29 | [ "if given rewrite succeeds, see its input and output" ] 30 | ] 31 | 32 | -- | If the 'Rewrite' fails, print out the 'Core', with a message. 33 | observeFailureR :: ( Injection a LCoreTC, LemmaContext c, ReadBindings c, ReadPath c Crumb 34 | , HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m ) 35 | => String -> Rewrite c m a -> Rewrite c m a 36 | observeFailureR str m = m <+ observeR str 37 | 38 | -- | Print out the 'Core', with a message. 39 | observeR :: ( Injection a LCoreTC, LemmaContext c, ReadBindings c, ReadPath c Crumb 40 | , HasHermitMEnv m, HasLemmas m, LiftCoreM m ) 41 | => String -> Rewrite c m a 42 | observeR msg = extractR $ sideEffectR $ \ cxt -> sendKEnvMessage . DebugCore msg cxt 43 | 44 | -- | Just say something, every time the rewrite is done. 45 | traceR :: (HasHermitMEnv m, HasLemmas m, LiftCoreM m) => String -> Rewrite c m a 46 | traceR msg = sideEffectR $ \ _ _ -> sendKEnvMessage $ DebugTick msg 47 | 48 | -- | Show before and after a rewrite. 49 | bracketR :: ( Injection a LCoreTC, LemmaContext c, ReadBindings c, ReadPath c Crumb 50 | , HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m ) 51 | => String -> Rewrite c m a -> Rewrite c m a 52 | bracketR msg rr = do 53 | -- Be careful to only run the rr once, in case it has side effects. 54 | (e,r) <- idR &&& attemptM rr 55 | either fail (\ e' -> do _ <- return e >>> observeR before 56 | return e' >>> observeR after) r 57 | where before = msg ++ " (before)" 58 | after = msg ++ " (after)" 59 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/Induction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module HERMIT.Dictionary.Induction 7 | ( -- * Induction 8 | externals 9 | , caseSplitOnR 10 | ) 11 | where 12 | 13 | import Control.Arrow 14 | import Control.Monad 15 | import Data.String 16 | 17 | import HERMIT.Context 18 | import HERMIT.Core 19 | import HERMIT.External 20 | import HERMIT.GHC 21 | import HERMIT.Kure 22 | import HERMIT.Lemma 23 | import HERMIT.Name 24 | 25 | import HERMIT.Dictionary.Common 26 | import HERMIT.Dictionary.Local.Case hiding (externals) 27 | import HERMIT.Dictionary.Undefined hiding (externals) 28 | 29 | ------------------------------------------------------------------------------ 30 | 31 | externals :: [External] 32 | externals = 33 | [ external "induction" (promoteClauseR . caseSplitOnR True . cmpHN2Var :: HermitName -> RewriteH LCore) 34 | [ "Induct on specified value quantifier." ] 35 | , external "prove-by-cases" (promoteClauseR . caseSplitOnR False . cmpHN2Var :: HermitName -> RewriteH LCore) 36 | [ "Case split on specified value quantifier." ] 37 | ] 38 | 39 | ------------------------------------------------------------------------------ 40 | 41 | -- TODO: revisit design here to make one level 42 | caseSplitOnR :: Bool -> (Id -> Bool) -> RewriteH Clause 43 | caseSplitOnR induction idPred = withPatFailMsg "induction can only be performed on universally quantified terms." $ do 44 | let p b = idPred b && isId b 45 | (bs, cl) <- arr collectQs 46 | guardMsg (any p bs) "specified identifier is not universally quantified in this lemma. (Induction cannot be performed on type quantifiers.)" 47 | let (as,b:bs') = break p bs -- safe because above guard 48 | guardMsg (not (any p bs')) "multiple matching quantifiers." 49 | 50 | ue <- mkUndefinedValT (varType b) -- undefined case 51 | cases <- liftM (ue:) $ constT $ caseExprsForM $ varToCoreExpr b 52 | 53 | let newBs = as ++ bs' 54 | substructural = filter (typeAlphaEq (varType b) . varType) 55 | 56 | go [] = return [] 57 | go (e:es) = do 58 | let cl' = substClause b e cl 59 | fvs = varSetElems $ delVarSetList (localFreeVarsExpr e) newBs 60 | 61 | -- Generate induction hypotheses for the recursive cases. 62 | antes <- if induction 63 | then forM (zip [(0::Int)..] $ substructural fvs) $ \ (i,b') -> 64 | withVarsInScope fvs $ transform $ \ c q -> 65 | let nm = fromString $ "ind-hyp-" ++ show i 66 | in liftM ((nm,) . discardUniVars) $ instClause (boundVars c) (==b) (Var b') q 67 | else return [] 68 | 69 | rs <- go es 70 | return $ mkForall fvs (foldr (uncurry Impl) cl' antes) : rs 71 | 72 | qs <- go cases 73 | 74 | return $ mkForall newBs $ foldr1 Conj qs 75 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/Local/Bind.hs: -------------------------------------------------------------------------------- 1 | module HERMIT.Dictionary.Local.Bind 2 | ( -- * Rewrites on Binding Groups 3 | externals 4 | , nonrecToRecR 5 | , recToNonrecR 6 | ) where 7 | 8 | import HERMIT.Core 9 | import HERMIT.External 10 | import HERMIT.GHC 11 | import HERMIT.Kure 12 | 13 | import HERMIT.Dictionary.Common 14 | 15 | ------------------------------------------------------------------------------ 16 | 17 | -- | Externals for manipulating binding groups. 18 | externals :: [External] 19 | externals = 20 | [ external "nonrec-to-rec" (promoteBindR nonrecToRecR :: RewriteH LCore) 21 | [ "Convert a non-recursive binding into a recursive binding group with a single definition." 22 | , "NonRec v e ==> Rec [Def v e]" ] .+ Shallow 23 | , external "rec-to-nonrec" (promoteBindR recToNonrecR :: RewriteH LCore) 24 | [ "Convert a singleton recursive binding into a non-recursive binding group." 25 | , "Rec [Def v e] ==> NonRec v e, (v not free in e)" ] 26 | ] 27 | 28 | ------------------------------------------------------------------------------ 29 | 30 | -- | @'NonRec' v e@ ==> @'Rec' [(v,e)]@ 31 | nonrecToRecR :: MonadCatch m => Rewrite c m CoreBind 32 | nonrecToRecR = prefixFailMsg "Converting non-recursive binding to recursive binding failed: " $ 33 | withPatFailMsg (wrongExprForm "NonRec v e") $ 34 | do NonRec v e <- idR 35 | guardMsg (isId v) "type variables cannot be defined recursively." 36 | return $ Rec [(v,e)] 37 | 38 | -- | @'Rec' [(v,e)]@ ==> @'NonRec' v e@ 39 | recToNonrecR :: MonadCatch m => Rewrite c m CoreBind 40 | recToNonrecR = prefixFailMsg "Converting singleton recursive binding to non-recursive binding failed: " $ 41 | withPatFailMsg (wrongExprForm "Rec [Def v e]") $ 42 | do Rec [(v,e)] <- idR 43 | guardMsg (v `notElemVarSet` freeIdsExpr e) ("'" ++ unqualifiedName v ++ " is recursively defined.") 44 | return (NonRec v e) 45 | 46 | ------------------------------------------------------------------------------ 47 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/New.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module HERMIT.Dictionary.New where 3 | 4 | import Control.Arrow 5 | 6 | import HERMIT.Core 7 | import HERMIT.Kure 8 | import HERMIT.External 9 | import HERMIT.GHC 10 | import HERMIT.ParserCore 11 | 12 | import HERMIT.Dictionary.Local.Let hiding (externals) 13 | 14 | externals :: [External] 15 | externals = map ((.+ Experiment) . (.+ TODO)) 16 | [ external "var" (promoteExprT . isVar :: String -> TransformH LCore ()) 17 | [ "var ' returns successfully for variable v, and fails otherwise." 18 | , "Useful in combination with \"when\", as in: when (var v) r" 19 | ] .+ Predicate 20 | , external "nonrec-intro" ((\ s str -> promoteCoreR (nonRecIntro s str)) :: String -> CoreString -> RewriteH LCore) 21 | [ "Introduce a new non-recursive binding. Only works at Expression or Program nodes." 22 | , "nonrec-into 'v [| e |]" 23 | , "body ==> let v = e in body" 24 | ] .+ Introduce .+ Shallow 25 | -- , external "prog-nonrec-intro" ((\ nm core -> promoteProgR $ progNonRecIntro nm core) :: String -> CoreString -> RewriteH Core) 26 | -- [ "Introduce a new top-level definition." 27 | -- , "prog-nonrec-into 'v [| e |]" 28 | -- , "prog ==> ProgCons (v = e) prog" ] .+ Introduce .+ Shallow 29 | -- , external "let-nonrec-intro" ((\ nm core -> promoteExprR $ letNonRecIntro nm core) :: String -> CoreString -> RewriteH Core) 30 | -- [ "Introduce a new definition as a non-recursive let binding." 31 | -- , "let-nonrec-intro 'v [| e |]" 32 | -- , "body ==> let v = e in body" ] .+ Introduce .+ Shallow 33 | ] 34 | 35 | ------------------------------------------------------------------------------------------------------ 36 | 37 | -- TODO: We might not want to match on TyVars and CoVars here. 38 | -- Probably better to have another predicate that operates on CoreTC, that way it can reach TyVars buried within types. 39 | -- But given the current setup (using Core for most things), changing "var" to operate on CoreTC would make it incompatible with other combinators. 40 | -- I'm not sure how to fix the current setup though. 41 | -- isVar :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => String -> Transform c m CoreExpr () 42 | -- isVar nm = (varT matchName <+ typeT (tyVarT matchName) <+ coercionT (coVarCoT matchName)) 43 | -- >>= guardM 44 | -- where 45 | -- matchName :: Monad m => Transform c m Var Bool 46 | -- matchName = arr (cmpString2Var nm) 47 | 48 | -- TODO: there might be a better module for this 49 | 50 | -- | Test if the current expression is an identifier matching the given name. 51 | isVar :: (ExtendPath c Crumb, MonadCatch m) => String -> Transform c m CoreExpr () 52 | isVar nm = varT (arr $ cmpString2Var nm) >>= guardM 53 | 54 | ------------------------------------------------------------------------------------------------------ 55 | 56 | -- The types of these can probably be generalised after the Core Parser is generalised. 57 | 58 | -- | @prog@ ==> @'ProgCons' (v = e) prog@ 59 | nonRecIntro :: String -> CoreString -> RewriteH Core 60 | nonRecIntro nm expr = parseCoreExprT expr >>= nonRecIntroR nm 61 | -- TODO: if e is not type-correct, then exprType will crash. 62 | -- Proposal: parseCore should check that its result is (locally) well-typed 63 | 64 | 65 | -- -- | @prog@ ==> @'ProgCons' (v = e) prog@ 66 | -- progNonRecIntro :: String -> CoreString -> RewriteH CoreProg 67 | -- progNonRecIntro nm expr = parseCoreExprT expr >>= progNonRecIntroR nm 68 | -- -- TODO: if e is not type-correct, then exprType will crash. 69 | -- -- Proposal: parseCore should check that its result is (locally) well-typed 70 | 71 | -- -- | @body@ ==> @let v = e in body@ 72 | -- letNonRecIntro :: String -> CoreString -> RewriteH CoreExpr 73 | -- letNonRecIntro nm expr = parseCoreExprT expr >>= letNonRecIntroR nm 74 | -- -- TODO: if e is not type-correct, then exprTypeOrKind will crash. 75 | -- -- Proposal: parseCore should check that its result is (locally) well-typed 76 | 77 | 78 | ------------------------------------------------------------------------------------------------------ 79 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/Remembered.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TupleSections #-} 6 | 7 | module HERMIT.Dictionary.Remembered 8 | ( -- * Remembering definitions. 9 | externals 10 | , prefixRemembered 11 | , rememberR 12 | , unfoldRememberedR 13 | , foldRememberedR 14 | , foldAnyRememberedR 15 | , compileRememberedT 16 | ) where 17 | 18 | import Control.Monad 19 | 20 | import qualified Data.Map as Map 21 | import Data.List (isPrefixOf) 22 | import Data.Monoid 23 | 24 | import HERMIT.Context 25 | import HERMIT.Core 26 | import HERMIT.External 27 | import HERMIT.GHC hiding ((<>), (<+>), nest, ($+$)) 28 | import HERMIT.Kure 29 | import HERMIT.Lemma 30 | import HERMIT.Monad 31 | import HERMIT.PrettyPrinter.Common 32 | 33 | import HERMIT.Dictionary.Fold hiding (externals) 34 | import HERMIT.Dictionary.Reasoning hiding (externals) 35 | 36 | ------------------------------------------------------------------------------ 37 | 38 | externals :: [External] 39 | externals = 40 | [ external "remember" (promoteCoreT . rememberR :: LemmaName -> TransformH LCore ()) 41 | [ "Remember the current binding, allowing it to be folded/unfolded in the future." ] .+ Context 42 | , external "unfold-remembered" (promoteExprR . unfoldRememberedR Obligation :: LemmaName -> RewriteH LCore) 43 | [ "Unfold a remembered definition." ] .+ Deep .+ Context 44 | , external "fold-remembered" (promoteExprR . foldRememberedR Obligation :: LemmaName -> RewriteH LCore) 45 | [ "Fold a remembered definition." ] .+ Context .+ Deep 46 | , external "fold-any-remembered" (promoteExprR foldAnyRememberedR :: RewriteH LCore) 47 | [ "Attempt to fold any of the remembered definitions." ] .+ Context .+ Deep 48 | , external "show-remembered" (promoteCoreT . showLemmasT (Just "remembered-") :: PrettyPrinter -> PrettyH LCore) 49 | [ "Display all remembered definitions." ] 50 | ] 51 | 52 | ------------------------------------------------------------------------------ 53 | 54 | prefixRemembered :: LemmaName -> LemmaName 55 | prefixRemembered = ("remembered-" <>) 56 | 57 | -- | Remember a binding with a name for later use. Allows us to look at past definitions. 58 | rememberR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasLemmas m, MonadCatch m) 59 | => LemmaName -> Transform c m Core () 60 | rememberR nm = prefixFailMsg "remember failed: " $ do 61 | Def v e <- setFailMsg "not applied to a binding." $ defOrNonRecT idR idR Def 62 | insertLemmaT (prefixRemembered nm) $ Lemma (mkClause [] (varToCoreExpr v) e) Proven NotUsed 63 | 64 | -- | Unfold a remembered definition (like unfoldR, but looks in stash instead of context). 65 | unfoldRememberedR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) 66 | => Used -> LemmaName -> Rewrite c m CoreExpr 67 | unfoldRememberedR u = prefixFailMsg "Unfolding remembered definition failed: " . forwardT . lemmaBiR u . prefixRemembered 68 | 69 | -- | Fold a remembered definition (like foldR, but looks in stash instead of context). 70 | foldRememberedR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) 71 | => Used -> LemmaName -> Rewrite c m CoreExpr 72 | foldRememberedR u = prefixFailMsg "Folding remembered definition failed: " . backwardT . lemmaBiR u . prefixRemembered 73 | 74 | -- | Fold any of the remembered definitions. 75 | foldAnyRememberedR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) 76 | => Rewrite c m CoreExpr 77 | foldAnyRememberedR = setFailMsg "Fold failed: no definitions could be folded." 78 | $ compileRememberedT >>= runFoldR 79 | 80 | -- | Compile all remembered definitions into something that can be run with `runFoldR` 81 | compileRememberedT :: (LemmaContext c, HasLemmas m, Monad m) => Transform c m x CompiledFold 82 | compileRememberedT = do 83 | qs <- liftM (map lemmaC . Map.elems . Map.filterWithKey (\ k _ -> "remembered-" `isPrefixOf` show k)) getLemmasT 84 | return $ compileFold $ concatMap (map flipEquality . toEqualities) qs -- fold rhs to lhs 85 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/Unfold.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module HERMIT.Dictionary.Unfold 7 | ( externals 8 | , betaReducePlusR 9 | , unfoldR 10 | , unfoldPredR 11 | , unfoldNameR 12 | , unfoldNamesR 13 | , unfoldSaturatedR 14 | , specializeR 15 | ) where 16 | 17 | import Control.Arrow 18 | import Control.Monad 19 | 20 | import HERMIT.Dictionary.Common 21 | import HERMIT.Dictionary.Inline (inlineR) 22 | 23 | import HERMIT.Core 24 | import HERMIT.Context 25 | import HERMIT.External 26 | import HERMIT.GHC 27 | import HERMIT.Kure 28 | import HERMIT.Monad 29 | import HERMIT.Name 30 | 31 | import Prelude hiding (exp) 32 | 33 | ------------------------------------------------------------------------ 34 | 35 | externals :: [External] 36 | externals = 37 | [ external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH LCore) 38 | [ "Perform one or more beta-reductions."] .+ Eval .+ Shallow 39 | , external "unfold" (promoteExprR unfoldR :: RewriteH LCore) 40 | [ "In application f x y z, unfold f." ] .+ Deep .+ Context 41 | , external "unfold" (promoteExprR . unfoldNameR . unOccurrenceName :: OccurrenceName -> RewriteH LCore) 42 | [ "Inline a definition, and apply the arguments; traditional unfold." ] .+ Deep .+ Context 43 | , external "unfold" (promoteExprR . unfoldNamesR . map unOccurrenceName:: [OccurrenceName] -> RewriteH LCore) 44 | [ "Unfold a definition if it is named in the list." ] .+ Deep .+ Context 45 | , external "unfold-saturated" (promoteExprR unfoldSaturatedR :: RewriteH LCore) 46 | [ "Unfold a definition only if the function is fully applied." ] .+ Deep .+ Context 47 | , external "specialize" (promoteExprR specializeR :: RewriteH LCore) 48 | [ "Specialize an application to its type and coercion arguments." ] .+ Deep .+ Context 49 | ] 50 | 51 | ------------------------------------------------------------------------ 52 | 53 | -- | Perform one or more beta reductions. 54 | betaReducePlusR :: MonadCatch m => Rewrite c m CoreExpr 55 | betaReducePlusR = prefixFailMsg "Multi-beta-reduction failed: " $ do 56 | (f,args) <- callT 57 | let (f',args',atLeastOne) = reduceAll f args False 58 | reduceAll (Lam v body) (a:as) _ = reduceAll (substCoreExpr v a body) as True 59 | reduceAll e as b = (e,as,b) 60 | guardMsg atLeastOne "no beta reductions possible." 61 | return $ mkCoreApps f' args' 62 | 63 | -- | A more powerful 'inline'. Matches two cases: 64 | -- Var ==> inlines 65 | -- App ==> inlines the head of the function call for the app tree 66 | unfoldR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c 67 | , ReadBindings c, ReadPath c Crumb, MonadCatch m ) 68 | => Rewrite c m CoreExpr 69 | unfoldR = prefixFailMsg "unfold failed: " (go >>> tryR betaReducePlusR) 70 | where go :: Rewrite c m CoreExpr 71 | go = appAllR go idR <+ inlineR -- this order gives better error messages 72 | 73 | unfoldPredR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb 74 | , MonadCatch m ) 75 | => (Id -> [CoreExpr] -> Bool) -> Rewrite c m CoreExpr 76 | unfoldPredR p = callPredT p >> unfoldR 77 | 78 | unfoldNameR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c 79 | , MonadCatch m ) 80 | => HermitName -> Rewrite c m CoreExpr 81 | unfoldNameR nm = prefixFailMsg ("unfold '" ++ show nm ++ " failed: ") (callNameT nm >> unfoldR) 82 | 83 | unfoldNamesR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c 84 | , MonadCatch m ) 85 | => [HermitName] -> Rewrite c m CoreExpr 86 | unfoldNamesR [] = fail "unfold-names failed: no names given." 87 | unfoldNamesR nms = setFailMsg "unfold-names failed." $ orR (map unfoldNameR nms) 88 | 89 | unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr 90 | unfoldSaturatedR = callSaturatedT >> unfoldR 91 | 92 | specializeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr 93 | specializeR = unfoldPredR (const $ all isTyCoArg) 94 | -------------------------------------------------------------------------------- /src/HERMIT/Dictionary/Unsafe.hs: -------------------------------------------------------------------------------- 1 | module HERMIT.Dictionary.Unsafe 2 | ( externals 3 | , unsafeReplaceR 4 | ) where 5 | 6 | import Control.Monad 7 | 8 | import HERMIT.Core 9 | import HERMIT.Kure 10 | import HERMIT.GHC 11 | import HERMIT.External 12 | import HERMIT.ParserCore 13 | 14 | import Prelude hiding (exp) 15 | 16 | ------------------------------------------------------------------------ 17 | 18 | externals :: [External] 19 | externals = map (.+ Unsafe) 20 | [ external "unsafe-replace" (promoteExprR . unsafeReplaceR :: CoreString -> RewriteH LCore) 21 | [ "replace the currently focused expression with a new expression" 22 | , "DOES NOT ensure that free variables in the replacement expression are in scope" ] 23 | ] 24 | 25 | ------------------------------------------------------------------------ 26 | 27 | unsafeReplaceR :: CoreString -> RewriteH CoreExpr 28 | unsafeReplaceR core = 29 | transform $ \ c e -> do 30 | e' <- parseCore core c 31 | guardMsg (eqType (exprKindOrType e) (exprKindOrType e')) "expression types differ." 32 | return e' 33 | 34 | ------------------------------------------------------------------------ 35 | -------------------------------------------------------------------------------- /src/HERMIT/Libraries/Int.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module HERMIT.Libraries.Int where 5 | 6 | import Control.Arrow 7 | 8 | import qualified Data.Map as M 9 | 10 | import HERMIT.GHC hiding (intTy) 11 | import HERMIT.Kure 12 | import HERMIT.Lemma 13 | import HERMIT.Name 14 | import HERMIT.Dictionary.Common 15 | import HERMIT.Dictionary.GHC 16 | 17 | {- 18 | Defines the following lemmas: 19 | 20 | forall n m. (m == n) = (n == m) 21 | forall n m. (m < n ) = (n > m) 22 | forall n m. (m <= n) = (n >= m) 23 | forall n m. (m >= n) = (n < m) 24 | 25 | forall n m. (m <= n) = False => (m == n) = False 26 | forall n m. (m == n) = True => (m <= n) = True 27 | 28 | forall n m. (min n m) = (min m n) 29 | forall n m. (max n m) = (max m n) 30 | forall n m. (min n m <= n) = True 31 | forall n m. (max n m >= n) = True 32 | -} 33 | 34 | lemmas :: LemmaLibrary 35 | lemmas = do 36 | intTy <- findTypeT "Prelude.Int" 37 | 38 | nId <- constT $ newIdH "n" intTy 39 | mId <- constT $ newIdH "m" intTy 40 | 41 | let n = varToCoreExpr nId 42 | m = varToCoreExpr mId 43 | #if __GLASGOW_HASKELL__ > 710 44 | appTo i e = return $ mkCoreApp (text "appTo") (varToCoreExpr i) e 45 | #else 46 | appTo i e = return $ mkCoreApp (varToCoreExpr i) e 47 | #endif 48 | appToInt i = appTo i (Type intTy) 49 | appToDict e = do 50 | let (aTys, _) = splitFunTys (exprType e) 51 | case aTys of 52 | #if __GLASGOW_HASKELL__ > 710 53 | (ty:_) | isDictTy ty -> return ty >>> buildDictionaryT >>> arr (mkCoreApp (text "appToDict") e) 54 | #else 55 | (ty:_) | isDictTy ty -> return ty >>> buildDictionaryT >>> arr (mkCoreApp e) 56 | #endif 57 | _ -> fail "first argument is not a dictionary." 58 | 59 | appMN e = mkCoreApps e [m,n] 60 | appNM e = mkCoreApps e [n,m] 61 | mkEL l r = mkL (Equiv l r) 62 | mkL cl = Lemma (mkForall [mId,nId] cl) BuiltIn NotUsed 63 | mkIL nm al ar cl cr = mkL (Impl nm (Equiv al ar) (Equiv cl cr)) 64 | 65 | eqE <- findIdT "Data.Eq.==" >>= appToInt >>= appToDict 66 | 67 | gtE <- findIdT "Data.Ord.>" >>= appToInt >>= appToDict 68 | ltE <- findIdT "Data.Ord.<" >>= appToInt >>= appToDict 69 | gteE <- findIdT "Data.Ord.>=" >>= appToInt >>= appToDict 70 | lteE <- findIdT "Data.Ord.<=" >>= appToInt >>= appToDict 71 | minE <- findIdT "Data.Ord.min" >>= appToInt >>= appToDict 72 | maxE <- findIdT "Data.Ord.max" >>= appToInt >>= appToDict 73 | 74 | trueE <- varToCoreExpr <$> findIdT "Data.Bool.True" 75 | falseE <- varToCoreExpr <$> findIdT "Data.Bool.False" 76 | 77 | return $ M.fromList 78 | [ ("EqCommutativeInt", mkEL (appMN eqE) (appNM eqE)) 79 | , ("LtGtInt", mkEL (appMN ltE) (appNM gtE)) 80 | , ("LteGteInt", mkEL (appMN lteE) (appNM gteE)) 81 | , ("GteLtInt", mkEL (appMN gteE) (appNM ltE)) 82 | , ("LteFalseImpliesEqFalseInt", mkIL "LteFalse" (appMN lteE) falseE (appMN eqE) falseE) 83 | , ("EqTrueImpliesLteTrueInt", mkIL "EqTrue" (appMN eqE) trueE (appMN lteE) trueE) 84 | , ("MinCommutativeInt", mkEL (appMN minE) (appNM minE)) 85 | , ("MaxCommutativeInt", mkEL (appMN maxE) (appNM maxE)) 86 | , ("MinLteInt", mkEL (mkCoreApps lteE [appNM minE, n]) trueE) 87 | , ("MaxGteInt", mkEL (mkCoreApps gteE [appNM maxE, n]) trueE) 88 | ] 89 | -------------------------------------------------------------------------------- /src/HERMIT/Libraries/WW.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module HERMIT.Libraries.WW (lemmas) where 5 | 6 | import HERMIT.Lemma 7 | import HERMIT.GHC hiding (($$), (<>)) 8 | import HERMIT.Kure 9 | import HERMIT.Name 10 | 11 | import HERMIT.Dictionary.Common 12 | import HERMIT.Dictionary.Function 13 | import HERMIT.Dictionary.GHC 14 | import HERMIT.Dictionary.Reasoning 15 | 16 | import Prelude hiding (abs) 17 | 18 | lemmas :: LemmaLibrary 19 | lemmas = workerWrapperLemmaT 20 | 21 | ------------------------------------------------- 22 | 23 | -- | worker/wrapper 24 | -- 25 | -- abs :: B -> A 26 | -- rep :: A -> B 27 | -- f :: A -> A 28 | -- 29 | -- abs . rep = id \/ abs . rep . f = f \/ fix (abs . rep . f) = fix f 30 | ----------------------------------------------------------------------------- 31 | -- fix f = abs (fix (rep . f . abs)) = abs (rep (fix f)) 32 | -- ^ 1B ^ ^ 2B ^ 33 | -- 34 | workerWrapperLemmaT :: LemmaLibrary 35 | workerWrapperLemmaT = do 36 | idId <- findIdT "Data.Function.id" 37 | fixId <- findIdT "Data.Function.fix" 38 | contextonlyT $ \ c -> do 39 | -- aTv :: Var, aTy :: Type 40 | [aTv, bTv] <- mapM newTyVar ["a","b"] 41 | 42 | let [aTy, bTy] = map mkTyVarTy [aTv, bTv] 43 | 44 | abs <- newIdH "abs" (bTy --> aTy) 45 | rep <- newIdH "rep" (aTy --> bTy) 46 | f <- newIdH "f" (aTy --> aTy) 47 | 48 | -- abs . rep = id 49 | lhsA <- inContextM c $ buildCompositionT (toCE abs) (toCE rep) 50 | #if __GLASGOW_HASKELL__ > 710 51 | let preA = lhsA === mkCoreApp (text "workerWrapperLemmaT") (toCE idId) (toCE aTv) 52 | #else 53 | let preA = lhsA === mkCoreApp (toCE idId) (toCE aTv) 54 | #endif 55 | 56 | -- abs . rep . f = f 57 | repAfterF <- inContextM c $ buildCompositionT (toCE rep) (toCE f) 58 | lhsB <- inContextM c $ buildCompositionT (toCE abs) repAfterF 59 | let preB = lhsB === f 60 | 61 | -- fix (abs . rep . f) = fix f 62 | lhsC <- fixId $$ lhsB 63 | fixf <- fixId $$ f 64 | let preC = lhsC === fixf 65 | 66 | -- 1B 67 | fAfterAbs <- inContextM c $ buildCompositionT (toCE f) (toCE abs) 68 | comp1B <- inContextM c $ buildCompositionT (toCE rep) fAfterAbs 69 | rhs1B <- (abs $$) =<< (fixId $$ comp1B) 70 | let oneB = fixf === rhs1B 71 | 72 | -- 2B 73 | rhs2B <- (abs $$) =<< (rep $$ fixf) 74 | let twoB = fixf === rhs2B 75 | 76 | return $ mconcat 77 | [ newLemma "ww-split-1B" $ 78 | mkForall [aTv, bTv, abs, rep, f] $ 79 | ("ww-split-1B-antecedent", preA \/ preB \/ preC) ==> oneB 80 | , newLemma "ww-split-2B" $ 81 | mkForall [aTv, bTv, abs, rep, f] $ 82 | ("ww-split-1B-antecedent", preA \/ preB \/ preC) ==> twoB 83 | ] 84 | 85 | ------------------------------------------------- 86 | 87 | newTyVar :: MonadUnique m => String -> m TyVar 88 | newTyVar nm = newTyVarH nm liftedTypeKind 89 | 90 | ------------------------------------------------- 91 | -------------------------------------------------------------------------------- /src/HERMIT/Plugin/Display.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module HERMIT.Plugin.Display 4 | ( showDisplay 5 | , printDisplay 6 | , ps_putStr 7 | , ps_putStrLn 8 | ) where 9 | 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | 13 | import Data.Maybe (fromMaybe) 14 | 15 | import HERMIT.Kernel (queryK, CommitMsg(..)) 16 | import HERMIT.Kure 17 | import HERMIT.Plugin.Types 18 | import HERMIT.PrettyPrinter.Common 19 | 20 | import System.IO 21 | 22 | showDisplay :: Maybe PathH -> PluginM DocH 23 | showDisplay window = do 24 | k <- asks pr_kernel 25 | st <- get 26 | let ast = ps_cursor st 27 | ppOpts = pOptions $ ps_pretty st 28 | d <- queryK k (extractT $ pathT (fromMaybe mempty window) $ liftPrettyH ppOpts $ pLCoreTC $ ps_pretty st) 29 | Never (mkKernelEnv st) ast 30 | return $ snd d -- discard new AST, assuming pretty printer won't create one 31 | 32 | -- TODO: rm 33 | printDisplay :: Maybe Handle -> Maybe PathH -> PluginM () 34 | printDisplay mbh window = do 35 | doc <- showDisplay window 36 | st <- get 37 | let ppOpts = pOptions $ ps_pretty st 38 | h = fromMaybe stdout mbh 39 | liftIO $ ps_render st h ppOpts $ Right $ doc 40 | 41 | -- TODO: rm 42 | ps_putStr :: (MonadIO m, MonadState PluginState m) => String -> m () 43 | ps_putStr str = do 44 | st <- get 45 | liftIO $ ps_render st stdout (pOptions $ ps_pretty st) (Left str) 46 | 47 | -- TODO: rm 48 | ps_putStrLn :: (MonadIO m, MonadState PluginState m) => String -> m () 49 | ps_putStrLn = ps_putStr . (++"\n") 50 | 51 | -------------------------------------------------------------------------------- /src/HERMIT/PrettyPrinter/GHC.hs: -------------------------------------------------------------------------------- 1 | -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites. 2 | module HERMIT.PrettyPrinter.GHC 3 | ( -- * GHC's standard Pretty-Printer for GHC Core 4 | externals 5 | , pretty 6 | , ppCoreTC 7 | , ppModGuts 8 | , ppCoreProg 9 | , ppCoreBind 10 | , ppCoreExpr 11 | , ppCoreAlt 12 | , ppKindOrType 13 | , ppCoercion 14 | ) 15 | where 16 | 17 | import Control.Arrow hiding ((<+>)) 18 | 19 | import Data.Char (isSpace) 20 | import Data.Default.Class 21 | 22 | import HERMIT.Core 23 | import HERMIT.External 24 | import HERMIT.GHC hiding ((<+>), (<>), char, text, parens, hsep, empty) 25 | import HERMIT.Kure 26 | 27 | import HERMIT.PrettyPrinter.Common 28 | 29 | import Text.PrettyPrint.MarkedHughesPJ as PP 30 | 31 | --------------------------------------------------------------------------- 32 | 33 | externals :: [External] 34 | externals = [ external "ghc" pretty ["GHC pretty printer."] ] 35 | 36 | pretty :: PrettyPrinter 37 | pretty = PP { pLCoreTC = promoteT ppCoreTC -- TODO 38 | , pOptions = def 39 | , pTag = "ghc" 40 | } 41 | 42 | -- | This pretty printer is just a reflection of GHC's standard pretty printer. 43 | ppCoreTC :: PrettyH CoreTC 44 | ppCoreTC = 45 | promoteExprT ppCoreExpr 46 | <+ promoteProgT ppCoreProg 47 | <+ promoteBindT ppCoreBind 48 | <+ promoteDefT ppCoreDef 49 | <+ promoteModGutsT ppModGuts 50 | <+ promoteAltT ppCoreAlt 51 | <+ promoteTypeT ppKindOrType 52 | <+ promoteCoercionT ppCoercion 53 | 54 | -- Use for any GHC structure. 55 | ppSDoc :: Outputable a => PrettyH a 56 | ppSDoc = do dynFlags <- constT getDynFlags 57 | arr (toDoc . showPpr dynFlags) 58 | where toDoc s | any isSpace s = parens (text s) 59 | | otherwise = text s 60 | 61 | ppModGuts :: PrettyH ModGuts 62 | ppModGuts = mg_binds ^>> ppSDoc 63 | 64 | ppCoreProg :: PrettyH CoreProg 65 | ppCoreProg = progToBinds ^>> ppSDoc 66 | 67 | ppCoreExpr :: PrettyH CoreExpr 68 | ppCoreExpr = ppSDoc 69 | 70 | ppCoreBind :: PrettyH CoreBind 71 | ppCoreBind = ppSDoc 72 | 73 | ppCoreAlt :: PrettyH CoreAlt 74 | ppCoreAlt = ppSDoc 75 | 76 | ppCoreDef :: PrettyH CoreDef 77 | ppCoreDef = defT ppSDoc ppCoreExpr $ \ i e -> i <+> char '=' <+> e 78 | 79 | ppKindOrType :: PrettyH Type 80 | ppKindOrType = ppSDoc 81 | 82 | ppCoercion :: PrettyH Coercion 83 | ppCoercion = ppSDoc 84 | 85 | {- TODO: lemma pp for GHC-style 86 | ppForallQuantification :: PrettyH [Var] 87 | ppForallQuantification = 88 | do vs <- mapT ppSDoc 89 | if null vs 90 | then return empty 91 | else return $ text "forall" <+> hsep vs <> text "." 92 | -} 93 | 94 | --------------------------------------------------------------------------- 95 | -------------------------------------------------------------------------------- /src/HERMIT/PrettyPrinter/Glyphs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | module HERMIT.PrettyPrinter.Glyphs where 7 | 8 | import Data.Semigroup (Semigroup(..)) 9 | import Data.Typeable 10 | 11 | import HERMIT.Kure 12 | import HERMIT.External 13 | import HERMIT.PrettyPrinter.Common 14 | 15 | import GHC.Generics 16 | 17 | import System.Console.ANSI 18 | 19 | -- | Glyph 20 | data Glyph = Glyph { gText :: String 21 | , gStyle :: Maybe SyntaxForColor 22 | } deriving Show 23 | 24 | -- | Glyphs 25 | newtype Glyphs = Glyphs [Glyph] deriving (Generic, Show) 26 | 27 | withStyle :: Maybe SyntaxForColor -> String -> IO () 28 | withStyle Nothing str = putStr str 29 | withStyle (Just sty) str = do 30 | setSGR $ styleSGR sty 31 | putStr str 32 | setSGR [Reset] 33 | 34 | withNoStyle :: Maybe SyntaxForColor -> String -> IO () 35 | withNoStyle _ str = putStr str 36 | 37 | styleSGR :: SyntaxForColor -> [SGR] 38 | styleSGR KeywordColor = [simpleColor Blue] 39 | styleSGR SyntaxColor = [simpleColor Red] 40 | styleSGR IdColor = [] 41 | styleSGR CoercionColor = [simpleColor Yellow] 42 | styleSGR TypeColor = [simpleColor Green] 43 | styleSGR LitColor = [simpleColor Cyan] 44 | styleSGR WarningColor = [SetColor Background Vivid Yellow 45 | ,SetColor Foreground Dull Black 46 | ] 47 | 48 | simpleColor :: Color -> SGR 49 | simpleColor = SetColor Foreground Vivid 50 | 51 | instance RenderSpecial Glyphs where 52 | renderSpecial sym = Glyphs [ Glyph [ch] (Just style) ] 53 | where Unicode ch = renderSpecial sym 54 | style = 55 | case sym of 56 | TypeSymbol -> TypeColor 57 | TypeBindSymbol -> TypeColor 58 | _ -> SyntaxColor 59 | 60 | instance Monoid Glyphs where 61 | mempty = Glyphs mempty 62 | mappend = (<>) 63 | 64 | instance Semigroup Glyphs where 65 | Glyphs rs1 <> Glyphs rs2 = 66 | Glyphs . flattenGlyphs . mergeGlyphs $ rs1 ++ rs2 67 | 68 | flattenGlyphs :: [Glyph] -> [Glyph] 69 | flattenGlyphs = go Nothing 70 | where go :: Maybe SyntaxForColor -> [Glyph] -> [Glyph] 71 | go _ [] = [] 72 | go s (Glyph str Nothing:r) = Glyph str s : go s r 73 | go _ (Glyph [] s@Just{}:r) = go s r 74 | go s (g:r) = g : go s r 75 | 76 | mergeGlyphs :: [Glyph] -> [Glyph] 77 | mergeGlyphs [] = [] 78 | mergeGlyphs [r] = [r] 79 | mergeGlyphs (g:h:r) = case merge g h of 80 | Left g' -> mergeGlyphs (g':r) 81 | Right (g',h') -> g' : mergeGlyphs (h':r) 82 | where merge (Glyph s1 Nothing) (Glyph s2 Nothing) = 83 | Left $ Glyph (s1 ++ s2) Nothing 84 | merge (Glyph [] Just{}) g2@(Glyph [] Just{}) = Left g2 85 | merge g1 g2 = Right (g1,g2) 86 | 87 | instance RenderCode Glyphs where 88 | rPutStr txt = Glyphs [ Glyph txt Nothing, Glyph [] (Just IdColor) ] 89 | rDoHighlight _ [] = mempty 90 | rDoHighlight _ (Color col:_) = Glyphs [Glyph [] (Just col)] 91 | rDoHighlight o (_:rest) = rDoHighlight o rest 92 | 93 | -- External Instances 94 | data TransformLCoreGlyphsBox = TransformLCoreGlyphsBox (TransformH LCore Glyphs) deriving Typeable 95 | 96 | instance Extern (TransformH LCore Glyphs) where 97 | type Box (TransformH LCore Glyphs) = TransformLCoreGlyphsBox 98 | box = TransformLCoreGlyphsBox 99 | unbox (TransformLCoreGlyphsBox i) = i 100 | 101 | data TransformLCoreTCGlyphsBox = TransformLCoreTCGlyphsBox (TransformH LCoreTC Glyphs) deriving Typeable 102 | 103 | instance Extern (TransformH LCoreTC Glyphs) where 104 | type Box (TransformH LCoreTC Glyphs) = TransformLCoreTCGlyphsBox 105 | box = TransformLCoreTCGlyphsBox 106 | unbox (TransformLCoreTCGlyphsBox i) = i 107 | -------------------------------------------------------------------------------- /src/HERMIT/Shell/Dictionary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module HERMIT.Shell.Dictionary 3 | ( mkDictionary 4 | , addToDictionary 5 | , pp_dictionary 6 | ) where 7 | 8 | import Data.Dynamic 9 | import Data.List 10 | import Data.Map (Map, fromList, toList, fromListWith) 11 | 12 | import HERMIT.External 13 | 14 | import HERMIT.PrettyPrinter.Common 15 | import qualified HERMIT.PrettyPrinter.AST as AST 16 | import qualified HERMIT.PrettyPrinter.Clean as Clean 17 | import qualified HERMIT.PrettyPrinter.GHC as GHCPP 18 | 19 | -------------------------------------------------------------------------- 20 | 21 | -- | A 'Dictionary' is a collection of 'Dynamic's. 22 | -- Looking up a 'Dynamic' (via an 'ExternalName' key) returns a list, as there 23 | -- can be multiple 'Dynamic's with the same name. 24 | type Dictionary = Map ExternalName [Dynamic] 25 | 26 | -- | Build a 'Data.Map' from names to 'Dynamic' values. 27 | toDictionary :: [External] -> Dictionary 28 | toDictionary = fromListWith (++) . map toEntry 29 | 30 | toEntry :: External -> (ExternalName, [Dynamic]) 31 | toEntry e = (externName e, [externDyn e]) 32 | 33 | addToDictionary :: External -> Dictionary -> Dictionary 34 | addToDictionary ex d = fromListWith (++) $ toEntry ex : toList d 35 | 36 | -- | Create a dictionary from a list of 'External's. 37 | mkDictionary :: [External] -> Dictionary 38 | mkDictionary externs = toDictionary externs' 39 | where 40 | msg = layoutTxt 60 (map (show . fst) dictionaryOfTags) 41 | externs' = externs ++ 42 | [ external "help" (help_command externs' "help") 43 | [ "(this message)" ] .+ Query .+ Shell 44 | , external "help" (help_command externs') 45 | ([ "help ||categories|all|" 46 | , "Displays help about a command, or all commands in a category." 47 | , "Multiple items may match." 48 | , "" 49 | , "Categories: " ++ head msg 50 | ] ++ map (" " ++) (tail msg)) .+ Query .+ Shell 51 | ] 52 | 53 | -------------------------------------------------------------------------- 54 | 55 | -- | The pretty-printing dictionaries. 56 | pp_dictionary :: Map String PrettyPrinter 57 | pp_dictionary = fromList 58 | [ ("clean", Clean.pretty) 59 | , ("ast", AST.pretty) 60 | , ("ghc", GHCPP.pretty) 61 | ] 62 | 63 | -------------------------------------------------------------------------- 64 | 65 | make_help :: [External] -> [String] 66 | make_help = concatMap snd . toList . toHelp 67 | 68 | help_command :: [External] -> String -> String 69 | help_command exts m 70 | | [(ct :: CmdTag,"")] <- reads m 71 | = unlines $ make_help $ filter (tagMatch ct) exts 72 | help_command exts "all" 73 | = unlines $ make_help exts 74 | help_command _ "categories" = unlines $ 75 | [ "Categories" ] ++ 76 | [ "----------" ] ++ 77 | [ txt ++ " " ++ replicate (16 - length txt) '.' ++ " " ++ desc 78 | | (cmd,desc) <- dictionaryOfTags 79 | , let txt = show cmd 80 | ] 81 | 82 | help_command exts m = unlines $ make_help $ pathPrefix m 83 | where pathPrefix p = filter (isInfixOf p . externName) exts 84 | 85 | layoutTxt :: Int -> [String] -> [String] 86 | layoutTxt n (w1:w2:ws) | length w1 + length w2 >= n = w1 : layoutTxt n (w2:ws) 87 | | otherwise = layoutTxt n ((w1 ++ " " ++ w2) : ws) 88 | layoutTxt _ other = other 89 | 90 | -------------------------------------------------------------------------- 91 | 92 | -------------------------------------------------------------------------------- /src/HERMIT/Shell/ShellEffect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | module HERMIT.Shell.ShellEffect 12 | ( ShellEffect(..) 13 | , ShellEffectBox(..) 14 | , performShellEffect 15 | , dumpT 16 | , dump 17 | ) where 18 | 19 | import Control.Monad.Error.Class (MonadError(..)) 20 | import Control.Monad.IO.Class (MonadIO(..)) 21 | import Control.Monad.Reader (ask) 22 | import Control.Monad.State (MonadState(..), gets) 23 | 24 | import Data.Typeable 25 | 26 | import HERMIT.External 27 | import HERMIT.Kure 28 | import HERMIT.PrettyPrinter.Common 29 | 30 | import HERMIT.Plugin.Renderer 31 | import HERMIT.Plugin.Types 32 | 33 | import HERMIT.Shell.Types 34 | 35 | import System.IO 36 | 37 | ---------------------------------------------------------------------------------- 38 | 39 | data ShellEffect :: * -> * where 40 | Abort :: ShellEffect () 41 | CLSModify :: CLT IO a -> ShellEffect a 42 | PluginComp :: PluginM () -> ShellEffect () 43 | Continue :: ShellEffect () 44 | Resume :: ShellEffect () 45 | FmapShellEffect :: (a -> b) -> ShellEffect a -> ShellEffect b 46 | 47 | instance Functor ShellEffect where 48 | fmap = FmapShellEffect 49 | 50 | data ShellEffectBox where 51 | ShellEffectBox :: Typeable a => ShellEffect a -> ShellEffectBox 52 | 53 | instance Typeable a => Extern (ShellEffect a) where 54 | type Box (ShellEffect _a) = ShellEffectBox 55 | box = ShellEffectBox 56 | unbox (ShellEffectBox i) = 57 | case cast i of 58 | Just res -> res 59 | Nothing -> error "Extern -- unbox: casting of shell effect failed." 60 | 61 | ---------------------------------------------------------------------------------- 62 | 63 | performShellEffect :: (MonadCatch m, CLMonad m) => ShellEffect a -> m a 64 | performShellEffect Abort = abort 65 | performShellEffect Resume = announceUnprovens >> gets cl_cursor >>= resume 66 | performShellEffect Continue = announceUnprovens >> get >>= continue 67 | 68 | performShellEffect (CLSModify m) = clm2clt m 69 | 70 | performShellEffect (PluginComp m) = pluginM m 71 | performShellEffect (FmapShellEffect f s) = fmap f (performShellEffect s) 72 | 73 | dumpT :: FilePath -> PrettyPrinter -> String -> Int -> TransformH DocH () 74 | dumpT fileName pp renderer width = do 75 | case lookup renderer shellRenderers of 76 | Just r -> do doc <- idR 77 | liftIO $ do h <- openFile fileName WriteMode 78 | r h ((pOptions pp) { po_width = width }) (Right doc) 79 | hClose h 80 | _ -> fail "dump: bad renderer option" 81 | 82 | dump :: FilePath -> PrettyPrinter -> String -> Int -> CLT IO () 83 | dump fileName pp renderer width = do 84 | st <- get 85 | env <- ask 86 | let st' = setPrettyOpts (setPretty st pp) $ (cl_pretty_opts st) { po_width = width } 87 | (er, _st'') <- runCLT env st' $ do 88 | pluginM (changeRenderer renderer) 89 | h <- liftIO $ openFile fileName WriteMode 90 | printWindowAlways (Just h) 91 | liftIO $ hClose h 92 | either throwError return er 93 | 94 | -------------------------------------------------------------------------------- /src/HERMIT/Syntax.hs: -------------------------------------------------------------------------------- 1 | module HERMIT.Syntax 2 | ( -- * Utility Predicates for lexing Identifiers 3 | quoteShow, 4 | -- ** Lexing HERMIT Scripts 5 | isScriptIdFirstChar, 6 | isScriptIdChar, 7 | isScriptInfixIdChar, 8 | -- ** Lexing Core Fragments 9 | isCoreIdFirstChar, 10 | isCoreIdChar, 11 | isCoreInfixIdChar 12 | ) where 13 | 14 | import Data.Char (isAlphaNum, isAlpha) 15 | 16 | --------------------------------------------------------------------- 17 | 18 | -- | Characters that are valid as the leading character of an identifier in a HERMIT script. 19 | isScriptIdFirstChar :: Char -> Bool 20 | isScriptIdFirstChar c = isAlphaNum c || c `elem` "$_:." 21 | 22 | -- | Characters that are valid identifier elements (a superset of 'isScriptIdFirstChar') in a HERMIT script. 23 | isScriptIdChar :: Char -> Bool 24 | isScriptIdChar c = isScriptIdFirstChar c || isScriptInfixIdChar c || c `elem` "'" 25 | -- infix identifiers can appear in dictionary names 26 | -- square brackets can appear in dictionary names (specifically, list instances). However, we don't include them here because that would require us to always place spaces around [ ] when defining lists. As a work-around, the user can place "" around any such names. 27 | 28 | -- | Characters that are valid in infix operators in a HERMIT script. 29 | isScriptInfixIdChar :: Char -> Bool 30 | isScriptInfixIdChar c = c `elem` infixOperatorSymbols 31 | -- old: "!£$%^&*-+=@#<>?/.:|" 32 | 33 | --------------------------------------------------------------------- 34 | 35 | -- | Chars that are valid as the leading character of an identifier in a Core fragment. 36 | isCoreIdFirstChar :: Char -> Bool 37 | isCoreIdFirstChar c = c `elem` "_$[]:.=" || isAlpha c 38 | 39 | -- | Characters that are valid identifier elements (a superset of 'isCoreIdFirstChar') in a Core fragment. 40 | isCoreIdChar :: Char -> Bool 41 | isCoreIdChar c = isAlphaNum c || isCoreIdFirstChar c || isCoreInfixIdChar c || c `elem` "'[]" 42 | -- infix identifiers can appear in dictionary names 43 | -- square brackets can appear in dictionary names (specifically, list instances) 44 | 45 | -- | Characters that are valid in infix operators in a Core fragment. 46 | isCoreInfixIdChar :: Char -> Bool 47 | isCoreInfixIdChar c = c `elem` infixOperatorSymbols 48 | -- old: "+*/._-:<>" 49 | 50 | --------------------------------------------------------------------- 51 | 52 | -- TODO: Should the set of infix operator symobls be common to both HERMIT scripts and Core fragments? 53 | -- I'm pretty sure the old definition of isCoreInfixIdChar was too limited at least. 54 | 55 | infixOperatorSymbols :: [Char] 56 | infixOperatorSymbols = "!£$%^&*-+=@#<>?/.:|" 57 | 58 | --------------------------------------------------------------------- 59 | 60 | quoteShow :: Show a => a -> String 61 | quoteShow x = if all isScriptIdChar s then s else show s 62 | where s = show x 63 | -------------------------------------------------------------------------------- /src/HERMIT/Utilities.hs: -------------------------------------------------------------------------------- 1 | module HERMIT.Utilities 2 | ( -- * Utilities 3 | nodups 4 | , dups 5 | , dupsBy 6 | , soleElement 7 | , equivalentBy 8 | , equivalent 9 | , whenJust 10 | , maybeM 11 | ) where 12 | 13 | ------------------------------------------------------------------------------ 14 | 15 | -- | Determine if a list contains no duplicated elements. 16 | nodups :: Eq a => [a] -> Bool 17 | nodups [] = True 18 | nodups (a:as) = (a `notElem` as) && nodups as 19 | 20 | -- | Generalisation of 'dups' to an arbitrary equality predicate. 21 | dupsBy :: (a -> a -> Bool) -> [a] -> [a] 22 | dupsBy _ [] = [] 23 | dupsBy p (a:as) = let ds = dupsBy p as 24 | in if any (p a) as 25 | then a : ds 26 | else ds 27 | 28 | -- | Discard the last occurrence of each element in the list. Thus the returned list contains only the duplicated elements. 29 | dups :: Eq a => [a] -> [a] 30 | dups = dupsBy (==) 31 | 32 | soleElement :: Monad m => [a] -> m a 33 | soleElement [] = fail "soleElement: list is empty." 34 | soleElement [a] = return a 35 | soleElement _ = fail "soleElement: multiple elements found." 36 | 37 | ------------------------------------------------------------------------------ 38 | 39 | -- Drew: surely this exists generally somewhere? 40 | -- for instance: 41 | -- equivalentBy ((==) `on` length) :: [[a]] -> Bool 42 | -- checks if all lists have the same length 43 | 44 | -- | A generalisation of 'equivalent' to any equivalence relation. 45 | -- @equivalent = equivalentBy (==)@ 46 | equivalentBy :: (a -> a -> Bool) -> [a] -> Bool 47 | equivalentBy _ [] = True 48 | equivalentBy eq (x:xs) = all (eq x) xs 49 | 50 | -- | Determine if all elements of a list are equal. 51 | equivalent :: Eq a => [a] -> Bool 52 | equivalent = equivalentBy (==) 53 | 54 | ------------------------------------------------------------------------------ 55 | 56 | -- | Perform the monadic action only in the 'Just' case. 57 | whenJust :: Monad m => (a -> m ()) -> Maybe a -> m () 58 | whenJust f = maybe (return ()) f 59 | 60 | -- | Lift a 'Maybe' into an arbitrary monad, using 'return' or 'fail'. 61 | maybeM :: Monad m => String -> Maybe a -> m a 62 | maybeM msg = maybe (fail msg) return 63 | 64 | ------------------------------------------------------------------------------ 65 | -------------------------------------------------------------------------------- /tests/README.md: -------------------------------------------------------------------------------- 1 | Run examples en masse with: 2 | 3 | cabal test 4 | 5 | If you're using `cabal-install-1.20` or later, you can see the tests run live with: 6 | 7 | cabal test --show-details=streaming 8 | 9 | To update a golden file, delete it from the `golden/` directory, re-run the tests, 10 | and commit. 11 | -------------------------------------------------------------------------------- /tests/dump/.keep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ku-fpg/hermit/3e7be430fae74a9e3860b8b574f36efbf9648dec/tests/dump/.keep -------------------------------------------------------------------------------- /tests/golden/golden-ghc-7103/last_Last_hs_Last_hss.ref: -------------------------------------------------------------------------------- 1 | ===================== Welcome to HERMIT ====================== 2 | HERMIT is a toolkit for the interactive transformation of GHC 3 | core language programs. Documentation on HERMIT can be found 4 | on the HERMIT web page at: 5 | http://www.ittc.ku.edu/csdl/fpg/software/hermit.html 6 | 7 | You have just loaded the interactive shell. To exit, type 8 | "abort" or "resume" to abort or resume GHC compilation. 9 | 10 | Type "help" for instructions on how to list or search the 11 | available HERMIT commands. 12 | 13 | To get started, you could try the following: 14 | - type "binding-of 'foo", where "foo" is a function 15 | defined in the module; 16 | - type "set-pp-type Show" to display full type information; 17 | - type "info" for more information about the current node; 18 | - to descend into a child node, type the name of the child 19 | ("info" includes a list of children of the current node); 20 | - to ascend, use the "up" command; 21 | - type "log" to display an activity log. 22 | ============================================================== 23 | 24 | rec last ∷ ∀ a . [a] → a 25 | last = λ a → 26 | let rec work ∷ a → [a] → a 27 | work = λ a0 as → 28 | case as of wild a 29 | [] → a0 30 | (:) a1 as0 → work a1 as0 31 | in λ ds → 32 | case ds of wild a 33 | [] → undefined a 34 | (:) a0 as → work a0 as 35 | wrap ∷ ∀ a . (a → [a] → a) → [a] → a 36 | wrap = λ a f ds → 37 | case ds of wild a 38 | [] → undefined a 39 | (:) a as → f a as 40 | unwrap ∷ ∀ a . ([a] → a) → a → [a] → a 41 | unwrap = λ a f a as → f ((:) a a as) 42 | main ∷ IO () 43 | main = print Char $fShowChar (last Char (unpackCString# "hello"#)) 44 | main ∷ IO () 45 | main = runMainIO () main 46 | recursive-definition-of-work-for-use-by-ww-fusion (Proven) 47 | work ≡ unwrap a (f (wrap a work)) 48 | -------------------------------------------------------------------------------- /tests/golden/golden-ghc-7103/last_Last_hs_NewLast_hss.ref: -------------------------------------------------------------------------------- 1 | ===================== Welcome to HERMIT ====================== 2 | HERMIT is a toolkit for the interactive transformation of GHC 3 | core language programs. Documentation on HERMIT can be found 4 | on the HERMIT web page at: 5 | http://www.ittc.ku.edu/csdl/fpg/software/hermit.html 6 | 7 | You have just loaded the interactive shell. To exit, type 8 | "abort" or "resume" to abort or resume GHC compilation. 9 | 10 | Type "help" for instructions on how to list or search the 11 | available HERMIT commands. 12 | 13 | To get started, you could try the following: 14 | - type "binding-of 'foo", where "foo" is a function 15 | defined in the module; 16 | - type "set-pp-type Show" to display full type information; 17 | - type "info" for more information about the current node; 18 | - to descend into a child node, type the name of the child 19 | ("info" includes a list of children of the current node); 20 | - to ascend, use the "up" command; 21 | - type "log" to display an activity log. 22 | ============================================================== 23 | 24 | Forcing obligation: last-assumption 25 | Successfully proven: last-assumption 26 | rec last ∷ ∀ a . [a] → a 27 | last = λ a → 28 | let rec x ∷ a → [a] → a 29 | x = λ a as → 30 | case as of wild a 31 | [] → a 32 | (:) a as → x a as 33 | in λ ds → 34 | case ds of wild a 35 | [] → undefined a 36 | (:) a as → x a as 37 | wrap ∷ ∀ a . (a → [a] → a) → [a] → a 38 | wrap = λ a f ds → 39 | case ds of wild a 40 | [] → undefined a 41 | (:) a as → f a as 42 | unwrap ∷ ∀ a . ([a] → a) → a → [a] → a 43 | unwrap = λ a f a as → f ((:) a a as) 44 | main ∷ IO () 45 | main = print Char $fShowChar (last Char (unpackCString# "hello"#)) 46 | main ∷ IO () 47 | main = runMainIO () main 48 | last-fusion (Built In) 49 | unwrap a (wrap a (fix (a → [a] → a) g)) ≡ fix (a → [a] → a) g 50 | -------------------------------------------------------------------------------- /tests/golden/golden-ghc-7103/mean_Mean_hs_Mean_hss.ref: -------------------------------------------------------------------------------- 1 | ===================== Welcome to HERMIT ====================== 2 | HERMIT is a toolkit for the interactive transformation of GHC 3 | core language programs. Documentation on HERMIT can be found 4 | on the HERMIT web page at: 5 | http://www.ittc.ku.edu/csdl/fpg/software/hermit.html 6 | 7 | You have just loaded the interactive shell. To exit, type 8 | "abort" or "resume" to abort or resume GHC compilation. 9 | 10 | Type "help" for instructions on how to list or search the 11 | available HERMIT commands. 12 | 13 | To get started, you could try the following: 14 | - type "binding-of 'foo", where "foo" is a function 15 | defined in the module; 16 | - type "set-pp-type Show" to display full type information; 17 | - type "info" for more information about the current node; 18 | - to descend into a child node, type the name of the child 19 | ("info" includes a list of children of the current node); 20 | - to ascend, use the "up" command; 21 | - type "log" to display an activity log. 22 | ============================================================== 23 | 24 | rec sum ∷ [Int] → Int 25 | sum = λ ds → 26 | case ds of wild Int 27 | [] → I# 0 28 | (:) x xs → (+) Int $fNumInt x (sum xs) 29 | rec length ∷ [Int] → Int 30 | length = λ ds → 31 | case ds of wild Int 32 | [] → I# 0 33 | (:) x xs → (+) Int $fNumInt (I# 1) (length xs) 34 | rec sumlength ∷ [Int] → (Int, Int) 35 | sumlength = λ xs → 36 | case xs of w (Int, Int) 37 | [] → (,) Int Int (I# 0) (I# 0) 38 | (:) y ys → 39 | case sumlength ys of sl (Int, Int) 40 | (,) s l → 41 | (,) Int Int ((+) Int $fNumInt y s) ((+) Int $fNumInt (I# 1) l) 42 | mean ∷ [Int] → Int 43 | mean = λ xs → 44 | case sumlength xs of sl Int 45 | (,) s l → div Int $fIntegralInt s l 46 | main ∷ IO () 47 | main = 48 | ($) Int (IO ()) (print Int $fShowInt) 49 | (mean (enumFromTo Int $fEnumInt (I# 1) (I# 10))) 50 | main ∷ IO () 51 | main = runMainIO () main 52 | remembered-sumlen (Proven) 53 | ∀ xs. sumlength xs ≡ (,) Int Int (sum xs) (length xs) 54 | -------------------------------------------------------------------------------- /tests/prims/Makefile: -------------------------------------------------------------------------------- 1 | boot:: 2 | - hermit Test.hs +main:Main Test.hss resume -- -v0 | tee Test.out 3 | diff -s Test.out Test.expected.out 4 | 5 | interactive:: 6 | - hermit Test.hs 7 | -------------------------------------------------------------------------------- /tests/prims/Test.expected.out: -------------------------------------------------------------------------------- 1 | compiling Test.hs, using (Test.hs,Test.hss resume) 2 | ghc-7.4.1 Test.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -v0 -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main:Test.hss -fplugin-opt=HERMIT:main:Main:resume -fplugin-opt=HERMIT:main:Main: 3 | ["main:Main:","main:Main:resume","main:Main:Test.hss"] 4 | ("files",["","resume","Test.hss"]) 5 | 0 6 | [including Test.hss] 7 | module main:Main where 8 | $dShow :: Show [] Char 9 | main :: IO () 10 | beta_reduce_start :: Int 11 | beta_reduce_end :: Int 12 | case_reduce_start :: String 13 | case_reduce_end :: String 14 | main :: IO () 15 | 16 | module main:Main where 17 | $dShow :: Show [] Char 18 | main :: IO () 19 | beta_reduce_start :: Int 20 | beta_reduce_end :: Int 21 | case_reduce_start :: String 22 | case_reduce_end :: String 23 | main :: IO () 24 | 25 | (\ x -> (+) * $fNumInt x (I# 2)) (I# 1) 26 | 27 | let x = I# 1 in (+) * $fNumInt x (I# 2) 28 | 29 | (+) * $fNumInt (I# 1) (I# 2) 30 | 31 | module main:Main where 32 | $dShow :: Show [] Char 33 | main :: IO () 34 | beta_reduce_start :: Int 35 | beta_reduce_end :: Int 36 | case_reduce_start :: String 37 | case_reduce_end :: String 38 | main :: IO () 39 | 40 | beta_reduce_start == beta_reduce_end 41 | module main:Main where 42 | $dShow :: Show [] Char 43 | main :: IO () 44 | beta_reduce_start :: Int 45 | beta_reduce_end :: Int 46 | case_reduce_start :: String 47 | case_reduce_end :: String 48 | main :: IO () 49 | 50 | let bar = Bar (I# 5) (F# (__float 2.1)) 51 | in case bar of wild 52 | Bar x f -> show * $fShowInt x 53 | Baz s -> s 54 | 55 | case Bar (I# 5) (F# (__float 2.1)) of wild 56 | Bar x f -> show * $fShowInt x 57 | Baz s -> s 58 | 59 | show * $fShowInt (I# 5) 60 | 61 | module main:Main where 62 | $dShow :: Show [] Char 63 | main :: IO () 64 | beta_reduce_start :: Int 65 | beta_reduce_end :: Int 66 | case_reduce_start :: String 67 | case_reduce_end :: String 68 | main :: IO () 69 | 70 | case_reduce_start == case_reduce_end 71 | -------------------------------------------------------------------------------- /tests/prims/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main = print "Test" 4 | 5 | ------------------------ beta reduction --------------------- 6 | beta_reduce_start :: Int 7 | beta_reduce_start = f 1 8 | where 9 | f = \ x -> x + 2 :: Int -- is auto-inlined 10 | 11 | beta_reduce_end :: Int 12 | beta_reduce_end = 1 + 2 13 | 14 | ------------------------ case reduction ------------------------- 15 | data Foo a = Bar Int Float a | Baz String 16 | 17 | case_reduce_start = case bar of 18 | Bar x f a -> show x 19 | Baz s -> s 20 | where {-# NOINLINE bar #-} 21 | bar = Bar 5 2.1 'a' 22 | 23 | case_reduce_end = show (5 :: Int) 24 | 25 | ------------------------ adding and using a rule ---------------- 26 | 27 | --{-# NOINLINE capture_me #-} 28 | capture_me :: Int 29 | capture_me = 99 30 | 31 | new_rule_start = capture_me 32 | 33 | new_rule_end = 99 :: Int 34 | 35 | ------------------------ fold ----------------------------------- 36 | 37 | double :: Int -> Int 38 | double x = x + x 39 | 40 | fold_start :: Int 41 | fold_start = 5 + 5 + 6 42 | 43 | fold_end = double 5 + 6 44 | 45 | ------------------------ ticks in names ------------------------- 46 | 47 | ones' :: [Int] 48 | ones' = 1 : ones' 49 | 50 | ones'_start :: [Int] 51 | ones'_start = 2 : ones' 52 | 53 | ones'_end :: [Int] 54 | ones'_end = 2 : 1 : ones' 55 | -------------------------------------------------------------------------------- /tests/prims/Test.hss: -------------------------------------------------------------------------------- 1 | flatten-module 2 | -- Use an ASCII render (so we can diff) 3 | set-renderer ascii 4 | -- set-pretty-depth 0 5 | -- Tests: beta-reduce, let-subst 6 | { rhs-of 'beta_reduce_start 7 | beta-reduce 8 | let-subst 9 | } 10 | compare-values 'beta_reduce_start 'beta_reduce_end 11 | 12 | -- Tests: case-reduce 13 | { rhs-of 'case_reduce_start 14 | let-subst 15 | case-reduce 16 | } 17 | compare-values 'case_reduce_start 'case_reduce_end 18 | 19 | -- Tests: add-rule 20 | add-rule capture 'capture_me 21 | { consider 'new_rule_start 22 | any-call (apply-rule capture) 23 | } 24 | compare-values 'new_rule_start 'new_rule_end 25 | 26 | -- Tests: fold 27 | { rhs-of 'fold_start 28 | any-bu (fold 'double) 29 | } 30 | compare-values 'fold_start 'fold_end 31 | 32 | -- Tests: ticks in names 33 | { rhs-of 'ones'_start 34 | any-bu (inline 'ones') 35 | } 36 | compare-values 'ones'_start 'ones'_end 37 | --------------------------------------------------------------------------------