├── .gitignore ├── LICENSE ├── README.md ├── cabal.project ├── coq ├── .gitignore ├── Bang.v ├── Constraints.v ├── Make ├── Makefile ├── NarrowBase.v ├── NarrowCompleteness.v ├── NarrowSoundness.v ├── Probability.v ├── README ├── Types.v ├── Util.v └── Valuation.v └── luck ├── LICENSE ├── Setup.hs ├── examples-template ├── C-QC.hs ├── C.hs ├── ModuleIntro.txt ├── Stlc-template.hs ├── Stlc.hs ├── combination.hs └── ghc-counters │ ├── 0.hs │ ├── out │ └── outOpt ├── examples ├── AC3Test.luck ├── AC3Test2.luck ├── BST.luck ├── BackTrackTest.luck ├── BinopTest.luck ├── C.luck ├── CaseTests.luck ├── Class.luck ├── Combination.luck ├── ConjTest.luck ├── Fresh.luck ├── GT.luck ├── InlineTest.luck ├── LLNI.luck ├── ListSet.luck ├── Map.luck ├── OrderedPair.luck ├── Peano.luck ├── PicoGenExec.luck ├── PicoGenExecBugArith.luck ├── RBT.luck ├── Records.luck ├── SSNI.luck ├── STLC.luck ├── SigTest.luck ├── Tree.luck └── pirapirabug.luck ├── exec └── Main.hs ├── luck.cabal ├── src ├── Common │ ├── Conversions.hs │ ├── Error.hs │ ├── Haskellify.hs │ ├── Pretty.hs │ ├── SrcLoc.hs │ ├── Types.hs │ └── Util.hs ├── Core │ ├── AST.hs │ ├── AST │ │ └── Pretty.hs │ ├── CSet.hs │ ├── IntRep.hs │ ├── Optimizations.hs │ ├── Pretty.hs │ ├── Rigidify.hs │ ├── Rigidify │ │ ├── Data.hs │ │ ├── Generator.hs │ │ └── Pretty.hs │ ├── Semantics.hs │ └── Types │ │ ├── Data.hs │ │ ├── Generator.hs │ │ └── Pretty.hs ├── Luck │ ├── Main.hs │ ├── Prelude.luck │ └── Template.hs └── Outer │ ├── AST.hs │ ├── AST │ └── Pretty.hs │ ├── ClassMono.hs │ ├── Expander.hs │ ├── Lexer.x │ ├── ParseMonad.hs │ ├── Parser.info │ ├── Parser.y │ ├── Renamer.hs │ └── Types.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by https://www.gitignore.io/api/coq,haskell,vim,emacs,macos,windows,linux 2 | 3 | ### Coq ### 4 | .*.aux 5 | *.a 6 | *.cma 7 | *.cmi 8 | *.cmo 9 | *.cmx 10 | *.cmxa 11 | *.cmxs 12 | *.glob 13 | *.ml.d 14 | *.ml4.d 15 | *.mli.d 16 | *.mllib.d 17 | *.mlpack.d 18 | *.native 19 | *.o 20 | *.v.d 21 | *.vio 22 | *.vo 23 | .coq-native/ 24 | .csdp.cache 25 | .lia.cache 26 | .nia.cache 27 | .nlia.cache 28 | .nra.cache 29 | csdp.cache 30 | lia.cache 31 | nia.cache 32 | nlia.cache 33 | nra.cache 34 | 35 | 36 | ### Haskell ### 37 | dist 38 | dist-* 39 | cabal-dev 40 | *.hi 41 | *.chi 42 | *.chs.h 43 | *.dyn_o 44 | *.dyn_hi 45 | .hpc 46 | .hsenv 47 | .cabal-sandbox/ 48 | cabal.sandbox.config 49 | *.prof 50 | *.aux 51 | *.hp 52 | *.eventlog 53 | .stack-work/ 54 | cabal.project.local 55 | .HTF/ 56 | 57 | 58 | ### Vim ### 59 | # swap 60 | [._]*.s[a-w][a-z] 61 | [._]s[a-w][a-z] 62 | # session 63 | Session.vim 64 | # temporary 65 | .netrwhist 66 | *~ 67 | # auto-generated tag files 68 | tags 69 | 70 | 71 | ### Emacs ### 72 | # -*- mode: gitignore; -*- 73 | \#*\# 74 | /.emacs.desktop 75 | /.emacs.desktop.lock 76 | *.elc 77 | auto-save-list 78 | tramp 79 | .\#* 80 | 81 | # Org-mode 82 | .org-id-locations 83 | *_archive 84 | 85 | # flymake-mode 86 | *_flymake.* 87 | 88 | # eshell files 89 | /eshell/history 90 | /eshell/lastdir 91 | 92 | # elpa packages 93 | /elpa/ 94 | 95 | # reftex files 96 | *.rel 97 | 98 | # AUCTeX auto folder 99 | /auto/ 100 | 101 | # cask packages 102 | .cask/ 103 | dist/ 104 | 105 | # Flycheck 106 | flycheck_*.el 107 | 108 | # server auth directory 109 | /server/ 110 | 111 | # projectiles files 112 | .projectile 113 | 114 | # directory configuration 115 | .dir-locals.el 116 | 117 | 118 | ### macOS ### 119 | *.DS_Store 120 | .AppleDouble 121 | .LSOverride 122 | 123 | # Icon must end with two \r 124 | Icon 125 | # Thumbnails 126 | ._* 127 | # Files that might appear in the root of a volume 128 | .DocumentRevisions-V100 129 | .fseventsd 130 | .Spotlight-V100 131 | .TemporaryItems 132 | .Trashes 133 | .VolumeIcon.icns 134 | .com.apple.timemachine.donotpresent 135 | # Directories potentially created on remote AFP share 136 | .AppleDB 137 | .AppleDesktop 138 | Network Trash Folder 139 | Temporary Items 140 | .apdisk 141 | 142 | 143 | ### Windows ### 144 | # Windows image file caches 145 | Thumbs.db 146 | ehthumbs.db 147 | 148 | # Folder config file 149 | Desktop.ini 150 | 151 | # Recycle Bin used on file shares 152 | $RECYCLE.BIN/ 153 | 154 | # Windows Installer files 155 | *.cab 156 | *.msi 157 | *.msm 158 | *.msp 159 | 160 | # Windows shortcuts 161 | *.lnk 162 | 163 | 164 | ### Linux ### 165 | 166 | # temporary files which can be created if a process still has a handle open of a deleted file 167 | .fuse_hidden* 168 | 169 | # KDE directory preferences 170 | .directory 171 | 172 | # Linux trash folder which might appear on any partition or disk 173 | .Trash-* 174 | 175 | # .nfs files are created when an open file is removed but is still being accessed 176 | .nfs* 177 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 QuickChick 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Note: 2025 update for Luck Haskell implementation 2 | 3 | After a little update, Luck builds with a modern GHC (9.6.5) using `cd luck && cabal build`. 4 | 5 | 6 | # Luck -- A Language for Property-Based Generators 7 | 8 | Accompanying material for the following POPL 2017 paper: 9 | Beginner's Luck: A Language for Property-Based Generators. 10 | Leonidas Lampropoulos, Diane Gallois-Wong, Catalin Hritcu, John 11 | Hughes, Benjamin C. Pierce, Li-yao Xia. 12 | https://arxiv.org/abs/1607.05443 13 | 14 | `/coq` 15 | 16 | Coq proofs for narrowing fragment of the Luck core language. 17 | Works with Coq 8.4pl6. Simply run `make` there to check proofs. 18 | 19 | `/luck` 20 | 21 | Luck interpreter. Known to work with GHC 7.10 -- 8.01 22 | 23 | Running `cabal install` there will produce a `luck` executable. 24 | Try out `luck examples/BST.luck`. 25 | `luck --help` provides a list of useful flags. 26 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: luck 2 | 3 | allow-newer: 4 | semigroupoids:base 5 | 6 | -------------------------------------------------------------------------------- /coq/.gitignore: -------------------------------------------------------------------------------- 1 | Makefile.coq 2 | -------------------------------------------------------------------------------- /coq/Bang.v: -------------------------------------------------------------------------------- 1 | Require Import Util. 2 | Require Import Types. 3 | Require Import Probability. 4 | Require Import Constraints. 5 | Require Import Valuation. 6 | Import CSet. 7 | 8 | Require Import QArith. 9 | 10 | Inductive sample' : 11 | exp -> cset -> frac -> cset -> trace -> Prop := 12 | | UST_U : forall u k q k' tr, 13 | sample u k q k' tr -> 14 | sample' (U u) k q k' tr 15 | 16 | | UST_Unit : forall k, 17 | sample' Unit k 1 k nil 18 | 19 | | UST_Pair : forall v1 v2 k q1 q2 k1 k2 tr1 tr2, 20 | sample' v1 k q1 k1 tr1 -> 21 | sample' v2 k1 q2 k2 tr2 -> 22 | sample' (Pair v1 v2) k (q1 * q2) k2 (tr2 ++ tr1) 23 | 24 | | UST_Inl : forall v k q k' tr t1 t2 , 25 | sample' v k q k' tr -> 26 | sample' (Inl t1 t2 v) k q k' tr 27 | 28 | | UST_Inr : forall v k q k' tr t1 t2, 29 | sample' v k q k' tr -> 30 | sample' (Inr t1 t2 v) k q k' tr 31 | 32 | | UST_Fold : forall T v k q k' tr, 33 | sample' v k q k' tr -> 34 | sample' (Fold T v) k q k' tr. 35 | 36 | Lemma sample_preserves_types' : 37 | forall e k q k' tr, 38 | sample' e k q k' tr -> 39 | uts k = uts k'. 40 | Proof. 41 | move => e k q k' tr H; induction H; auto. 42 | - eapply sample_preserves_types; eauto. 43 | - rewrite IHsample'1; auto. 44 | Qed. 45 | 46 | Lemma sample_preserves_well_typed' : 47 | forall e k q k' tr, 48 | sample' e k q k' tr -> 49 | well_typed_cset k -> 50 | well_typed_cset k'. 51 | Proof. 52 | move => e k q k' tr H; induction H; auto. 53 | - eapply sample_preserves_well_typed; eauto. 54 | Qed. 55 | 56 | Lemma uniform_sat' : 57 | forall v k q k' tr, 58 | sample' v k q k' tr -> sat k -> 59 | sat k'. 60 | move => v k q k' tr H; induction H => SAT; 61 | eauto. 62 | eapply uniform_sat; eauto. 63 | Qed. 64 | 65 | Lemma sample_lte' : 66 | forall v k q k' tr, 67 | sample' v k q k' tr -> 68 | lte k' k. 69 | Proof. 70 | induction v; intros; try inversion H; eauto. 71 | - apply reflexivity. 72 | - eapply transitivity; eauto. 73 | - subst. eapply sample_lte; eauto. 74 | Qed. 75 | 76 | Ltac discharge_IH_Bang IH s e k T Hyp := 77 | specialize (IH s e k T); 78 | match goal with 79 | | [ H : _ -> _ -> _ -> _ -> ?Res |- _ ] => 80 | assert (Hyp : Res); [eapply H | ]; clear H; eauto 81 | end; eauto. 82 | 83 | Lemma shift_preserves_NonFun : 84 | forall T, isNonFunType T -> 85 | forall n, isNonFunType (Types.shift n T). 86 | move => T H; induction H; move => n; simpl; eauto; 87 | try solve [econstructor; eauto]. 88 | destruct (lt_dec X n); econstructor. 89 | Qed. 90 | 91 | Lemma substT_preserves_NonFun : 92 | forall T , isNonFunType T -> 93 | forall T', isNonFunType T' -> 94 | forall n, isNonFunType (substT n T' T). 95 | move => T H; induction H; move => T' HT HT'; simpl; eauto; 96 | match goal with 97 | | |- context[eq_tvar_dec O ?X] => 98 | destruct (eq_tvar_dec O X) 99 | | _ => idtac 100 | end; simpl; eauto; 101 | try solve [inversion HT; subst; econstructor; eauto]. 102 | - destruct (eq_tvar_dec HT' X); eauto. 103 | econstructor. 104 | econstructor. 105 | eapply IHisNonFunType. 106 | eapply shift_preserves_NonFun; eauto. 107 | Qed. 108 | 109 | Lemma sample_spec_1' : 110 | forall v (H : is_value v) k s v' T, 111 | uts k; ∅ ⊢ v ↦ T -> 112 | isNonFunType T -> 113 | InK s k -> SubVal s v v' -> 114 | exists k', InK s k' /\ 115 | exists q tr, sample' v k q k' tr. 116 | move => v H; induction H; 117 | move => k s v' T' HT' HNF HInK HSub; 118 | inversion HSub; subst; 119 | inversion HT'; subst. 120 | - exists k. 121 | split; auto. 122 | exists 1; exists nil. 123 | econstructor; eauto. 124 | - move: (sample_spec_1 u k s b HInK H1) => 125 | [k' [HInK' [q [tr H]]]]. 126 | exists k'. 127 | split; auto. 128 | exists q; exists tr. 129 | econstructor; eauto. 130 | - discharge_IH_Bang IHis_value1 k s e1' T₁ Hyp. 131 | inversion HNF; eauto. 132 | move: Hyp => [k₁ [HInK₁ [q₁ [tr₁ H1]]]]. 133 | discharge_IH_Bang IHis_value2 k₁ s e2' T₂ Hyp. 134 | erewrite <- sample_preserves_types'; eauto. 135 | inversion HNF; eauto. 136 | move: Hyp => [k₂ [HInK₂ [q₂ [tr₂ H2]]]]. 137 | exists k₂. 138 | split; auto. 139 | exists (q₁ * q₂). 140 | exists (tr₂ ++ tr₁). 141 | econstructor; eauto. 142 | - discharge_IH_Bang IHis_value k s e' T₁ Hyp. 143 | inversion HNF; eauto. 144 | move: Hyp => [k' [HInK' [q [tr H']]]]. 145 | exists k'. 146 | split; auto. 147 | exists q; exists tr. 148 | econstructor; eauto. 149 | - discharge_IH_Bang IHis_value k s e' T₂ Hyp. 150 | inversion HNF; eauto. 151 | move: Hyp => [k' [HInK' [q [tr H']]]]. 152 | exists k'. 153 | split; auto. 154 | exists q; exists tr. 155 | econstructor; eauto. 156 | - inversion HNF. 157 | - discharge_IH_Bang IHis_value k s e' (substT O (TMu T0) T0) Hyp. 158 | inversion HNF; subst; eauto. 159 | eapply substT_preserves_NonFun; eauto. 160 | 161 | move: Hyp => [k' [HInK' [q [tr H']]]]. 162 | exists k'. 163 | split; auto. 164 | exists q; exists tr. 165 | econstructor; eauto. 166 | Qed. 167 | 168 | Lemma sample_spec_2' : 169 | forall v k q k' tr, 170 | sample' v k q k' tr -> 171 | forall s, InK s k' -> InK s k. 172 | move => v k q k' tr H; induction H => s In; eauto. 173 | eapply sample_spec_2; eauto. 174 | Qed. 175 | 176 | Inductive singleton' (k : cset) 177 | : exp -> exp -> Prop := 178 | | Sing_Unit : singleton' k Unit Unit 179 | | Sing_Pair : 180 | forall v1 v1' v2 v2', 181 | singleton' k v1 v1' -> 182 | singleton' k v2 v2' -> 183 | singleton' k (Pair v1 v2) 184 | (Pair v1' v2') 185 | | Sing_Inl : 186 | forall T1 T2 v v', 187 | singleton' k v v' -> 188 | singleton' k (Inl T1 T2 v) (Inl T1 T2 v') 189 | | Sing_Inr : 190 | forall T1 T2 v v', 191 | singleton' k v v' -> 192 | singleton' k (Inr T1 T2 v) (Inr T1 T2 v') 193 | | Sing_Fold : 194 | forall T v v', 195 | singleton' k v v' -> 196 | singleton' k (Fold T v) (Fold T v') 197 | | Sing_U : 198 | forall u b, 199 | singleton k u b -> 200 | singleton' k (U u) (base_to_exp b). 201 | 202 | Lemma SubVal_singleton' : 203 | forall k v v', 204 | singleton' k v v' -> 205 | forall s, InK s k -> SubVal s v v'. 206 | move => k v v' H; induction H; move => s HIn; 207 | econstructor; eauto. 208 | Qed. 209 | 210 | Lemma uniform_preserves_singleton' : 211 | forall v k q k' tr, 212 | sample' v k q k' tr -> 213 | sat k -> 214 | forall v' v'', singleton' k v' v'' -> 215 | singleton' k' v' v''. 216 | move => v k q k' tr H; induction H; 217 | move => SAT v' v'' HS; eauto. 218 | - induction HS; subst; eauto; 219 | econstructor; eauto. 220 | eapply uniform_preserves_singleton; eauto. 221 | - induction HS; subst; eauto; 222 | econstructor; eauto. 223 | assert (singleton' k2 (U u) (base_to_exp b)). 224 | { 225 | eapply IHsample'2; eauto. 226 | eapply uniform_sat'; eauto. 227 | eapply IHsample'1; eauto. 228 | econstructor; eauto. 229 | } 230 | inversion H2; subst. 231 | erewrite base_to_exp_injective; eauto. 232 | Qed. 233 | 234 | Lemma uniform_singleton' : 235 | forall v k q k' tr, 236 | sample' v k q k' tr -> sat k -> 237 | exists v', singleton' k' v v'. 238 | move => v k q k' tr H; 239 | induction H; move => SAT; eauto. 240 | - eapply uniform_singleton in H; auto. 241 | move: H => [v Hv]. 242 | exists (base_to_exp v); 243 | econstructor; eauto. 244 | - exists Unit; econstructor; eauto. 245 | - move: (IHsample'1 SAT) => [v1' H1]. 246 | eapply uniform_sat' in H; eauto. 247 | move: (IHsample'2 H) => [v2' H2]. 248 | exists (Pair v1' v2'); auto. 249 | simpl; auto. 250 | eapply uniform_preserves_singleton' in H1; 251 | eauto. 252 | econstructor; eauto. 253 | - move: (IHsample' SAT) => [v' Hv]. 254 | exists (Inl t1 t2 v'); econstructor; eauto. 255 | - move: (IHsample' SAT) => [v' Hv]. 256 | exists (Inr t1 t2 v'); econstructor; eauto. 257 | - move: (IHsample' SAT) => [v' Hv]. 258 | exists (Fold T v'); econstructor; eauto. 259 | Qed. 260 | 261 | 262 | Definition nat_denote' k e n : Prop := 263 | exists v, singleton' k e v /\ nat_denote v n. 264 | 265 | Lemma Singleton_SubVal : 266 | forall s v v', SubVal s v v' -> 267 | forall k v'', InK s k -> singleton' k v v'' -> 268 | v' = v''. 269 | move => s v v' HSub; induction HSub; 270 | move => k v'' HIn HS; 271 | inversion HS; subst; eauto. 272 | - erewrite IHHSub1; eauto. 273 | erewrite IHHSub2; eauto. 274 | - erewrite IHHSub; eauto. 275 | - erewrite IHHSub; eauto. 276 | - move: (H2 s HIn) => H. 277 | assert (b = b0). 278 | eapply MapProp.F.MapsTo_fun; eauto. 279 | subst; auto. 280 | - erewrite IHHSub; eauto. 281 | Qed. 282 | 283 | Lemma sample_domain' : 284 | forall v k q k' tr, 285 | sample' v k q k' tr -> 286 | domain k = domain k'. 287 | move => v k q k' tr H; induction H; eauto. 288 | - eapply sample_domain; eauto. 289 | - rewrite IHsample'1; eauto. 290 | Qed. -------------------------------------------------------------------------------- /coq/Make: -------------------------------------------------------------------------------- 1 | Util.v 2 | Types.v 3 | Probability.v 4 | Valuation.v 5 | Constraints.v 6 | Bang.v 7 | NarrowBase.v 8 | NarrowCompleteness.v 9 | NarrowSoundness.v 10 | -------------------------------------------------------------------------------- /coq/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: compile tests clean 2 | 3 | compile: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | Makefile.coq: Make 7 | coq_makefile -f Make -o Makefile.coq 8 | 9 | clean: 10 | # This might not work on macs, but then not my problem 11 | find . -regex ".*\.vo\|.*\.d\|.*\.glob\|.*\.o\|.*\.cmi\|.*\.cmx\|.*\.cmxs\|.*\.cmo\|.*\.bak\|.*~" -type f -delete 12 | rm -f Makefile.coq 13 | -------------------------------------------------------------------------------- /coq/Probability.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | 3 | Require Import Coq.QArith.QArith_base. 4 | 5 | Definition frac := Q. 6 | 7 | Inductive Choice := 8 | | Chose : nat -> nat -> Choice. 9 | 10 | Definition trace := list Choice. 11 | 12 | (* 13 | Axiom tape : Type. 14 | Axiom frequency : forall {A}, list (nat * A) -> tape -> (A * tape). 15 | Axiom frequency_chooses : 16 | forall A (l : list (nat * A)) (t t': tape) (a : A), 17 | (a, t') = frequency l t -> exists n, In (n,a) l. 18 | Axiom tape_inhabited : tape. 19 | 20 | Axiom frequency_possible : 21 | forall {A} (l : list (nat * A)) (t' : tape) 22 | (n : nat) (a : A), 23 | In (n, a) l -> n <> O -> 24 | exists t, frequency l t = (a,t'). 25 | *) -------------------------------------------------------------------------------- /coq/README: -------------------------------------------------------------------------------- 1 | This development requires Coq 8.4pl6 and SSReflect 1.5. 2 | 3 | Warning: "make" could take 5-10 minutes. 4 | -------------------------------------------------------------------------------- /coq/Util.v: -------------------------------------------------------------------------------- 1 | (* Valuations / maps *) 2 | Require Export Coq.Structures.OrderedTypeEx. 3 | Require Export MSetList. 4 | Require Import FMapList. 5 | Require Import FMapFacts. 6 | Require Import Coq.Arith.EqNat. 7 | 8 | Ltac clear_dup := 9 | match goal with 10 | | [ H : ?X |- _ ] => 11 | match goal with 12 | | [ H' : ?Y |- _ ] => 13 | match H with 14 | | H' => fail 2 15 | | _ => unify X Y ; (clear H' || clear H) 16 | end 17 | end 18 | end. 19 | 20 | Ltac clear_dups := repeat clear_dup. 21 | 22 | Definition beq_unknown := beq_nat. 23 | Module Map := FMapList.Make(Nat_as_OT). 24 | (* Restrict a valuation to a set of unknowns *) 25 | Module MapProp := FMapFacts.Properties Map. 26 | Module MapFacts := FMapFacts.Facts Map. 27 | 28 | Definition liftMaybe {A B} (f : A -> B) (m : option A) : option B := 29 | match m with 30 | | Some a => Some (f a) 31 | | None => None 32 | end. 33 | 34 | Definition liftMaybe2 {A B C} (f : A -> B -> C) 35 | (ma : option A) (mb : option B) : (option C) := 36 | match ma, mb with 37 | | Some a, Some b => Some (f a b) 38 | | _,_ => None 39 | end. 40 | 41 | Definition liftMaybe3 {A B C D} (f : A -> B -> C -> D) 42 | (ma : option A) (mb : option B) (mc : option C) 43 | : (option D) := 44 | match ma, mb, mc with 45 | | Some a, Some b, Some c => Some (f a b c) 46 | | _,_,_ => None 47 | end. 48 | 49 | Require Import QArith. 50 | Require Import Coq.PArith.BinPosDef. 51 | Definition div (n m : nat) : Q := 52 | Z_of_nat n # Pos.of_nat m. 53 | Notation " a // b " := (div a b) (at level 40). -------------------------------------------------------------------------------- /luck/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /luck/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /luck/examples-template/C-QC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveDataTypeable #-} 2 | import Control.Monad 3 | import Control.Applicative 4 | import Control.Arrow hiding ((<+>)) 5 | 6 | import Control.Monad.State 7 | 8 | import System.IO 9 | import System.Directory 10 | import System.Process 11 | import Control.Concurrent 12 | import Control.Exception 13 | import System.Exit 14 | import System.IO 15 | import System.IO.Error 16 | import System.Posix.Signals 17 | import System.Process.Internals 18 | 19 | import System.Environment 20 | import System.Random 21 | import System.Console.CmdArgs 22 | import System.Exit 23 | 24 | import Luck.Template 25 | import Test.QuickCheck 26 | 27 | import Data.Data 28 | import Data.Maybe 29 | import Data.List 30 | 31 | import System.Directory 32 | import System.Process 33 | 34 | import Data.Set (Set) 35 | import qualified Data.Set as Set 36 | import Data.Data 37 | 38 | import Text.PrettyPrint (Doc, (<+>), (<>), ($$)) 39 | import qualified Text.PrettyPrint as PP 40 | 41 | import qualified Data.Urn as U 42 | import Data.Urn (Urn) 43 | 44 | data Exp = Var Int 45 | | Int Int 46 | | Add Exp Exp 47 | | Eq Exp Exp 48 | deriving (Show, Data) 49 | 50 | data Stmt = Declare Int Stmt 51 | | Asgn Int Exp Stmt 52 | | If Exp Stmt Stmt Stmt 53 | | For Int Int Int Stmt Stmt 54 | | PrintVar Int Stmt 55 | | FunCall Int [Exp] Stmt 56 | | Empty 57 | deriving (Show, Data) 58 | 59 | class PP a where 60 | pp :: a -> Doc 61 | 62 | instance PP Int where 63 | pp = PP.int 64 | 65 | instance PP Exp where 66 | pp (Var x) = PP.text $ "var" ++ show x 67 | pp (Int n) = pp n 68 | pp (Add e1 e2) = PP.parens $ pp e1 <+> PP.char '+' <+> pp e2 69 | pp (Eq e1 e2) = PP.parens $ pp e1 <+> PP.text "==" <+> pp e2 70 | 71 | ppForVar :: Int -> Doc 72 | ppForVar i = PP.char 'i' <> PP.int i 73 | 74 | instance PP Stmt where 75 | pp (Declare x s) = PP.text "int" <+> pp (Var x) <+> PP.char ';' $$ pp s 76 | pp (Asgn x e s) = pp (Var x) <+> PP.char '=' <+> pp e <+> PP.char ';' $$ pp s 77 | pp (If e s1 s2 s') = PP.text "if" <+> PP.parens (pp e) <+> PP.char '{' 78 | $$ PP.nest 2 (pp s1) 79 | $$ PP.char '}' 80 | $$ PP.text "else {" 81 | $$ PP.nest 2 (pp s2) 82 | $$ PP.char '}' 83 | $$ pp s' 84 | pp (PrintVar n s') = PP.text "printf(\"%d\\n\", " <+> pp (Var n) <+> PP.text ");" $$ pp s' 85 | pp (FunCall (-2) [] s') = PP.text "empty();" $$ pp s' 86 | pp (FunCall (-1) [] s') = PP.text "loop();" $$ pp s' 87 | pp (FunCall fid es s') = 88 | PP.char 'a' <> PP.int fid <> PP.char '(' 89 | <> PP.hcat (intersperse (PP.char ',') (map pp es)) 90 | <> PP.text ");" $$ pp s' 91 | pp Empty = PP.empty 92 | pp (For i low high sfor s') = 93 | PP.text "for (int" <+> ppForVar i <+> PP.char '=' <+> PP.int low <> PP.char ';' 94 | <+> ppForVar i <+> PP.char '<' <+> PP.int high <> PP.char ';' 95 | <+> ppForVar i <> PP.text "++) {" 96 | $$ PP.nest 2 (pp sfor) 97 | $$ PP.text "}" 98 | $$ pp s' 99 | 100 | type Variable = Int 101 | 102 | data GenState = GS { deadCode :: Bool -- ^ In dead code or not 103 | , declared :: Int -- ^ Number of declared variables 104 | , assigned :: Set Variable -- ^ Set of assigned variables 105 | } deriving (Eq, Ord, Show) 106 | 107 | type CGen = StateT GenState Gen 108 | 109 | certain :: Gen a -> Gen (Maybe a) 110 | certain = fmap Just 111 | 112 | genAssigned :: CGen (Gen (Maybe Variable)) 113 | genAssigned = do 114 | set <- assigned <$> get 115 | if Set.null set then return $ pure Nothing 116 | else return $ certain $ elements $ Set.toList set 117 | 118 | genInt :: Gen Int 119 | genInt = choose (-10, 10) 120 | 121 | genVar :: CGen (Gen (Maybe Variable)) 122 | genVar = do 123 | gs <- get 124 | if deadCode gs then 125 | if declared gs == 0 then return $ pure Nothing 126 | else return $ certain $ choose (0, declared gs - 1) 127 | else genAssigned 128 | 129 | backtrack :: Urn (Gen (Maybe a)) -> Gen (Maybe a) 130 | backtrack u = do 131 | (_, g, mu) <- U.remove u 132 | ma <- g 133 | case ma of 134 | Just a -> return $ Just a 135 | Nothing -> case mu of 136 | Just u' -> backtrack u' 137 | Nothing -> return Nothing 138 | 139 | genExp :: Int -> CGen (Maybe Exp) 140 | genExp 0 = do 141 | g <- genVar 142 | let urn = fromJust $ U.fromList [ (1, (Var <$>) <$> g) 143 | , (1, (Int <$>) <$> (certain genInt)) ] 144 | lift $ backtrack urn 145 | 146 | 147 | 148 | {- 149 | stmtGen :: Gen (Maybe [Stmt]) 150 | stmtGen = $(mkGenQ defFlags{_fileName="examples/C.luck", _maxUnroll=2}) tProxy1 151 | 152 | runWait c = do 153 | p <- runCommand c 154 | waitForProcess p 155 | 156 | 157 | dump :: [Stmt] -> String -> String -> IO () 158 | dump (t:ts) fn1 fn2 = do 159 | let indices = map fst $ zip [0..] ts 160 | let tDoc = PP.vcat [ PP.text "void a0(int var0, int var1, int var2) {" 161 | , PP.nest 2 $ pp t 162 | , PP.text "}" ] 163 | tsDoc = PP.vcat $ PP.text "#include " 164 | : (PP.text "void loop() { while (1) { printf(\"1\"); } }") 165 | : (PP.text "void empty() { }") 166 | : map (\(i,t) -> 167 | PP.vcat [ PP.text "void a" <> PP.int i <> PP.text "(int var0, int var1, int var2) {" 168 | , PP.nest 2 $ pp t 169 | , PP.text "}" ] 170 | ) (reverse $ zip [1..] $ ts) 171 | -- let calls = map (\(i,_) -> PP.text "a" <> PP.int i <+> PP.text "();") (zip [0..] ts) 172 | let doc = PP.render $ PP.vcat ( PP.text "#include " 173 | : (map (\(i,_) -> PP.text "extern void a" 174 | <> PP.int i <> PP.text "(int x, int y, int z);" 175 | ) (zip [1..] ts) 176 | ) 177 | ++ [ PP.text "extern void loop(); " 178 | , PP.text "extern void empty(); " ] 179 | ++ [ tDoc 180 | , PP.text "int main() {" 181 | , PP.text " int undef;" 182 | , PP.text " a0(undef, 0,1);" 183 | , PP.text "}" ]) 184 | writeFile fn1 doc 185 | writeFile fn2 (PP.render tsDoc) 186 | 187 | compileAndRun :: CFlags -> IO Bool 188 | compileAndRun cflags@CFlags{..} = do 189 | let fn1 = _outFN ++ "1.c" 190 | fn2 = _outFN ++ "2.c" 191 | putStrLn "Compiling...\n" 192 | -- | Compile 193 | e1 <- runWait $ "clang-3.6 -Wno-tautological-compare -Wno-parentheses-equality " 194 | ++ fn1 ++ " " ++ fn2 ++ " -o test.NotOpt" 195 | e2 <- runWait $ "clang-3.6 -Wno-tautological-compare -Wno-parentheses-equality -O3" 196 | ++ " -mllvm -inline-threshold=10000 " 197 | ++ fn1 ++ " " ++ fn2 ++ " -o test.Opt" 198 | 199 | -- | Run and test 200 | putStrLn "Running and testing outputs...\n" 201 | (ePlain, outPlain, _) <- readProcessWithExitCode "timeout" [show _timeout, "./test.NotOpt"] "" 202 | (eOpt, outOpt, _) <- readProcessWithExitCode "timeout" [show _timeout, "./test.Opt"] "" 203 | return (outPlain == outOpt) 204 | 205 | runSingleBatch :: CFlags -> IO Bool 206 | runSingleBatch cflags@CFlags{..} = do 207 | (mts : _ ) <- sample' stmtGen 208 | case mts of 209 | Just ts -> do 210 | let fn1 = _outFN ++ "1.c" 211 | fn2 = _outFN ++ "2.c" 212 | dump ts fn1 fn2 213 | compileAndRun cflags 214 | Nothing -> error "Unsuccesful generation" 215 | 216 | -- TODO: Expose Luck options? 217 | data CFlags = CFlags { _numTries :: !Int 218 | , _timeout :: !Double 219 | , _outFN :: String 220 | } 221 | deriving (Eq, Show, Read, Typeable, Data) 222 | 223 | cFlags = CFlags { _numTries = 100 224 | &= name "num-tries" &= help "Number of tests to run" 225 | , _timeout = 0.1 226 | &= name "timeout" &= help "Timeout per-test (s)" 227 | , _outFN = "test" 228 | &= name "filename" &= help "Generated .c filename" 229 | } 230 | 231 | main :: IO () 232 | main = do 233 | cflags@CFlags{..} <- cmdArgs cFlags 234 | let aux 0 = putStrLn "Counterexample not found" 235 | aux n = do 236 | b <- runSingleBatch cflags 237 | if b then putStrLn "Found!" 238 | else aux $ n-1 239 | aux _numTries 240 | -} 241 | -------------------------------------------------------------------------------- /luck/examples-template/C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveDataTypeable #-} 2 | import Control.Monad 3 | import Control.Applicative 4 | import Control.Arrow hiding ((<+>)) 5 | 6 | import System.IO 7 | import System.Directory 8 | import System.Process 9 | import Control.Concurrent 10 | import Control.Exception 11 | import System.Exit 12 | import System.IO 13 | import System.IO.Error 14 | import System.Posix.Signals 15 | import System.Process.Internals 16 | 17 | import System.Environment 18 | import System.Random 19 | import System.Console.CmdArgs 20 | import System.Exit 21 | 22 | import Luck.Template 23 | import Test.QuickCheck 24 | 25 | import Data.Data 26 | import Data.Maybe 27 | import Data.List 28 | 29 | import System.Directory 30 | import System.Process 31 | 32 | import Data.Data 33 | 34 | import Text.PrettyPrint (Doc, (<+>), (<>), ($$)) 35 | import qualified Text.PrettyPrint as PP 36 | 37 | data Exp = Var Int 38 | | Int Int 39 | | Add Exp Exp 40 | | Eq Exp Exp 41 | deriving (Show, Data) 42 | 43 | data Stmt = Declare Int Stmt 44 | | Asgn Int Exp Stmt 45 | | If Exp Stmt Stmt Stmt 46 | | For Int Int Int Stmt Stmt 47 | | PrintVar Int Stmt 48 | | FunCall Int [Exp] Stmt 49 | | Empty 50 | deriving (Show, Data) 51 | 52 | class PP a where 53 | pp :: a -> Doc 54 | 55 | instance PP Int where 56 | pp = PP.int 57 | 58 | instance PP Exp where 59 | pp (Var x) = PP.text $ "var" ++ show x 60 | pp (Int n) = pp n 61 | pp (Add e1 e2) = PP.parens $ pp e1 <+> PP.char '+' <+> pp e2 62 | pp (Eq e1 e2) = PP.parens $ pp e1 <+> PP.text "==" <+> pp e2 63 | 64 | ppForVar :: Int -> Doc 65 | ppForVar i = PP.char 'i' <> PP.int i 66 | 67 | instance PP Stmt where 68 | pp (Declare x s) = PP.text "int" <+> pp (Var x) <+> PP.char ';' $$ pp s 69 | pp (Asgn x e s) = pp (Var x) <+> PP.char '=' <+> pp e <+> PP.char ';' $$ pp s 70 | pp (If e s1 s2 s') = PP.text "if" <+> PP.parens (pp e) <+> PP.char '{' 71 | $$ PP.nest 2 (pp s1) 72 | $$ PP.char '}' 73 | $$ PP.text "else {" 74 | $$ PP.nest 2 (pp s2) 75 | $$ PP.char '}' 76 | $$ pp s' 77 | pp (PrintVar n s') = PP.text "printf(\"%d\\n\", " <+> pp (Var n) <+> PP.text ");" $$ pp s' 78 | pp (FunCall (-2) [] s') = PP.text "empty();" $$ pp s' 79 | pp (FunCall (-1) [] s') = PP.text "loop();" $$ pp s' 80 | pp (FunCall fid es s') = 81 | PP.char 'a' <> PP.int fid <> PP.char '(' 82 | <> PP.hcat (intersperse (PP.char ',') (map pp es)) 83 | <> PP.text ");" $$ pp s' 84 | pp Empty = PP.empty 85 | pp (For i low high sfor s') = 86 | PP.text "for (int" <+> ppForVar i <+> PP.char '=' <+> PP.int low <> PP.char ';' 87 | <+> ppForVar i <+> PP.char '<' <+> PP.int high <> PP.char ';' 88 | <+> ppForVar i <> PP.text "++) {" 89 | $$ PP.nest 2 (pp sfor) 90 | $$ PP.text "}" 91 | $$ pp s' 92 | -- pp x = error $ show x 93 | 94 | stmtGen :: Gen (Maybe [Stmt]) 95 | stmtGen = $(mkGenQ defFlags{_fileName="examples/C.luck", _maxUnroll=2}) tProxy1 96 | 97 | runWait c = do 98 | p <- runCommand c 99 | waitForProcess p 100 | 101 | 102 | dump :: [Stmt] -> String -> String -> IO () 103 | dump (t:ts) fn1 fn2 = do 104 | let indices = map fst $ zip [0..] ts 105 | let tDoc = PP.vcat [ PP.text "void a0(int var0, int var1, int var2) {" 106 | , PP.nest 2 $ pp t 107 | , PP.text "}" ] 108 | tsDoc = PP.vcat $ PP.text "#include " 109 | : (PP.text "void loop() { while (1) { printf(\"1\"); } }") 110 | : (PP.text "void empty() { }") 111 | : map (\(i,t) -> 112 | PP.vcat [ PP.text "void a" <> PP.int i <> PP.text "(int var0, int var1, int var2) {" 113 | , PP.nest 2 $ pp t 114 | , PP.text "}" ] 115 | ) (reverse $ zip [1..] $ ts) 116 | -- let calls = map (\(i,_) -> PP.text "a" <> PP.int i <+> PP.text "();") (zip [0..] ts) 117 | let doc = PP.render $ PP.vcat ( PP.text "#include " 118 | : (map (\(i,_) -> PP.text "extern void a" 119 | <> PP.int i <> PP.text "(int x, int y, int z);" 120 | ) (zip [1..] ts) 121 | ) 122 | ++ [ PP.text "extern void loop(); " 123 | , PP.text "extern void empty(); " ] 124 | ++ [ tDoc 125 | , PP.text "int main() {" 126 | , PP.text " int undef;" 127 | , PP.text " a0(undef, 0,1);" 128 | , PP.text "}" ]) 129 | writeFile fn1 doc 130 | writeFile fn2 (PP.render tsDoc) 131 | 132 | compileAndRun :: CFlags -> IO Bool 133 | compileAndRun cflags@CFlags{..} = do 134 | let fn1 = _outFN ++ "1.c" 135 | fn2 = _outFN ++ "2.c" 136 | putStrLn "Compiling...\n" 137 | -- | Compile 138 | e1 <- runWait $ "clang-3.6 -Wno-tautological-compare -Wno-parentheses-equality " 139 | ++ fn1 ++ " " ++ fn2 ++ " -o test.NotOpt" 140 | e2 <- runWait $ "clang-3.6 -Wno-tautological-compare -Wno-parentheses-equality -O3" 141 | ++ " -mllvm -inline-threshold=10000 " 142 | ++ fn1 ++ " " ++ fn2 ++ " -o test.Opt" 143 | 144 | -- | Run and test 145 | putStrLn "Running and testing outputs...\n" 146 | (ePlain, outPlain, _) <- readProcessWithExitCode "timeout" [show _timeout, "./test.NotOpt"] "" 147 | (eOpt, outOpt, _) <- readProcessWithExitCode "timeout" [show _timeout, "./test.Opt"] "" 148 | return (outPlain == outOpt) 149 | 150 | runSingleBatch :: CFlags -> IO Bool 151 | runSingleBatch cflags@CFlags{..} = do 152 | (mts : _ ) <- sample' stmtGen 153 | case mts of 154 | Just ts -> do 155 | let fn1 = _outFN ++ "1.c" 156 | fn2 = _outFN ++ "2.c" 157 | dump ts fn1 fn2 158 | compileAndRun cflags 159 | Nothing -> error "Unsuccesful generation" 160 | 161 | -- TODO: Expose Luck options? 162 | data CFlags = CFlags { _numTries :: !Int 163 | , _timeout :: !Double 164 | , _outFN :: String 165 | } 166 | deriving (Eq, Show, Read, Typeable, Data) 167 | 168 | cFlags = CFlags { _numTries = 100 169 | &= name "num-tries" &= help "Number of tests to run" 170 | , _timeout = 0.1 171 | &= name "timeout" &= help "Timeout per-test (s)" 172 | , _outFN = "test" 173 | &= name "filename" &= help "Generated .c filename" 174 | } 175 | 176 | main :: IO () 177 | main = do 178 | cflags@CFlags{..} <- cmdArgs cFlags 179 | let aux 0 = putStrLn "Counterexample not found" 180 | aux n = do 181 | b <- runSingleBatch cflags 182 | if b then putStrLn "Found!" 183 | else aux $ n-1 184 | aux _numTries 185 | -------------------------------------------------------------------------------- /luck/examples-template/ModuleIntro.txt: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import qualified Control.Exception as E 3 | import System.IO 4 | 5 | handler (E.ErrorCall s) = putStrLn $ "*** Exception" 6 | 7 | incomplete1 0 = [undefined] 8 | incomplete1 n = n:(incomplete1 $ n-1) 9 | incomplete2 0 = undefined 10 | incomplete2 n = n:(incomplete2 $ n-1) 11 | 12 | main = do 13 | hSetBuffering stdout NoBuffering 14 | forM_ codelist $ \code -> do 15 | forM_ [0..2] $ \x -> do 16 | E.catch (print $ code $ incomplete1 x) handler 17 | E.catch (print $ code $ incomplete2 x) handler 18 | putStrLn "-----------------------" 19 | 20 | codelist = [ 21 | 22 | -------------------------------------------------------------------------------- /luck/examples-template/Stlc-template.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} 2 | 3 | import Data.Data 4 | import Luck.Template 5 | import Test.QuickCheck 6 | 7 | data Type = TArrow Type Type 8 | | TList 9 | | TInt 10 | deriving (Show, Data) 11 | 12 | data Term = Var Int 13 | | Abs Int Type Term 14 | | App Type Term Term 15 | deriving (Show, Data) 16 | 17 | gen :: Gen (Maybe Term) 18 | gen = $(mkGenQ defFlags{_fileName="examples/STLC.luck", _maxUnroll=2}) tProxy1 19 | {-# NOINLINE gen #-} 20 | 21 | main = sample gen 22 | -------------------------------------------------------------------------------- /luck/examples-template/Stlc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} 2 | import Control.Monad 3 | import Control.Applicative 4 | import Control.Arrow 5 | 6 | import Luck.Template 7 | import Test.QuickCheck 8 | 9 | import Data.Data 10 | import Data.Maybe 11 | import Data.List 12 | 13 | import System.Directory 14 | import System.Process 15 | 16 | import Data.Data 17 | 18 | data Type = TArrow Type Type 19 | | TList 20 | | TInt 21 | deriving (Show, Data) 22 | 23 | sizeT :: Type -> Int 24 | sizeT (TArrow t1 t2) = 1 + sizeT t1 + sizeT t2 25 | sizeT _ = 1 26 | 27 | data Term = Var Int 28 | | Abs Int Type Term 29 | | App Type Term Term 30 | deriving (Show, Data) 31 | 32 | size :: Term -> Int 33 | size (Var _) = 1 34 | size (Abs _ t e) = 1 + sizeT t + size e 35 | size (App t e1 e2) = 1 + sizeT t + size e1 + size e2 36 | 37 | 38 | mapping :: Int -> String 39 | mapping 0 = "(undefined :: Int)" 40 | mapping 1 = "id" 41 | mapping 2 = "seq" 42 | mapping 3 = "id" 43 | mapping 4 = "seq" 44 | mapping n = "x" ++ show n 45 | 46 | unparse :: Term -> String 47 | unparse (Var x) = mapping x 48 | unparse (Abs n _ e) = "(\\" ++ mapping n ++ " -> " ++ unparse e ++ ")" 49 | unparse (App _ e1 e2) = "(" ++ unparse e1 ++ " " ++ unparse e2 ++ ")" 50 | 51 | ghcGen :: Gen (Maybe Term) 52 | ghcGen = $(mkGenQ defFlags{_fileName="examples/STLC.luck", _maxUnroll=2}) tProxy1 53 | 54 | --main = do 55 | -- (x:_) <- sample' gen 56 | -- case x of 57 | -- Just t -> putStrLn $ unparse t 58 | -- Nothing -> putStrLn "NOTHING" 59 | 60 | runWait c = do 61 | p <- runCommand c 62 | waitForProcess p 63 | 64 | generateAndPack :: IO () 65 | generateAndPack = do 66 | -- | Generate a file 67 | putStrLn "Generating 1100 tests...\n" 68 | let tmp = "examples-template/Main.hs" 69 | funs <- (catMaybes . concat) <$> (replicateM 10 $ sample' ghcGen) 70 | putStrLn "Writing to haskell module...\n" 71 | copyFile "examples-template/ModuleIntro.txt" tmp 72 | let appendString = " " ++ (concat $ intersperse ",\n " (fmap unparse funs)) 73 | appendFile tmp appendString 74 | appendFile tmp " ]\n" 75 | 76 | compileAndRun :: String -> IO Bool 77 | compileAndRun fileBase = do 78 | let dotO = fileBase ++ ".o" 79 | dotHs = fileBase ++ ".hs" 80 | putStrLn "Compiling...\n" 81 | -- | Compile 82 | runWait $ "rm " ++ dotO 83 | e1 <- runWait $ "ghc-6.12.1 -o Main " ++ dotHs 84 | runWait $ "rm " ++ dotO 85 | -- | Run and test 86 | putStrLn " Running and testing outputs...\n" 87 | e2 <- runWait $ "ghc-6.12.1 -o MainOpt -O2 " ++ dotHs 88 | (ePlain, outPlain, _) <- readProcessWithExitCode "./Main" [] "" 89 | (eOpt, outOpt, _) <- readProcessWithExitCode "./MainOpt" [] "" 90 | return (outPlain == outOpt) 91 | 92 | main :: IO () 93 | main = do 94 | -- Calculate sizes 95 | funs <- (catMaybes . concat) <$> (replicateM 1 $ sample' ghcGen) 96 | -- putStrLn $ show $ sum $ fmap size funs 97 | generateAndPack 98 | b <- compileAndRun "examples-template/Main" 99 | if b then putStrLn "New Batch\n" -- >> main 100 | else do 101 | putStrLn "Counterexample Found!" 102 | files <- getDirectoryContents "examples-template/ghc-counters" 103 | copyFile "examples-template/Main.hs" ("examples-template/ghc-counters/" 104 | ++ (show $ length files) 105 | ++ ".hs") 106 | -------------------------------------------------------------------------------- /luck/examples-template/combination.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | import Luck.Template 3 | import Test.QuickCheck 4 | 5 | gen :: Gen (Maybe [Bool]) 6 | gen = $(mkGenQ defFlags{_fileName="examples/Combination.luck",_maxUnroll=14}) tProxy1 7 | 8 | main = sample $ (fmap . fmap . fmap) fromEnum gen 9 | -------------------------------------------------------------------------------- /luck/examples-template/ghc-counters/0.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import qualified Control.Exception as E 3 | import System.IO 4 | 5 | handler (E.ErrorCall s) = putStrLn $ "*** Exception" 6 | 7 | incomplete1 0 = [undefined] 8 | incomplete1 n = n:(incomplete1 $ n-1) 9 | incomplete2 0 = undefined 10 | incomplete2 n = n:(incomplete2 $ n-1) 11 | 12 | main = do 13 | hSetBuffering stdout NoBuffering 14 | forM_ codelist $ \code -> do 15 | forM_ [0..2] $ \x -> do 16 | E.catch (print $ code $ incomplete1 x) handler 17 | E.catch (print $ code $ incomplete2 x) handler 18 | putStrLn "-----------------------" 19 | 20 | codelist = [ 21 | 22 | ((\x16 -> (\x17 -> ((\x18 -> x17) x17))) (id (undefined :: Int))), 23 | (\x16 -> ((seq id) (((\x17 -> (\x18 -> x16)) ((seq id) x16)) (((\x17 -> (\x18 -> (\x19 -> (undefined :: Int)))) x16) ((\x17 -> x16) x16))))), 24 | (\x16 -> (((\x17 -> (\x18 -> ((\x19 -> x19) x18))) ((\x17 -> x16) (undefined :: Int))) ((\x17 -> x16) ((\x17 -> (\x18 -> x16)) x16)))), 25 | ((\x16 -> (((\x17 -> seq) (id (undefined :: Int))) (\x17 -> (undefined :: Int)))) (undefined :: Int)), 26 | ((\x16 -> (\x17 -> x17)) ((id seq) ((\x16 -> (undefined :: Int)) (id ((\x16 -> (undefined :: Int)) (\x16 -> x16)))))), 27 | (seq ((((\x16 -> id) (undefined :: Int)) seq) (undefined :: Int))), 28 | (seq id), 29 | (\x16 -> x16), 30 | (\x16 -> ((\x17 -> x16) (((\x17 -> id) (\x17 -> (\x18 -> (undefined :: Int)))) (id (undefined :: Int))))), 31 | (((\x16 -> ((\x17 -> (\x18 -> (\x19 -> x19))) (undefined :: Int))) (undefined :: Int)) ((\x16 -> (undefined :: Int)) (((\x16 -> (\x17 -> (\x18 -> (undefined :: Int)))) (undefined :: Int)) (undefined :: Int)))), 32 | (seq id), 33 | (seq id), 34 | (seq (((((\x16 -> (\x17 -> id)) (undefined :: Int)) (id seq)) (\x16 -> id)) (undefined :: Int))), 35 | (seq id), 36 | ((\x16 -> (seq (\x17 -> (undefined :: Int)))) ((\x16 -> (\x17 -> (id (undefined :: Int)))) (undefined :: Int))), 37 | (((\x16 -> seq) (undefined :: Int)) (\x16 -> (undefined :: Int))), 38 | (\x16 -> (((\x17 -> (\x18 -> x16)) x16) (\x17 -> ((\x18 -> (\x19 -> x16)) (\x18 -> (\x19 -> (\x20 -> x17))))))), 39 | (seq id), 40 | (((\x16 -> seq) (undefined :: Int)) ((\x16 -> id) ((\x16 -> (\x17 -> x16)) (undefined :: Int)))), 41 | (seq (\x16 -> (undefined :: Int))), 42 | (seq id), 43 | (\x16 -> ((seq id) ((\x17 -> x16) x16))), 44 | (\x16 -> ((\x17 -> ((\x18 -> x16) (undefined :: Int))) x16)), 45 | ((\x16 -> (\x17 -> ((seq (seq (undefined :: Int))) x17))) (\x16 -> (((\x17 -> seq) (undefined :: Int)) id))), 46 | (((((\x16 -> (\x17 -> (\x18 -> seq))) (\x16 -> (\x17 -> (undefined :: Int)))) (undefined :: Int)) ((id (id (\x16 -> (\x17 -> (undefined :: Int))))) (undefined :: Int))) ((id seq) ((\x16 -> (undefined :: Int)) (undefined :: Int)))), 47 | (((\x16 -> ((\x17 -> (\x18 -> (\x19 -> x19))) (undefined :: Int))) ((\x16 -> (undefined :: Int)) ((seq (undefined :: Int)) (undefined :: Int)))) ((((\x16 -> (\x17 -> (\x18 -> (\x19 -> (\x20 -> (undefined :: Int)))))) ((\x16 -> (\x17 -> x16)) (undefined :: Int))) ((\x16 -> (\x17 -> (\x18 -> (undefined :: Int)))) (undefined :: Int))) ((\x16 -> (id (undefined :: Int))) (\x16 -> (undefined :: Int))))), 48 | (seq ((((\x16 -> (\x17 -> seq)) (undefined :: Int)) (\x16 -> (\x17 -> (undefined :: Int)))) ((\x16 -> (undefined :: Int)) (id (id (undefined :: Int)))))), 49 | (seq (\x16 -> (undefined :: Int))), 50 | (\x16 -> ((((\x17 -> (\x18 -> (\x19 -> x16))) (undefined :: Int)) x16) (((\x17 -> id) (id (undefined :: Int))) (((\x17 -> (\x18 -> (\x19 -> (\x20 -> (undefined :: Int))))) (undefined :: Int)) ((\x17 -> (undefined :: Int)) x16))))), 51 | (seq (seq (id (undefined :: Int)))), 52 | ((\x16 -> (\x17 -> x17)) (undefined :: Int)), 53 | ((\x16 -> (seq id)) (undefined :: Int)), 54 | ((((\x16 -> (\x17 -> seq)) (undefined :: Int)) (undefined :: Int)) (\x16 -> (undefined :: Int))), 55 | (id (seq (id (\x16 -> seq x16 id) (undefined :: Int)))), 56 | (((\x16 -> seq) ((\x16 -> (undefined :: Int)) (\x16 -> (undefined :: Int)))) (((\x16 -> seq) (undefined :: Int)) (id (undefined :: Int)))), 57 | (\x16 -> ((seq id) ((\x17 -> x16) (undefined :: Int)))), 58 | ((((\x16 -> (\x17 -> seq)) (\x16 -> x16)) id) (seq (id (undefined :: Int)))), 59 | (((\x16 -> seq) (undefined :: Int)) (\x16 -> (undefined :: Int))), 60 | ((((\x16 -> (\x17 -> seq)) (undefined :: Int)) ((\x16 -> (\x17 -> (\x18 -> (\x19 -> (\x20 -> (undefined :: Int)))))) (id (undefined :: Int)))) (seq (undefined :: Int))), 61 | (seq ((id ((\x16 -> seq) (undefined :: Int))) (undefined :: Int))), 62 | ((\x16 -> (seq (\x17 -> x17))) (id ((\x16 -> (x16 (\x17 -> id))) (\x16 -> (undefined :: Int))))), 63 | (seq id), 64 | (seq ((\x16 -> (\x17 -> (undefined :: Int))) (\x16 -> ((\x17 -> (\x18 -> (\x19 -> x18))) (id (undefined :: Int)))))), 65 | (\x16 -> (((((\x17 -> (\x18 -> seq)) (\x17 -> (\x18 -> (undefined :: Int)))) (\x17 -> (id (undefined :: Int)))) ((\x17 -> ((\x18 -> id) x16)) x16)) (((\x17 -> (\x18 -> x16)) (id (undefined :: Int))) x16))), 66 | (((((\x16 -> (\x17 -> (\x18 -> (\x19 -> x18)))) (undefined :: Int)) (id (id (undefined :: Int)))) (((\x16 -> seq) (\x16 -> (\x17 -> (\x18 -> (undefined :: Int))))) id)) (seq (undefined :: Int))), 67 | (seq id), 68 | (seq id), 69 | (seq ((id (id (\x16 -> (seq (undefined :: Int))))) (id (id (id (undefined :: Int)))))), 70 | (\x16 -> x16), 71 | (\x16 -> x16), 72 | (((((\x16 -> ((\x17 -> (\x18 -> (\x19 -> seq))) (\x17 -> x17))) (undefined :: Int)) (\x16 -> (id (undefined :: Int)))) (id (id (undefined :: Int)))) id), 73 | ((((\x16 -> (\x17 -> seq)) (\x16 -> (\x17 -> x16))) (undefined :: Int)) ((id (\x16 -> (seq (undefined :: Int)))) (id (undefined :: Int)))), 74 | (((((\x16 -> (\x17 -> (\x18 -> seq))) (\x16 -> (\x17 -> (undefined :: Int)))) (seq (undefined :: Int))) (\x16 -> (undefined :: Int))) (\x16 -> (undefined :: Int))), 75 | (seq ((\x16 -> (\x17 -> (undefined :: Int))) (undefined :: Int))), 76 | (((\x16 -> seq) (id ((\x16 -> (undefined :: Int)) (seq id)))) ((\x16 -> (\x17 -> (undefined :: Int))) ((\x16 -> (id (undefined :: Int))) (undefined :: Int)))), 77 | (seq id), 78 | (((((\x16 -> (\x17 -> (\x18 -> (\x19 -> (\x20 -> x20))))) (id ((\x16 -> (undefined :: Int)) (undefined :: Int)))) (\x16 -> (undefined :: Int))) (undefined :: Int)) (((\x16 -> id) (undefined :: Int)) (((id (\x16 -> id)) (undefined :: Int)) (undefined :: Int)))), 79 | (seq (seq (id (((\x16 -> (\x17 -> (undefined :: Int))) (undefined :: Int)) (undefined :: Int))))), 80 | (seq ((((\x16 -> id) (undefined :: Int)) (\x16 -> ((\x17 -> (\x18 -> (undefined :: Int))) (undefined :: Int)))) (undefined :: Int))), 81 | (((((\x16 -> (\x17 -> (\x18 -> seq))) (id (undefined :: Int))) ((\x16 -> (undefined :: Int)) (\x16 -> (undefined :: Int)))) (((\x16 -> id) (undefined :: Int)) (undefined :: Int))) (seq (id (undefined :: Int)))), 82 | (seq id), 83 | ((((\x16 -> (\x17 -> seq)) (undefined :: Int)) (undefined :: Int)) (\x16 -> (undefined :: Int))), 84 | (seq ((\x16 -> id) ((\x16 -> (undefined :: Int)) (\x16 -> (id (undefined :: Int)))))), 85 | (((\x16 -> (\x17 -> ((\x18 -> (\x19 -> x19)) x16))) (undefined :: Int)) (((id (\x16 -> id)) (undefined :: Int)) (undefined :: Int))), 86 | (((\x16 -> seq) (id (id (undefined :: Int)))) (seq ((seq ((\x16 -> (undefined :: Int)) (\x16 -> (undefined :: Int)))) (id (id (undefined :: Int)))))), 87 | (((\x16 -> seq) (undefined :: Int)) ((id (id seq)) ((seq (undefined :: Int)) (undefined :: Int)))), 88 | (seq ((((\x16 -> ((\x17 -> id) (undefined :: Int))) (\x16 -> (\x17 -> (\x18 -> (undefined :: Int))))) (\x16 -> id)) (undefined :: Int))), 89 | (\x16 -> ((seq (\x17 -> (undefined :: Int))) x16)), 90 | ((((\x16 -> ((\x17 -> x17) (\x17 -> (\x18 -> (\x19 -> x19))))) (\x16 -> ((\x17 -> (undefined :: Int)) (undefined :: Int)))) (undefined :: Int)) (\x16 -> (undefined :: Int))), 91 | (seq id), 92 | (((\x16 -> seq) ((\x16 -> (undefined :: Int)) (\x16 -> (undefined :: Int)))) ((id seq) (undefined :: Int))), 93 | (\x16 -> (((\x17 -> (\x18 -> x16)) (((\x17 -> (\x18 -> (\x19 -> x16))) (\x17 -> (\x18 -> (\x19 -> x16)))) (\x17 -> ((\x18 -> id) (\x18 -> x16))))) ((\x17 -> x16) (\x17 -> (\x18 -> (undefined :: Int)))))), 94 | ((\x16 -> (\x17 -> (((\x18 -> (\x19 -> x18)) ((\x18 -> x17) (\x18 -> x17))) (\x18 -> x17)))) (\x16 -> (id ((\x17 -> (id (undefined :: Int))) (x16 (undefined :: Int)))))), 95 | ((\x16 -> (((\x17 -> seq) (undefined :: Int)) (\x17 -> (undefined :: Int)))) (seq ((seq (undefined :: Int)) (undefined :: Int)))), 96 | (\x16 -> ((seq (\x17 -> (id (undefined :: Int)))) x16)), 97 | (seq (\x16 -> (id ((\x17 -> x16) (\x17 -> (\x18 -> x17)))))), 98 | ((((\x16 -> (\x17 -> seq)) ((seq (undefined :: Int)) ((\x16 -> (undefined :: Int)) (undefined :: Int)))) (seq (undefined :: Int))) ((((\x16 -> (\x17 -> seq)) ((\x16 -> (undefined :: Int)) (undefined :: Int))) (\x16 -> (undefined :: Int))) (id (undefined :: Int)))), 99 | (((\x16 -> seq) (\x16 -> (id (undefined :: Int)))) ((id seq) (((\x16 -> id) (undefined :: Int)) (undefined :: Int)))), 100 | (\x16 -> ((seq (seq (undefined :: Int))) (((\x17 -> (\x18 -> x18)) x16) x16))), 101 | (seq id), 102 | (\x16 -> ((\x17 -> x16) (undefined :: Int))), 103 | (((\x16 -> seq) (undefined :: Int)) ((\x16 -> ((\x17 -> id) (undefined :: Int))) (undefined :: Int))), 104 | (seq id), 105 | (\x16 -> x16), 106 | (seq (\x16 -> x16)), 107 | (seq (seq (id ((\x16 -> (undefined :: Int)) (undefined :: Int))))), 108 | (\x16 -> ((\x17 -> ((\x18 -> ((\x19 -> x16) (\x19 -> (undefined :: Int)))) x16)) ((\x17 -> (\x18 -> x16)) ((\x17 -> (\x18 -> x16)) (\x17 -> ((\x18 -> x16) x16)))))), 109 | (\x16 -> x16), 110 | (((\x16 -> (\x17 -> (\x18 -> x18))) ((seq (undefined :: Int)) ((\x16 -> (undefined :: Int)) (undefined :: Int)))) (id ((seq (undefined :: Int)) (undefined :: Int)))), 111 | ((\x16 -> (\x17 -> x17)) (\x16 -> (\x17 -> (undefined :: Int)))), 112 | (((\x16 -> seq) (\x16 -> ((\x17 -> (\x18 -> x16)) (id (undefined :: Int))))) ((\x16 -> id) id)), 113 | ((((((\x16 -> (\x17 -> (\x18 -> (\x19 -> seq)))) (\x16 -> (undefined :: Int))) (undefined :: Int)) (undefined :: Int)) (id (undefined :: Int))) (\x16 -> ((\x17 -> (id (undefined :: Int))) (undefined :: Int)))), 114 | ((((\x16 -> (\x17 -> seq)) (undefined :: Int)) (id (undefined :: Int))) (seq (undefined :: Int))), 115 | (((\x16 -> (\x17 -> (((\x18 -> seq) (\x18 -> x16)) (\x18 -> (undefined :: Int))))) (undefined :: Int)) (((id (\x16 -> id)) (id (undefined :: Int))) (undefined :: Int))), 116 | (((\x16 -> seq) (seq ((\x16 -> (undefined :: Int)) (id (undefined :: Int))))) ((\x16 -> ((\x17 -> (\x18 -> (undefined :: Int))) (id (undefined :: Int)))) ((\x16 -> (\x17 -> (undefined :: Int))) (undefined :: Int)))), 117 | (seq ((\x16 -> (\x17 -> (undefined :: Int))) ((\x16 -> (\x17 -> (x17 (\x18 -> x16)))) (undefined :: Int)))), 118 | (\x16 -> ((\x17 -> x16) ((\x17 -> (\x18 -> x17)) (undefined :: Int)))), 119 | (((\x16 -> seq) (seq id)) id), 120 | (seq (seq (id (undefined :: Int)))), 121 | ((\x16 -> (seq (seq (id (undefined :: Int))))) (undefined :: Int)), 122 | (((\x16 -> (\x17 -> (\x18 -> x18))) ((\x16 -> (\x17 -> (\x18 -> (\x19 -> x19)))) (id (undefined :: Int)))) (((\x16 -> id) ((seq (undefined :: Int)) (undefined :: Int))) ((seq (undefined :: Int)) (undefined :: Int)))), 123 | (\x16 -> (((\x17 -> (seq (\x18 -> (undefined :: Int)))) x16) ((\x17 -> x16) ((\x17 -> (\x18 -> (\x19 -> (undefined :: Int)))) (\x17 -> (undefined :: Int)))))), 124 | (seq ((\x16 -> (\x17 -> (undefined :: Int))) ((\x16 -> (\x17 -> (\x18 -> (undefined :: Int)))) (id (undefined :: Int))))), 125 | (seq id), 126 | (((\x16 -> seq) (undefined :: Int)) (seq (undefined :: Int))), 127 | (\x16 -> ((seq id) ((seq id) ((\x17 -> x16) x16)))), 128 | (((\x16 -> seq) (id (undefined :: Int))) id), 129 | (\x16 -> (((\x17 -> (seq id)) (((\x17 -> (\x18 -> (\x19 -> x17))) (undefined :: Int)) (undefined :: Int))) x16)), 130 | (\x16 -> ((\x17 -> x16) ((((\x17 -> seq) (\x17 -> x16)) (\x17 -> (undefined :: Int))) x16))), 131 | (((\x16 -> ((\x17 -> seq) (undefined :: Int))) (undefined :: Int)) ((id (\x16 -> (\x17 -> (undefined :: Int)))) (undefined :: Int))) ] 132 | -------------------------------------------------------------------------------- /luck/examples/AC3Test.luck: -------------------------------------------------------------------------------- 1 | fun foo x y z w = (x < y && y == z && w == 10 && w > z) !x !y !z 2 | -------------------------------------------------------------------------------- /luck/examples/AC3Test2.luck: -------------------------------------------------------------------------------- 1 | fun foo x y z w = (x < y && y == z && w == 10 && w > z) 2 | -------------------------------------------------------------------------------- /luck/examples/BST.luck: -------------------------------------------------------------------------------- 1 | data Tree a = Leaf | Node a (Tree a) (Tree a) 2 | 3 | sig isBST :: Tree Int -> Int -> Int -> Bool 4 | fun isBST tree low high = 5 | case tree of 6 | | 1 % Leaf -> True 7 | | 4 % Node x l r -> (low < x && x < high) !x 8 | && isBST l low x 9 | && isBST r x high 10 | end 11 | 12 | fun test tree = isBST tree (-10) 10 13 | -------------------------------------------------------------------------------- /luck/examples/BackTrackTest.luck: -------------------------------------------------------------------------------- 1 | fun foo x = 2 | (case x of 3 | | 1 % [] -> True 4 | | 10 % _ -> False 5 | end) && 6 | (case x of 7 | | 1 % [] -> True 8 | | 10 % _ -> False 9 | end) 10 | 11 | 12 | -------------------------------------------------------------------------------- /luck/examples/BinopTest.luck: -------------------------------------------------------------------------------- 1 | fun foo1 x y = x < y 2 | fun foo2 x = 0 < x && x < 5 3 | fun foo3 x y = fix { 2 :: 0 < x && x == y && y < 5 } 4 | fun foo4 x y = not (x <= y) 5 | fun foo5 x = x < (3 + 4) 6 | -------------------------------------------------------------------------------- /luck/examples/C.luck: -------------------------------------------------------------------------------- 1 | data Exp = Var Int 2 | | Int Int 3 | | Add Exp Exp 4 | | Eq Exp Exp 5 | 6 | data Stmt = Declare Int Stmt 7 | | Asgn Int Exp Stmt 8 | | If Exp Stmt Stmt Stmt 9 | | For Int Int Int Stmt Stmt 10 | | PrintVar Int Stmt 11 | | FunCall Int [Exp] Stmt 12 | | Empty 13 | 14 | data Set = Set Int [Int] 15 | 16 | sig setSize :: Set -> Int 17 | fun setSize set = let' (Set sz _) = set in sz 18 | 19 | sig memberAux :: Int -> Int -> [Int] -> Bool 20 | fun memberAux sz x l = 21 | case l of 22 | | [] -> False 23 | | h:t -> x == h {1} || {sz} memberAux (sz - 1) x t 24 | end 25 | 26 | sig setMember :: Int -> Set -> Bool 27 | fun setMember x set = 28 | let' (Set sz l) = set in 29 | memberAux (sz - 1) x l 30 | 31 | sig setInsert :: Int -> Set -> Set 32 | fun setInsert x set = 33 | if setMember x set then set 34 | else let' (Set sz l) = set in 35 | (Set (sz + 1) (x:l)) 36 | 37 | -- Simplistic List Map 38 | -- We need a library! 39 | 40 | data Map a = Map Int [(Int, a)] 41 | 42 | sig mapSize :: Map a -> Int 43 | fun mapSize map = let' (Map sz _) = map in sz 44 | 45 | sig mapFindAux :: Int -> Int -> [(Int, a)] -> Maybe a 46 | fun mapFindAux sz x l = 47 | case l of 48 | | [] -> Nothing 49 | | (y,a):l' -> if x == y then Just a else mapFindAux sz x l' 50 | end 51 | 52 | sig mapFind :: Int -> Map a -> Maybe a 53 | fun mapFind x map = 54 | let' (Map sz l) = map in 55 | mapFindAux sz x l 56 | 57 | sig declaredVar :: Int -> Int -> Bool 58 | fun declaredVar m x = (0 < x && x < m) !x 59 | 60 | -- Generate a good expression 61 | -- mode :: if in dead code or not 62 | -- m :: number of declared variables 63 | -- vars :: initialized variables 64 | -- size :: size of expression 65 | sig goodExp :: Bool -> Int -> Set -> Int -> Exp -> Bool 66 | fun goodExp mode m vars size e = 67 | if size == 0 then 68 | case e of 69 | | 1 % Var x -> setMember x vars 70 | | 1 % Int n -> True 71 | | _ -> False 72 | end 73 | else 74 | case e of 75 | | 100 % Var x -> if mode then setMember x vars 76 | else declaredVar m x 77 | | 100 % Int n -> True 78 | | 100 % Add e1 e2 -> 79 | goodExp mode m vars (size / 2) e1 80 | && goodExp mode m vars (size / 2) e2 81 | | 100 % Eq e1 e2 -> 82 | goodExp mode m vars (size / 2) e1 83 | && goodExp mode m vars (size / 2) e2 84 | end 85 | 86 | sig goodExpN :: Int -> Int -> Bool -> Int -> Set -> Int -> [Exp] -> Bool 87 | fun goodExpN undefs n mode m vars size es = 88 | case es of 89 | | [] -> undefs == 0 && n == 0 90 | | e:es' -> 91 | if undefs > 0 then 92 | case e of 93 | | 1 % Var x -> 94 | declaredVar m x -- Can be undefined! 95 | && goodExpN (undefs - 1) n mode m vars size es' 96 | | 1 % _ -> 97 | goodExp mode m vars 2 e 98 | && goodExpN (undefs - 1) n mode m vars size es' 99 | end 100 | else if n > 0 then 101 | goodExp mode m vars 2 e && goodExpN undefs (n-1) mode m vars size es' 102 | else False 103 | end 104 | 105 | sig futureFun :: Int -> Int -> Map (Int, Int) -> Maybe (Int, Int) 106 | fun futureFun f funId ctx = 107 | if f > funId then mapFind f ctx 108 | else Nothing 109 | 110 | -- Generate a well-defined function 111 | -- funId :: Id of the function being generated 112 | -- sigCtx :: Context with function signatures 113 | -- mode :: DeadCodeMode or Not 114 | -- m :: Number of declared variables (to generate next ones. Can be undefined) 115 | -- vars :: List of initialized variables. Can be assigned *and* used 116 | -- size :: Stmt to generate 117 | -- s :: Program 118 | sig goodFun :: Int -> Map (Int, Int) -> Bool -> Int -> Set -> Int -> Int -> Stmt -> Bool 119 | fun goodFun funId ctx mode m vars forVars size s = 120 | case s of 121 | | size % Declare x s' -> 122 | x == m && goodFun funId ctx mode (m+1) vars forVars (size -1) s' 123 | | size % Asgn x e s' -> 124 | declaredVar m x 125 | && goodExp mode m vars size e 126 | && goodFun funId ctx mode m (setInsert x vars) forVars (size - 1) s' 127 | | size % If e s1 s2 s' -> 128 | goodExp mode m vars size e 129 | && goodFun funId ctx mode m vars forVars (size / 4) s1 130 | && goodFun funId ctx mode m vars forVars (size / 4) s2 131 | && goodFun funId ctx mode m vars forVars (size / 2) s' 132 | | size % For i low high sfor s' -> 133 | i == forVars && low == 0 && high == 5 && 134 | goodFun funId ctx mode m vars (forVars + 1) (size / 2) sfor && 135 | goodFun funId ctx mode m vars forVars (size / 2) s' 136 | | size % PrintVar x s' -> 137 | (if mode then setMember x vars else declaredVar m x) 138 | && goodFun funId ctx mode m vars forVars (size - 1) s' 139 | | % ((5-funId)*size) % FunCall f es s' -> -- 5 should be ctx size 140 | fresh { u :: Bool :: 1 } in 141 | case u of 142 | | 90 % True -> -- Most of the time call a function 143 | case futureFun f funId ctx of 144 | | 999 % Just (undefNo, varNo) -> 145 | goodExpN undefNo varNo mode m vars size es 146 | && goodFun funId ctx mode m vars forVars (size -1) s' 147 | | Nothing -> False 148 | end 149 | | 1 % False -> -- Loop or empty 150 | mode && 151 | case es of 152 | | 999 % [] -> 153 | ((f == -2) && goodFun funId ctx True m vars forVars (size - 1) s') {990} || {10} 154 | ((f == -1) && goodFun funId ctx False m vars forVars (size - 1) s') 155 | | _ -> False 156 | end 157 | end 158 | | 1 % Empty -> True 159 | -- | _ -> False 160 | end 161 | 162 | sig initSetAux :: Int -> Int -> [Int] -> Set 163 | fun initSetAux tot n acc = 164 | if n < 0 then Set tot acc 165 | else initSetAux tot (n-1) (n:acc) 166 | 167 | sig initSet :: Int -> Set 168 | fun initSet n = initSetAux n (n-1) [] 169 | 170 | -- Generate functions 171 | sig goodFuns :: Map (Int, Int) -> [Stmt] -> [(Int, (Int, Int))] -> Bool 172 | fun goodFuns ctx ss sigs = 173 | case sigs of 174 | | [] -> case ss of 175 | | [] -> True 176 | | _ -> False 177 | end 178 | | (fid, (undefNo, varsNo)):sigs' -> 179 | case ss of 180 | | [] -> False 181 | | s:ss' -> 182 | goodFun fid ctx True (undefNo + varsNo) (initSet varsNo) 0 42 s 183 | && goodFuns ctx ss' sigs' 184 | end 185 | end 186 | 187 | sig initCtx :: Unit -> Map (Int, Int) 188 | fun initCtx x = Map 5 [(0, (1,2)),(1, (1,2)),(2, (1,2)),(3, (1,2)),(4, (1,2))] 189 | 190 | sig main :: [Stmt] -> Bool 191 | fun main ss = 192 | let' (Map sz sigs) = initCtx () in 193 | goodFuns (Map sz sigs) ss sigs 194 | -------------------------------------------------------------------------------- /luck/examples/CaseTests.luck: -------------------------------------------------------------------------------- 1 | fun foo x = 2 | case x of 3 | | [] -> True 4 | | h:t -> False 5 | end 6 | 7 | fun bar x = 8 | case x of 9 | | [] -> False 10 | | h:t -> h 11 | end 12 | 13 | fun baz x = 14 | case x of 15 | | 1 % [] -> True 16 | | 9 % h:t -> h && baz t 17 | end 18 | -------------------------------------------------------------------------------- /luck/examples/Class.luck: -------------------------------------------------------------------------------- 1 | class Eq a where 2 | eq :: a -> a -> Bool 3 | 4 | instance Eq Int where 5 | eq x y = x == y 6 | 7 | sig eq_list :: {Eq a} => [a] -> [a] -> Bool 8 | fun eq_list x y = 9 | case (x,y) of 10 | | ([], []) -> True 11 | | (hx:xs, hy:ys) -> eq hx hy && eq_list xs ys 12 | | _ -> True 13 | end 14 | 15 | instance Eq a => Eq [a] where 16 | eq x y = eq_list x y 17 | 18 | fun test_int x y = eq [x,17] [42, y] 19 | -------------------------------------------------------------------------------- /luck/examples/Combination.luck: -------------------------------------------------------------------------------- 1 | -- Check that xs is a list of length n with exactly k True elements. 2 | -- Invariant: n >= k >= 0 3 | sig isC :: Int -> Int -> [Bool] -> Bool 4 | fun isC n k xs = 5 | case xs of 6 | | [] -> n == 0 7 | | x : xs -> 8 | n > 0 && 9 | case x of 10 | | % k+1 % True -> k > 0 && isC (n-1) (k-1) xs 11 | | % n-k+1 % False -> n > k && isC (n-1) k xs 12 | end 13 | end 14 | 15 | sig isC' :: [Bool] -> Bool 16 | fun isC' {xs :: 1000} = isC 13 3 xs 17 | -------------------------------------------------------------------------------- /luck/examples/ConjTest.luck: -------------------------------------------------------------------------------- 1 | fun foo x = True || True 2 | fun bar x = True && True 3 | 4 | -------------------------------------------------------------------------------- /luck/examples/Fresh.luck: -------------------------------------------------------------------------------- 1 | fun foo y = 2 | fresh { x :: [Int] :: 5 } in 3 | case x of 4 | | [] -> True 5 | | _ -> False 6 | end 7 | -------------------------------------------------------------------------------- /luck/examples/GT.luck: -------------------------------------------------------------------------------- 1 | fun foo x y = x < y !x !y 2 | -------------------------------------------------------------------------------- /luck/examples/InlineTest.luck: -------------------------------------------------------------------------------- 1 | fun foo x y = 2 | case (x,y) of 3 | | ([], _) -> True 4 | | (_, (h:t)) -> h > 0 5 | | _ -> False 6 | end 7 | -------------------------------------------------------------------------------- /luck/examples/LLNI.luck: -------------------------------------------------------------------------------- 1 | data Label = L | H 2 | 3 | sig eqL :: Label -> Label -> Bool 4 | fun eqL l1 l2 = 5 | case (l1, l2) of 6 | | (L, L) -> True 7 | | (H, H) -> True 8 | | _ -> False 9 | end 10 | 11 | sig isLow :: Label -> Bool 12 | fun isLow l = eqL L l 13 | 14 | sig isHigh :: Label -> Bool 15 | fun isHigh l = eqL H l 16 | 17 | sig wellFormedLabel :: Label -> Bool 18 | fun wellFormedLabel l = 19 | case l of 20 | | 3 % L -> True 21 | | 1 % H -> True 22 | end 23 | 24 | data Atom = Atom Int Label 25 | 26 | sig isHighAtom :: Atom -> Bool 27 | fun isHighAtom pc = 28 | let' (Atom _ l) = pc in 29 | isHigh l 30 | 31 | sig eqInt :: Int -> Int -> Bool 32 | fun eqInt n1 n2 = (n1 == n2) !n1 !n2 33 | 34 | sig indistAtom :: Atom -> Atom -> Bool 35 | fun indistAtom a1 a2 = 36 | let' (Atom v1 l1) = a1 in 37 | let' (Atom v2 l2) = a2 in 38 | eqL l1 l2 && if isLow l1 then eqInt v1 v2 else True 39 | 40 | sig indistAtomList :: [Atom] -> [Atom] -> Bool 41 | fun indistAtomList l1 l2 = 42 | case (l1, l2) of 43 | | ([], []) -> True 44 | | (a1:t1, a2:t2) -> indistAtom a1 a2 && indistAtomList t1 t2 45 | | _ -> False 46 | end 47 | 48 | data Instr = Noop 49 | | Add 50 | | Push Atom 51 | | Pop 52 | | Load 53 | | Store 54 | | Jump 55 | | Call Int 56 | | Return 57 | | Halt 58 | 59 | sig indistInstr :: Instr -> Instr -> Bool 60 | fun indistInstr i1 i2 = 61 | case (i1, i2) of 62 | | (Push a1, Push a2) -> indistAtom a1 a2 63 | | (Noop, Noop) -> True 64 | | (Add, Add) -> True 65 | | (Pop, Pop) -> True 66 | | (Load, Load) -> True 67 | | (Store, Store) -> True 68 | | (Jump, Jump) -> True 69 | | (Call a1, Call a2) -> eqInt a1 a2 70 | | (Return, Return) -> True 71 | | (Halt, Halt) -> True 72 | | _ -> False 73 | end 74 | 75 | data StkElt = Data Atom 76 | | Ret Atom 77 | 78 | sig indistStkElt :: StkElt -> StkElt -> Bool 79 | fun indistStkElt s1 s2 = 80 | case (s1, s2) of 81 | | (Data d1, Data d2) -> indistAtom d1 d2 82 | | (Ret a1, Ret a2) -> indistAtom a1 a2 83 | | _ -> False 84 | end 85 | 86 | sig indistStkLow :: [StkElt] -> [StkElt] -> Bool 87 | fun indistStkLow s1 s2 = 88 | case (s1, s2) of 89 | | ([], []) -> True 90 | | (x:s1', y:s2') -> indistStkElt x y && indistStkLow s1' s2' 91 | | _ -> False 92 | end 93 | 94 | sig indistStkCrop2 :: [StkElt] -> [StkElt] -> Bool 95 | fun indistStkCrop2 s1 s2 = 96 | case s2 of 97 | | ((Ret (Atom _ l)):s2') -> 98 | case l of 99 | | L -> indistStkLow s1 s2' 100 | | H -> indistStkCrop2 s1 s2' 101 | end 102 | | (_:s2') -> indistStkCrop2 s1 s2' 103 | | _ -> False 104 | end 105 | 106 | sig indistStkCrop :: [StkElt] -> [StkElt] -> Bool 107 | fun indistStkCrop s1 s2 = 108 | case s1 of 109 | | (Ret (Atom _ l):s1') -> 110 | case l of 111 | | L -> indistStkCrop2 s1' s2 112 | | H -> indistStkCrop s1' s2 113 | end 114 | | (_:s1') -> indistStkCrop s1' s2 115 | | _ -> False 116 | end 117 | 118 | sig crop :: [StkElt] -> Maybe [StkElt] 119 | fun crop x = 120 | case x of 121 | | (Ret (Atom _ l) : x') -> 122 | case l of 123 | | L -> Just x 124 | | H -> crop x' 125 | end 126 | | (_ : x') -> crop x' 127 | | _ -> Nothing 128 | end 129 | 130 | sig indistStkCrop' :: [StkElt] -> [StkElt] -> Bool 131 | fun indistStkCrop' x1 x2 = 132 | case crop x1 of 133 | | Just x1' -> 134 | case crop x2 of 135 | | Just x2' -> indistStkLow x1' x2' 136 | | _ -> False 137 | end 138 | | _ -> False 139 | end 140 | 141 | sig indistInstrList :: [Instr] -> [Instr] -> Bool 142 | fun indistInstrList i1 i2 = 143 | case (i1, i2) of 144 | | ([], []) -> True 145 | | (h1:t1, h2:t2) -> indistInstr h1 h2 && indistInstrList t1 t2 146 | | _ -> False 147 | end 148 | 149 | data AS = AS [Atom] [Instr] [StkElt] Atom 150 | 151 | fun inRange x = (x >= 0 && x < 2) !x 152 | 153 | sig length :: [a] -> Int -> Bool 154 | fun length x n = 155 | case x of 156 | | [] -> n == 0 157 | | _:t -> n > 0 && length t (n-1) 158 | end 159 | 160 | sig stackLength :: Int -> [StkElt] -> Bool 161 | fun stackLength n stack = 162 | case stack of 163 | | [] -> n == 0 164 | | (Ret _ : _ ) -> n == 0 165 | | (Data _ : s) -> n > 0 && stackLength (n-1) s 166 | end 167 | 168 | sig wellFormedInstr :: Instr -> [StkElt] -> Bool 169 | fun wellFormedInstr i stack = 170 | fresh { topFrameSize :: Int :: 5 } in 171 | ((topFrameSize >= 0) && 172 | (case i of 173 | | Noop -> True 174 | | Add -> (topFrameSize >= 2) 175 | | Push _ -> True 176 | | Pop -> (topFrameSize >= 1) 177 | | Load -> case stack of 178 | | ((Data x):_) -> 179 | let' (Atom n _) = x in inRange n 180 | | _ -> False 181 | end 182 | | Store -> (topFrameSize >= 2) && 183 | case stack of 184 | | ((Data x):_) -> 185 | let' (Atom n _) = x in inRange n 186 | | _ -> False 187 | end 188 | | Jump -> (topFrameSize >= 1) 189 | | Call n -> (topFrameSize >= n) !n 190 | | Return -> topFrameSize >= 1 191 | | Halt -> True 192 | end) !topFrameSize 193 | && stackLength topFrameSize stack) 194 | 195 | sig nth :: [a] -> Int -> Maybe a 196 | fun nth x n = 197 | case x of 198 | | [] -> Nothing 199 | | h:t -> if n == 0 then Just h 200 | else nth t (n-1) 201 | end 202 | 203 | sig wellFormedInstrs :: [Instr] -> Int -> [StkElt] -> Bool 204 | fun wellFormedInstrs instrs addr stack = 205 | case nth instrs addr of 206 | | Just i -> wellFormedInstr i stack 207 | | Nothing -> False 208 | end 209 | 210 | sig putNth :: Int -> a -> [a] -> Maybe [a] 211 | fun putNth n x l = 212 | if n == 0 then Just (x : l) 213 | else case l of 214 | | h:t -> case putNth (n-1) x t of 215 | | Just l -> Just (h:l) 216 | | _ -> Nothing 217 | end 218 | | [] -> Nothing 219 | end 220 | 221 | sig join :: Label -> Label -> Label 222 | fun join l1 l2 = 223 | case l1 of 224 | | L -> l2 225 | | H -> H 226 | end 227 | 228 | sig add :: Atom -> Atom -> Atom 229 | fun add a1 a2 = 230 | let' (Atom x1 l1) = a1 in 231 | let' (Atom x2 l2) = a2 in 232 | Atom 2 (join l1 l2) 233 | 234 | sig step :: AS -> Maybe AS 235 | fun step st = 236 | let' (AS m is s pc) = st in 237 | let' (Atom addr lab) = pc in 238 | case nth is addr of 239 | | Just i -> 240 | case i of 241 | | Noop -> Just (AS m is s (Atom (addr+1) lab)) 242 | | Add -> 243 | case s of 244 | | (Data a1:Data a2:s') -> 245 | Just (AS m is (Data (add a1 a2):s') (Atom (addr+1) lab)) 246 | | _ -> Nothing 247 | end 248 | | Push x -> Just (AS m is (Data x:s) (Atom (addr+1) lab)) 249 | | Pop -> 250 | case s of 251 | | (Data _:s') -> Just (AS m is s' (Atom (addr+1) lab)) 252 | | _ -> Nothing 253 | end 254 | | Load -> 255 | case s of 256 | | (Data a:s') -> 257 | let' (Atom ptr lptr) = a in 258 | case nth m ptr of 259 | | Just (Atom d ldata) -> 260 | Just (AS m is (Data (Atom d (join lptr ldata)):s') (Atom (addr+1) lab)) 261 | | _ -> Nothing 262 | end 263 | -- nthLoad ptr m (len, m, is, lptr, s', (Atom (addr+1) lab)) 264 | | _ -> Nothing 265 | end 266 | | Store -> 267 | case s of 268 | | (Data (Atom ptr lptr):Data x:s') -> 269 | case putNth ptr x m of 270 | | Just m' -> Just (AS m' is s' (Atom (addr+1) lab)) 271 | | _ -> Nothing 272 | end 273 | | _ -> Nothing 274 | end 275 | | Jump -> 276 | case s of 277 | | (Data (Atom ptr labPtr):s') -> 278 | Just (AS m is s' (Atom ptr (join lab labPtr))) 279 | | _ -> Nothing 280 | end 281 | | Call n -> 282 | case s of 283 | | (Data (Atom ptr labPtr):s') -> 284 | case putNth n (Ret (Atom (addr+1) lab)) s of 285 | | Just s' -> Just (AS m is s' (Atom ptr (join labPtr lab))) 286 | | _ -> Nothing 287 | end 288 | | _ -> Nothing 289 | end 290 | | Return -> 291 | case s of 292 | | (Data (Atom x lx):Ret ret:s') -> 293 | Just (AS m is (Data (Atom x (join lx lab)):s') ret) 294 | | _ -> Nothing 295 | end 296 | | Halt -> Nothing 297 | end 298 | | _ -> Nothing 299 | end 300 | 301 | sig runsLong :: Int -> AS -> Bool 302 | fun runsLong len st = 303 | if len <= 0 then True 304 | else 305 | let' (AS m i s pc) = st in 306 | let' (Atom addr lab) = pc in 307 | inRange addr && 308 | wellFormedInstrs i addr s && 309 | case step st of 310 | | 100 % Just st' -> runsLong (len - 1) st' 311 | | 1 % Nothing -> True 312 | end 313 | 314 | sig wellFormedStack :: [StkElt] -> Int -> Bool 315 | fun wellFormedStack st n = 316 | if n == 0 then 317 | case st of 318 | | [] -> True 319 | | _ -> False 320 | end 321 | else case st of 322 | | [] -> False 323 | | 3 % (Data (Atom x l) : xs) -> 324 | inRange x && wellFormedLabel l && 325 | wellFormedStack xs (n-1) 326 | | 1 % (Ret (Atom addr lab) : xs) -> 327 | inRange addr && wellFormedLabel lab && 328 | wellFormedStack xs (n-1) 329 | end 330 | 331 | sig wellFormedMemory :: [Atom] -> Int -> Bool 332 | fun wellFormedMemory l n = 333 | if n == 0 then 334 | case l of 335 | | [] -> True 336 | | _ -> False 337 | end 338 | else case l of 339 | | [] -> False 340 | | ((Atom x lab) : xs) -> inRange x 341 | && wellFormedLabel lab 342 | && wellFormedMemory xs (n-1) 343 | end 344 | 345 | -- sig wellFormed :: AS -> Bool 346 | -- fun wellFormed as = 347 | -- let' (AS mem instrs stack pc) = as in 348 | -- let' (Atom addr pcLab) = pc in 349 | -- inRange addr && length mem 2 && length instrs 2 350 | -- && length stack 4 351 | -- && wellFormedInstrs instrs addr stack 352 | 353 | sig wellFormed :: AS -> Bool 354 | fun wellFormed as = 355 | let' (AS mem instrs stack pc) = as in 356 | let' (Atom addr pcLab) = pc in 357 | inRange addr && wellFormedMemory mem 5 && length instrs 5 && wellFormedStack stack 5 358 | && runsLong 5 (AS mem instrs stack (Atom addr pcLab)) 359 | 360 | sig indistState :: AS -> AS -> Bool 361 | fun indistState as1 as2 = 362 | let' (AS m1 i1 s1 pc1) = as1 in 363 | let' (AS m2 i2 s2 pc2) = as2 in 364 | indistAtom pc1 pc2 && indistAtomList m1 m2 && indistInstrList i1 i2 365 | && if isHighAtom pc1 then indistStkCrop s1 s2 else indistStkLow s1 s2 366 | 367 | sig statePred :: AS -> AS -> Bool 368 | fun statePred as1 as2 = 369 | wellFormed as1 && indistState as1 as2 370 | 371 | -------------------------------------------------------------------------------- /luck/examples/ListSet.luck: -------------------------------------------------------------------------------- 1 | -- Simplistic ListSet data structure. 2 | -- We need a proper library 3 | data Set = Set Int [Int] 4 | 5 | sig setSize :: Set -> Int 6 | fun setSize set = let' (Set sz _) = set in sz 7 | 8 | sig memberAux :: Int -> Int -> [Int] -> Bool 9 | fun memberAux sz x l = 10 | case l of 11 | | [] -> False 12 | | h:t -> x == h {1} || {sz} memberAux (sz - 1) x t 13 | end 14 | 15 | sig setMember :: Int -> Set -> Bool 16 | fun setMember x set = 17 | let' (Set sz l) = set in 18 | memberAux (sz - 1) x l 19 | 20 | sig setInsert :: Int -> Set -> Set 21 | fun setInsert x set = 22 | if setMember x set then set 23 | else let' (Set sz l) = set in 24 | (Set (sz + 1) (x:l)) 25 | 26 | fun test x = setMember x (setInsert 4 (Set 3 [1,2,3])) 27 | 28 | 29 | -------------------------------------------------------------------------------- /luck/examples/Map.luck: -------------------------------------------------------------------------------- 1 | -- Simplistic List Map 2 | -- We need a library! 3 | 4 | data Map a = Map Int [(Int, a)] 5 | 6 | sig mapSize :: Map a -> Int 7 | fun mapSize map = let' (Map sz _) = map in sz 8 | 9 | sig mapFindAux :: Int -> Int -> [(Int, a)] -> Maybe a 10 | fun mapFindAux sz x l = 11 | case l of 12 | | [] -> Nothing 13 | | (y,a):l' -> if x == y then Just a else mapFindAux sz x l' 14 | end 15 | 16 | sig mapFind :: Int -> Map a -> Maybe a 17 | fun mapFind x map = 18 | let' (Map sz l) = map in 19 | mapFindAux sz x l 20 | 21 | sig mapInsertAux :: Int -> Int -> a -> [(Int, a)] -> Map a 22 | fun mapInsertAux sz x a l = 23 | case l of 24 | | [] -> Map 1 [(x, a)] 25 | | (y,a'):l' -> 26 | if x == y then Map sz ((y,a):l') 27 | else let' (Map sz' l'') = mapInsertAux (sz - 1) x a l' in 28 | Map (sz' + 1) ((y,a'):l'') 29 | end 30 | 31 | sig mapInsert :: Int -> a -> Map a -> Map a 32 | fun mapInsert x a map = 33 | let' (Map sz l) = map in 34 | mapInsertAux sz x a l 35 | 36 | fun test x y = case mapFind x (mapInsert 0 42 (Map 3 [(1, 1),(2,2),(3,3)])) of 37 | | Just a -> a == y 38 | | _ -> False 39 | end 40 | 41 | 42 | -------------------------------------------------------------------------------- /luck/examples/OrderedPair.luck: -------------------------------------------------------------------------------- 1 | fun f x y = x < y 2 | -------------------------------------------------------------------------------- /luck/examples/Peano.luck: -------------------------------------------------------------------------------- 1 | data Nat = O | S Nat 2 | 3 | fun gt x y = 4 | case x of 5 | | O -> False 6 | | S x' -> case y of 7 | | O -> True 8 | | S y' -> gt x' y' 9 | end 10 | end 11 | 12 | fun eqNat x y = 13 | case x of 14 | | O -> case y of 15 | | O -> True 16 | | S y' -> False 17 | end 18 | | S x' -> case y of 19 | | O -> False 20 | | S y' -> eqNat x' y' 21 | end 22 | end 23 | 24 | sig foo :: (Nat, Nat) -> Bool 25 | fun foo x = 26 | case x of 27 | | (x1, x2) -> eqNat x1 x2 28 | end 29 | 30 | data Label = L | H 31 | 32 | sig eqL :: Label -> Label -> Bool 33 | fun eqL l1 l2 = 34 | case (l1, l2) of 35 | | (L, L) -> True 36 | | (H, H) -> True 37 | | _ -> False 38 | end 39 | 40 | sig isLow :: Label -> Bool 41 | fun isLow l = eqL L l 42 | 43 | sig isHigh :: Label -> Bool 44 | fun isHigh l = eqL H l 45 | 46 | data Instr = Noop 47 | | Add 48 | | Push Atom 49 | | Pop 50 | | Load 51 | | Store 52 | | Jump 53 | | Call Nat 54 | | Return 55 | | Halt 56 | 57 | data Atom = Atom Nat Label 58 | 59 | sig indistAtom :: Atom -> Atom -> Bool 60 | fun indistAtom a1 a2 = 61 | let' (Atom v1 l1) = a1 in 62 | let' (Atom v2 l2) = a2 in 63 | eqL l1 l2 && if isLow l1 then eqNat v1 v2 else True 64 | 65 | sig fold :: (a -> b -> b) -> b -> [a] -> b 66 | fun fold f acc x = 67 | case x of 68 | | 1 % [] -> acc 69 | | 5 % h:t -> fold f (f h acc) t 70 | end 71 | 72 | sig indistAtomList :: [Atom] -> [Atom] -> Bool 73 | fun indistAtomList l1 l2 = 74 | case (l1, l2) of 75 | | ([], []) -> True 76 | | (a1:t1, a2:t2) -> indistAtom a1 a2 && indistAtomList t1 t2 77 | | _ -> False 78 | end 79 | 80 | sig indistInstr :: Instr -> Instr -> Bool 81 | fun indistInstr i1 i2 = 82 | case (i1, i2) of 83 | | (Push a1, Push a2) -> indistAtom a1 a2 84 | | (Noop, Noop) -> True 85 | | (Add, Add) -> True 86 | | (Pop, Pop) -> True 87 | | (Load, Load) -> True 88 | | (Store, Store) -> True 89 | | (Jump, Jump) -> True 90 | | (Call a1, Call a2) -> eqNat a1 a2 91 | | (Return, Return) -> True 92 | | (Halt, Halt) -> True 93 | | _ -> False 94 | end 95 | 96 | data StkElt = Data Atom 97 | | Ret Atom 98 | 99 | sig indistStkElt :: StkElt -> StkElt -> Bool 100 | fun indistStkElt s1 s2 = 101 | case (s1, s2) of 102 | | (Data d1, Data d2) -> indistAtom d1 d2 103 | | (Ret a1, Ret a2) -> indistAtom a1 a2 104 | | _ -> False 105 | end 106 | 107 | sig indistStkLow :: [StkElt] -> [StkElt] -> Bool 108 | fun indistStkLow s1 s2 = 109 | case (s1, s2) of 110 | | ([], []) -> True 111 | | (x:s1', y:s2') -> indistStkElt x y && indistStkLow s1' s2' 112 | | _ -> False 113 | end 114 | 115 | sig indistStkCrop2 :: [StkElt] -> [StkElt] -> Bool 116 | fun indistStkCrop2 s1 s2 = 117 | case s2 of 118 | | ((Ret (Atom _ l)):s2') -> 119 | case l of 120 | | L -> indistStkLow s1 s2' 121 | | H -> indistStkCrop2 s1 s2' 122 | end 123 | | (_:s2') -> indistStkCrop2 s1 s2' 124 | | _ -> False 125 | end 126 | 127 | sig indistStkCrop :: [StkElt] -> [StkElt] -> Bool 128 | fun indistStkCrop s1 s2 = 129 | case s1 of 130 | | (Ret (Atom _ l):s1') -> 131 | case l of 132 | | L -> indistStkCrop2 s1' s2 133 | | H -> indistStkCrop s1' s2 134 | end 135 | | (_:s1') -> indistStkCrop s1' s2 136 | | _ -> False 137 | end 138 | 139 | sig crop :: [StkElt] -> Maybe [StkElt] 140 | fun crop x = 141 | case x of 142 | | (Ret (Atom _ l) : x') -> 143 | case l of 144 | | L -> Just x 145 | | H -> crop x' 146 | end 147 | | (_ : x') -> crop x' 148 | | _ -> Nothing 149 | end 150 | 151 | sig indistStkCrop' :: [StkElt] -> [StkElt] -> Bool 152 | fun indistStkCrop' x1 x2 = 153 | case crop x1 of 154 | | Just x1' -> 155 | case crop x2 of 156 | | Just x2' -> indistStkLow x1' x2' 157 | | _ -> False 158 | end 159 | | _ -> False 160 | end 161 | -- case (crop x1, crop x2) of 162 | -- | (Just x1', Just x2') -> indistStkLow x1' x2' 163 | -- | _ -> False 164 | -- end 165 | 166 | sig indistInstrList :: [Instr] -> [Instr] -> Bool 167 | fun indistInstrList i1 i2 = 168 | case (i1, i2) of 169 | | ([], []) -> True 170 | | (h1:t1, h2:t2) -> indistInstr h1 h2 && indistInstrList t1 t2 171 | | _ -> False 172 | end 173 | 174 | data AS = AS [Atom] [Instr] [StkElt] Atom 175 | 176 | fun gteq x y = eqNat x y || gt x y 177 | 178 | fun inRange x = gteq x O && gt (S (S O)) x 179 | 180 | sig length :: [a] -> Nat -> Bool 181 | fun length x n = 182 | case x of 183 | | [] -> case n of 184 | | O -> True 185 | | S n' -> False 186 | end 187 | | h:t -> case n of 188 | | O -> False 189 | | S n' -> length t n' 190 | end 191 | end 192 | 193 | sig stackLength :: Nat -> [StkElt] -> Bool 194 | fun stackLength n stack = 195 | case stack of 196 | | [] -> case n of 197 | | O -> True 198 | | S _ -> False 199 | end 200 | | (Ret _ : _ ) -> 201 | case n of 202 | | O -> True 203 | | S _ -> False 204 | end 205 | | (Data _ : s) -> case n of 206 | | O -> False 207 | | S n' -> stackLength n' s 208 | end 209 | end 210 | 211 | sig wellFormedInstr :: Instr -> [StkElt] -> Bool 212 | fun wellFormedInstr i stack = 213 | fresh { stackSize :: Nat :: 10 } in 214 | (case i of 215 | | Noop -> True 216 | | Add -> gteq stackSize (S (S O)) 217 | | Push _ -> True 218 | | Pop -> gteq stackSize (S O) 219 | | Load -> case stack of 220 | | (Data (Atom n _):_) -> inRange n 221 | | _ -> False 222 | end 223 | | Store -> gteq stackSize (S (S O)) && 224 | case stack of 225 | | (Data (Atom n _):_) -> inRange n 226 | | _ -> False 227 | end 228 | | Jump -> gteq stackSize (S O) 229 | | Call n -> gteq stackSize n 230 | | Return -> gteq stackSize (S O) 231 | | Halt -> True 232 | end 233 | && stackLength stackSize stack) 234 | 235 | sig nth :: [a] -> Nat -> Maybe a 236 | fun nth x n = 237 | case x of 238 | | [] -> Nothing 239 | | h:t -> case n of 240 | | O -> Just h 241 | | S n' -> nth t n' 242 | end 243 | end 244 | 245 | sig wellFormedInstrs :: [Instr] -> Nat -> [StkElt] -> Bool 246 | fun wellFormedInstrs instrs addr stack = 247 | case nth instrs addr of 248 | | Just i -> wellFormedInstr i stack 249 | | Nothing -> False 250 | end 251 | 252 | sig wellFormed :: AS -> Bool 253 | fun wellFormed as = 254 | let' (AS mem instrs stack pc) = as in 255 | let' (Atom addr pcLab) = pc in 256 | inRange addr && length mem (S (S O)) && length instrs (S (S O)) 257 | && length stack (S (S (S (S O)))) 258 | && wellFormedInstrs instrs addr stack 259 | 260 | sig indistState :: AS -> AS -> Bool 261 | fun indistState as1 as2 = 262 | let' (AS m1 i1 s1 pc1) = as1 in 263 | let' (AS m2 i2 s2 pc2) = as2 in 264 | indistAtom pc1 pc2 && indistAtomList m1 m2 && indistInstrList i1 i2 265 | && indistStkCrop' s1 s2 266 | 267 | sig statePred :: AS -> AS -> Bool 268 | fun statePred as1 as2 = 269 | wellFormed as1 && indistState as1 as2 270 | 271 | 272 | 273 | -------------------------------------------------------------------------------- /luck/examples/PicoGenExec.luck: -------------------------------------------------------------------------------- 1 | data Label = L | H 2 | 3 | data Atom = Atom Label Int 4 | 5 | data Instr 6 | = Noop 7 | | Add 8 | | Push Atom 9 | | Pop 10 | | Load 11 | | Store 12 | | Jump 13 | | Call Int Bool 14 | | Return Bool 15 | | Halt 16 | 17 | data StkElt = Data Atom 18 | | Ret (Label, (Int, Bool)) 19 | 20 | data AS = AS [Atom] [Instr] [StkElt] Atom 21 | 22 | sig try_ :: Bool -> Bool 23 | fun try_ a = case a of 24 | | 99 % True -> True 25 | | 1 % False -> True 26 | end 27 | 28 | sig tryAndMaybe_ :: Bool -> Maybe a -> Maybe a 29 | fun tryAndMaybe_ x m = 30 | case x of 31 | | 99 % True -> m 32 | | 1 % False -> Nothing 33 | end 34 | 35 | sig eqL :: Label -> Label -> Bool 36 | fun eqL l1 l2 = 37 | case (l1, l2) of 38 | | (L, L) -> True 39 | | (H, H) -> True 40 | | _ -> False 41 | end 42 | 43 | sig isLow :: Label -> Bool 44 | fun isLow l = eqL L l 45 | 46 | sig isHigh :: Label -> Bool 47 | fun isHigh l = eqL H l 48 | 49 | sig wellFormedLabel :: Label -> Bool 50 | fun wellFormedLabel l = 51 | case l of 52 | | 1 % L -> True 53 | | 1 % H -> True 54 | end 55 | 56 | sig labelLeq :: Label -> Label -> Bool 57 | fun labelLeq l m = 58 | case l of 59 | | H -> 60 | case m of 61 | | H -> True 62 | | L -> False 63 | end 64 | | L -> True 65 | end 66 | 67 | sig isHighAtom :: Atom -> Bool 68 | fun isHighAtom pc = 69 | let' (Atom l _) = pc in 70 | isHigh l 71 | 72 | -- Does *not* instantiate 73 | sig inRange :: Int -> Bool 74 | fun inRange x = 0 <= x && x < 10 75 | 76 | sig isProgAddr :: Int -> Bool 77 | fun isProgAddr x = 0 <= x && x < 10 78 | 79 | sig isMemAddr :: Int -> Bool 80 | fun isMemAddr x = 0 <= x && x < 10 81 | 82 | -- TODO factor 83 | sig nth :: Int -> [a] -> Maybe a 84 | fun nth n l = 85 | if n == 0 then 86 | case l of 87 | | i:_ -> Just i 88 | | _ -> Nothing 89 | end 90 | else 91 | case l of 92 | | _:is -> nth (n-1) is 93 | | _ -> Nothing 94 | end 95 | 96 | sig indistAtom :: Atom -> Atom -> Bool 97 | fun indistAtom a1 a2 = 98 | let' (Atom l1 v1) = a1 in 99 | let' (Atom l2 v2) = a2 in 100 | eqL l1 l2 && 101 | if isLow l1 then 102 | (v1 == v2) !v1 !v2 103 | else 104 | inRange v1 !v1 && inRange v2 !v2 105 | 106 | sig indistAtomList :: [Atom] -> [Atom] -> Bool 107 | fun indistAtomList l1 l2 = 108 | case (l1, l2) of 109 | | ([], []) -> True 110 | | (a1:t1, a2:t2) -> indistAtom a1 a2 && indistAtomList t1 t2 111 | | _ -> False 112 | end 113 | 114 | sig indistInstr :: Instr -> Instr -> Bool 115 | fun indistInstr i1 i2 = 116 | case (i1, i2) of 117 | | (Push a1, Push a2) -> indistAtom a1 a2 118 | | (Noop, Noop) -> True 119 | | (Add, Add) -> True 120 | | (Pop, Pop) -> True 121 | | (Load, Load) -> True 122 | | (Store, Store) -> True 123 | | (Jump, Jump) -> True 124 | | (Call a1 True, Call a2 True) -> inRange a1 !a1 && (a1 == a2) !a2 125 | | (Return True, Return True) -> True 126 | | (Halt, Halt) -> True 127 | | _ -> False 128 | end 129 | 130 | sig indistStkElt :: StkElt -> StkElt -> Bool 131 | fun indistStkElt s1 s2 = 132 | case (s1, s2) of 133 | | (Data d1, Data d2) -> indistAtom d1 d2 134 | | (Ret (l1, (i1, True)), Ret (l2, (i2, True))) -> 135 | case (l1, l2) of 136 | | (H, H) -> inRange i1 && inRange i2 137 | | (L, L) -> inRange i1 && i1 == i2 138 | | _ -> False 139 | end 140 | | _ -> False 141 | end 142 | 143 | sig indistStkLow :: [StkElt] -> [StkElt] -> Bool 144 | fun indistStkLow s1 s2 = 145 | case (s1, s2) of 146 | | ([], []) -> True 147 | | (x1 : s1', x2 : s2') -> indistStkElt x1 x2 && indistStkLow s1' s2' 148 | | _ -> False 149 | end 150 | 151 | sig indistStkCrop2 :: [StkElt] -> [StkElt] -> Bool 152 | fun indistStkCrop2 s1 s2 = 153 | case s2 of 154 | | Ret (l, (i, b)) : s2' -> 155 | case l of 156 | | L -> indistStkLow s1 (Ret (l, (i, b)) : s2') 157 | | H -> indistStkCrop2 s1 s2' 158 | end 159 | | _ : s2' -> indistStkCrop2 s1 s2' 160 | | [] -> indistStkLow s1 [] 161 | end 162 | 163 | sig indistStkCrop :: [StkElt] -> [StkElt] -> Bool 164 | fun indistStkCrop s1 s2 = 165 | case s1 of 166 | | Ret (l, (i, b)) : s1' -> 167 | case l of 168 | | L -> indistStkCrop2 (Ret (l, (i, b)) : s1') s2 169 | | H -> indistStkCrop s1' s2 170 | end 171 | | _ : s1' -> indistStkCrop s1' s2 172 | | [] -> indistStkCrop2 [] s2 173 | end 174 | 175 | sig length :: [a] -> Int -> Bool 176 | fun length l n = 177 | if n == 0 then 178 | case l of 179 | | [] -> True 180 | | _ -> False 181 | end 182 | else 183 | case l of 184 | | [] -> False 185 | | (x : xs) -> length xs (n-1) 186 | end 187 | 188 | sig length' :: [a] -> Int 189 | fun length' l = 190 | case l of 191 | | [] -> 0 192 | | _ : t -> 1 + length' t 193 | end 194 | 195 | fun wellFormedAtom a = 196 | let' Atom l n = a in 197 | inRange n && 198 | wellFormedLabel l 199 | 200 | sig wellFormedMemory :: [Atom] -> Bool 201 | fun wellFormedMemory l = 202 | case l of 203 | | 1 % [] -> True 204 | | 10 % a : as -> wellFormedAtom a && wellFormedMemory as 205 | end 206 | 207 | sig wellFormedStack :: [StkElt] -> Bool 208 | fun wellFormedStack st = 209 | case st of 210 | | 1 % [] -> True 211 | | 10 % (x : xs) -> 212 | case x of 213 | | 5 % Data (Atom l x) -> 214 | inRange x && 215 | wellFormedLabel l 216 | | 1 % Ret (l, (addr, True)) -> 217 | isProgAddr addr && 218 | wellFormedLabel l 219 | | Ret (_, (_, False)) -> False 220 | end && 221 | wellFormedStack xs 222 | end 223 | 224 | sig stackLength :: [StkElt] -> Int -> (Int, Bool) 225 | fun stackLength stack n = 226 | case stack of 227 | | [] -> (n, False) 228 | | (Ret _ : _ ) -> (n, True) 229 | | (Data _ : s) -> stackLength s (n+1) 230 | end 231 | 232 | sig indistInstrList :: [Instr] -> [Instr] -> Bool 233 | fun indistInstrList i1 i2 = 234 | case (i1, i2) of 235 | | ([], []) -> True 236 | | (h1:t1, h2:t2) -> indistInstr h1 h2 && indistInstrList t1 t2 237 | | _ -> False 238 | end 239 | 240 | sig setNth :: Int -> a -> [a] -> Maybe [a] 241 | fun setNth n x l = 242 | case l of 243 | | h : t -> 244 | if n == 0 then 245 | Just (x : t) 246 | else 247 | case setNth (n-1) x t of 248 | | Just t' -> Just (h : t') 249 | | Nothing -> Nothing 250 | end 251 | | [] -> Nothing 252 | end 253 | 254 | sig insertNth :: Int -> a -> [a] -> Maybe [a] 255 | fun insertNth n x l = 256 | if n == 0 then 257 | Just (x : l) 258 | else 259 | case l of 260 | | h : t -> 261 | case insertNth (n-1) x t of 262 | | Just t' -> Just (h : t') 263 | | Nothing -> Nothing 264 | end 265 | | [] -> Nothing 266 | end 267 | 268 | sig join :: Label -> Label -> Label 269 | fun join l1 l2 = 270 | case l1 of 271 | | L -> l2 272 | | H -> H 273 | end 274 | 275 | sig add :: Atom -> Atom -> Atom 276 | fun add a1 a2 = 277 | let' (Atom l1 x1) = a1 in 278 | let' (Atom l2 x2) = a2 in 279 | let' () = () !x1 !x2 in 280 | Atom (join l1 l2) (x1 + x2) 281 | 282 | sig getReturn :: [StkElt] -> Maybe ((Label, (Int, Bool)), [StkElt]) 283 | fun getReturn s = 284 | case s of 285 | | Data _ : s -> getReturn s 286 | | [] -> Nothing 287 | | Ret r : s -> Just (r, s) 288 | end 289 | 290 | -- Just Nothing = Halted 291 | sig step :: AS -> Maybe (Maybe AS) 292 | fun step st = 293 | let' (AS m is s pc) = st in 294 | let' (Atom lPC aPC) = pc in 295 | case nth aPC is of 296 | | Just i -> 297 | case i of 298 | | 1 % Noop -> Just (Just (AS m is s (Atom lPC (aPC+1)))) 299 | | 40 % Add -> 300 | case s of 301 | | Data a1 : Data a2 : s' -> 302 | Just (Just (AS m is (Data (add a1 a2):s') (Atom lPC (aPC+1)))) 303 | | _ -> Nothing 304 | end 305 | | 80 % Push x -> 306 | Just (Just (AS m is (Data x:s) (Atom lPC (aPC+1)))) 307 | | 40 % Pop -> 308 | case s of 309 | | Data _ : s' -> 310 | Just (Just (AS m is s' (Atom lPC (aPC+1)))) 311 | | _ -> Nothing 312 | end 313 | | 40 % Load -> 314 | case s of 315 | | Data a : s' -> 316 | let' (Atom lptr ptr) = a in 317 | tryAndMaybe_ (isMemAddr ptr !ptr) ( 318 | case nth ptr m of 319 | | Just (Atom ldata d) -> 320 | let' l' = 321 | join lptr ldata 322 | in 323 | Just (Just 324 | (AS m is (Data (Atom l' d) : s') (Atom lPC (aPC+1))) 325 | ) 326 | | Nothing -> Nothing 327 | end 328 | ) 329 | | _ -> Nothing 330 | end 331 | | 40 % Store -> 332 | case s of 333 | | Data (Atom lptr ptr) : Data (Atom l n) : s' -> 334 | tryAndMaybe_ ( 335 | isMemAddr ptr !ptr && 336 | case nth ptr m of 337 | | Just (Atom l' n') -> 338 | labelLeq lPC l' && 339 | labelLeq lptr l' 340 | | Nothing -> False 341 | end 342 | ) ( 343 | let' atom = 344 | Atom (join (join lptr lPC) l) n 345 | in 346 | case setNth ptr atom m of 347 | | Just m' -> Just (Just (AS m' is s' (Atom lPC (aPC+1)))) 348 | | Nothing -> Nothing 349 | end 350 | ) 351 | | _ -> Nothing 352 | end 353 | | 40 % Jump -> 354 | case s of 355 | | Data (Atom labPtr ptr) : s' -> 356 | tryAndMaybe_ (isProgAddr ptr !ptr) ( 357 | let' lPC' = 358 | join lPC labPtr 359 | in 360 | Just (Just (AS m is s' (Atom lPC' ptr))) 361 | ) 362 | | _ -> Nothing 363 | end 364 | | 40 % Call n True -> 365 | case s of 366 | | Data (Atom labPtr ptr) : s' -> 367 | let' (stackL, _) = stackLength s' 0 in 368 | tryAndMaybe_ ( 369 | isProgAddr ptr !ptr && 370 | (0 <= n && n <= stackL) !n 371 | ) ( 372 | let' stkElt = Ret (lPC, (aPC+1, True)) in 373 | case insertNth n stkElt s' of 374 | | Just s'' -> 375 | let' l' = 376 | join labPtr lPC 377 | in 378 | Just (Just (AS m is s'' (Atom l' ptr))) 379 | | Nothing -> Nothing 380 | end 381 | ) 382 | | _ -> Nothing 383 | end 384 | | 40 % Return True -> 385 | case s of 386 | | Data (Atom lx x) : s' -> 387 | case getReturn s' of 388 | | Just ((retl, (retptr, True)), s'') -> 389 | -- (isProgAddr retPtr == True) by construction 390 | let' l' = 391 | join lx lPC 392 | in 393 | Just (Just 394 | (AS m is (Data (Atom l' x) : s'') (Atom retl retptr)) 395 | ) 396 | | _ -> Nothing 397 | end 398 | | _ -> Nothing 399 | end 400 | | Call _ False -> Nothing -- TODO 401 | | Return False -> Nothing -- TODO 402 | | 5 % Halt -> Just Nothing 403 | end 404 | | _ -> Nothing 405 | end 406 | 407 | sig runsLong :: Int -> AS -> Bool 408 | fun runsLong len st = 409 | if len <= 0 then True 410 | else 411 | try_ ( 412 | case step st of 413 | | 99 % Just state -> 414 | case state of 415 | | Nothing -> True 416 | | Just st' -> 417 | let' len' = len-1 in 418 | runsLong len' st' 419 | end 420 | | 1 % Nothing -> False 421 | end 422 | ) 423 | 424 | sig wellFormed :: AS -> Bool 425 | fun wellFormed as = 426 | let' (AS mem instrs stack pc) = as in 427 | let' (Atom pcLab addr) = pc in 428 | length instrs 10 && 429 | wellFormedMemory mem && 430 | length stack 0 && 431 | isLow pcLab && 432 | addr == 0 !addr 433 | 434 | sig indistState :: AS -> AS -> Bool 435 | fun indistState as1 as2 = 436 | let' (AS m1 i1 s1 pc1) = as1 in 437 | let' (AS m2 i2 s2 pc2) = as2 in 438 | indistAtom pc1 pc2 && indistAtomList m1 m2 && indistInstrList i1 i2 439 | -- Low, does the same as EQUIVFULL if STARTARBITRARY is *not* defined. 440 | && indistStkLow s1 s2 441 | 442 | sig statePred :: AS -> AS -> Bool 443 | fun statePred {as1 :: 100} {as2 :: 100} = 444 | wellFormed as1 && runsLong 10 as1 && indistState as1 as2 445 | -------------------------------------------------------------------------------- /luck/examples/RBT.luck: -------------------------------------------------------------------------------- 1 | -- BEGIN inductives HERE 2 | data Color = Red | Black 3 | data RBT a = Leaf | Node Color a (RBT a) (RBT a) 4 | -- END inductives HERE 5 | 6 | -- BEGIN isRBT HERE 7 | sig isRBT' :: Int -> Int -> Int -> Color -> RBT Int -> Bool 8 | fun isRBT' h low high c t = 9 | if h == 0 then 10 | case (c, t) of 11 | | (_, Leaf) -> True 12 | | (Black, Node Red x Leaf Leaf) -> (low < x && x < high) !x 13 | | _ -> False 14 | end 15 | else case (c, t) of 16 | | (Red, Node Black x l r) -> 17 | (low < x && x < high) !x 18 | && isRBT' (h-1) low x Black l 19 | && isRBT' (h-1) x high Black r 20 | | (Black, Node Red x l r) -> 21 | (low < x && x < high) !x 22 | && isRBT' h low x Red l 23 | && isRBT' h x high Red r 24 | | (Black, Node Black x l r) -> 25 | (low < x && x < high) !x 26 | && isRBT' (h-1) low x Black l 27 | && isRBT' (h-1) x high Black r 28 | | _ -> False 29 | end 30 | -- END isRBT HERE 31 | 32 | -- | This leads to h height! 33 | sig isRBT :: RBT Int -> Bool 34 | fun isRBT t = isRBT' 6 0 (42424242) Red t 35 | -------------------------------------------------------------------------------- /luck/examples/Records.luck: -------------------------------------------------------------------------------- 1 | record Foo a = { foo :: a 2 | ; bar :: Int 3 | } 4 | 5 | sig test :: Foo Int -> Bool 6 | fun test x = 7 | case x of 8 | | MkFoo a b -> a == b 9 | end 10 | 11 | sig test2 :: Foo Int -> Bool 12 | fun test2 x = foo x == bar x 13 | 14 | -------------------------------------------------------------------------------- /luck/examples/SSNI.luck: -------------------------------------------------------------------------------- 1 | -- TODO: explicitly force the whole pair of states to ensure that 2 | -- integers are in a sane range (in particular, nonnegative). 3 | 4 | data Label = L | H 5 | 6 | data Instr = Noop 7 | | Add 8 | | Push Atom 9 | | Pop 10 | | Load 11 | | Store 12 | | Jump 13 | | Call Int Bool 14 | | Return Bool 15 | | Halt 16 | 17 | data Atom = Atom Label Int 18 | 19 | data StkElt = Data Atom 20 | | Ret (Label, (Int, Bool)) 21 | 22 | data AS = AS [Atom] [Instr] [StkElt] Atom 23 | 24 | sig eqL :: Label -> Label -> Bool 25 | fun eqL l1 l2 = 26 | case (l1, l2) of 27 | | (L, L) -> True 28 | | (H, H) -> True 29 | | _ -> False 30 | end 31 | 32 | sig isLow :: Label -> Bool 33 | fun isLow l = eqL L l 34 | 35 | sig isHigh :: Label -> Bool 36 | fun isHigh l = eqL H l 37 | 38 | sig eqInt :: Int -> Int -> Bool 39 | fun eqInt n1 n2 = fix { 2 :: (n1 == n2) !n1} !n2 40 | 41 | sig indistAtom :: Atom -> Atom -> Bool 42 | fun indistAtom a1 a2 = 43 | let' (Atom l1 v1) = a1 in 44 | let' (Atom l2 v2) = a2 in 45 | eqL l1 l2 && if isLow l1 then eqInt v1 v2 else v2 >= 0 46 | 47 | sig indistAtomList :: [Atom] -> [Atom] -> Bool 48 | fun indistAtomList l1 l2 = 49 | case (l1, l2) of 50 | | ([], []) -> True 51 | | (a1:t1, a2:t2) -> indistAtom a1 a2 && indistAtomList t1 t2 52 | | _ -> False 53 | end 54 | 55 | sig indistInstr :: Instr -> Instr -> Bool 56 | fun indistInstr i1 i2 = 57 | case (i1, i2) of 58 | | (Push a1, Push a2) -> indistAtom a1 a2 59 | | (Noop, Noop) -> True 60 | | (Add, Add) -> True 61 | | (Pop, Pop) -> True 62 | | (Load, Load) -> True 63 | | (Store, Store) -> True 64 | | (Jump, Jump) -> True 65 | | (Call a1 True, Call a2 True) -> eqInt a1 a2 66 | | (Return True, Return True) -> True 67 | | (Halt, Halt) -> True 68 | | _ -> False 69 | end 70 | 71 | sig indistStkElt :: StkElt -> StkElt -> Bool 72 | fun indistStkElt s1 s2 = 73 | case (s1, s2) of 74 | | (Data d1, Data d2) -> indistAtom d1 d2 75 | | (Ret (l1, (x1, True)), Ret (l2, (x2, True))) -> indistAtom (Atom l1 x1) (Atom l2 x2) 76 | | _ -> False 77 | end 78 | 79 | sig indistStkLow :: [StkElt] -> [StkElt] -> Bool 80 | fun indistStkLow s1 s2 = 81 | case (s1, s2) of 82 | | ([], []) -> True 83 | | (x:s1', y:s2') -> indistStkElt x y && indistStkLow s1' s2' 84 | | _ -> False 85 | end 86 | 87 | sig indistStkCrop2 :: [StkElt] -> [StkElt] -> Bool 88 | fun indistStkCrop2 s1 s2 = 89 | case s2 of 90 | | ((Ret (l, _)):s2') -> 91 | case l of 92 | | L -> indistStkLow s1 s2' 93 | | H -> indistStkCrop2 s1 s2' 94 | end 95 | | (_:s2') -> indistStkCrop2 s1 s2' 96 | | _ -> False 97 | end 98 | 99 | sig indistStkCrop :: [StkElt] -> [StkElt] -> Bool 100 | fun indistStkCrop s1 s2 = 101 | case s1 of 102 | | (Ret (l, _):s1') -> 103 | case l of 104 | | L -> indistStkCrop2 s1' s2 105 | | H -> indistStkCrop s1' s2 106 | end 107 | | (_:s1') -> indistStkCrop s1' s2 108 | | _ -> False 109 | end 110 | 111 | sig crop :: [StkElt] -> Maybe [StkElt] 112 | fun crop x = 113 | case x of 114 | | (Ret (l, _) : x') -> 115 | case l of 116 | | L -> Just x 117 | | H -> crop x' 118 | end 119 | | (_ : x') -> crop x' 120 | | _ -> Nothing 121 | end 122 | 123 | sig indistStkCrop' :: [StkElt] -> [StkElt] -> Bool 124 | fun indistStkCrop' x1 x2 = 125 | case crop x1 of 126 | | Just x1' -> 127 | case crop x2 of 128 | | Just x2' -> indistStkLow x1' x2' 129 | | _ -> False 130 | end 131 | | _ -> False 132 | end 133 | 134 | sig indistInstrList :: [Instr] -> [Instr] -> Bool 135 | fun indistInstrList i1 i2 = 136 | case (i1, i2) of 137 | | ([], []) -> True 138 | | (h1:t1, h2:t2) -> indistInstr h1 h2 && indistInstrList t1 t2 139 | | _ -> False 140 | end 141 | 142 | fun inRange x = (x >= 0 && x < 2) !x 143 | 144 | sig length :: [a] -> Int -> Bool 145 | fun length x n = 146 | case x of 147 | | [] -> n == 0 148 | | _:t -> n > 0 && length t (n-1) 149 | end 150 | 151 | sig or_ :: Bool -> Bool -> Bool 152 | fun or_ a b = 153 | case a of 154 | | True -> True 155 | | False -> b 156 | end 157 | 158 | sig stackLengthGt :: [StkElt] -> Int -> Bool 159 | fun stackLengthGt stack n = 160 | or_ (n == 0) (case stack of 161 | | 5 % Data _ : s -> stackLengthGt s (n-1) 162 | | 1 % _ -> False 163 | end) 164 | 165 | sig stackReturns :: [StkElt] -> Bool 166 | fun stackReturns stack = 167 | case stack of 168 | | Ret _ : _ -> True 169 | | Data _ : stack' -> stackReturns stack' 170 | | [] -> False 171 | end 172 | 173 | sig wellFormedInstr :: Instr -> [StkElt] -> Bool 174 | fun wellFormedInstr i stack = 175 | case i of 176 | | Noop -> True 177 | | Add -> stackLengthGt stack 2 178 | | Push _ -> True 179 | | Pop -> stackLengthGt stack 1 180 | | Load -> stackLengthGt stack 1 181 | | Store -> stackLengthGt stack 2 182 | | Jump -> stackLengthGt stack 1 183 | | Call n True -> (0 <= n && n < 4) !n && stackLengthGt stack n && stackReturns stack 184 | | Return True -> stackLengthGt stack 1 185 | | Halt -> True 186 | | _ -> False 187 | end 188 | 189 | sig nth :: [a] -> Int -> Maybe a 190 | fun nth x n = 191 | case x of 192 | | [] -> Nothing 193 | | h:t -> if n == 0 then Just h 194 | else nth t (n-1) 195 | end 196 | 197 | sig wellFormedInstrs :: [Instr] -> Int -> [StkElt] -> Bool 198 | fun wellFormedInstrs instrs addr stack = 199 | case nth instrs addr of 200 | | Just i -> wellFormedInstr i stack 201 | | Nothing -> False 202 | end 203 | 204 | sig wellFormed :: AS -> Bool 205 | fun wellFormed as = 206 | let' (AS mem instrs stack pc) = as in 207 | let' (Atom pcLab addr) = pc in 208 | inRange addr && length mem 2 && length instrs 2 209 | && length stack 4 210 | && wellFormedInstrs instrs addr stack 211 | 212 | sig indistState :: AS -> AS -> Bool 213 | fun indistState as1 as2 = 214 | let' (AS m1 i1 s1 pc1) = as1 in 215 | let' (AS m2 i2 s2 pc2) = as2 in 216 | indistAtom pc1 pc2 && indistAtomList m1 m2 && indistInstrList i1 i2 217 | && indistStkCrop' s1 s2 218 | 219 | sig statePred :: AS -> AS -> Bool 220 | fun statePred as1 as2 = 221 | wellFormed as1 && indistState as1 as2 222 | -------------------------------------------------------------------------------- /luck/examples/STLC.luck: -------------------------------------------------------------------------------- 1 | data Type = TArrow Type Type 2 | | TList 3 | | TInt 4 | 5 | data Term = Var Int 6 | | Abs Int Type Term 7 | | App Type Term Term 8 | 9 | sig eqType :: Int -> Type -> Type -> Bool 10 | fun eqType size t1 t2 = 11 | case t1 of 12 | | TArrow t11 t12 -> 13 | case t2 of 14 | | TArrow t21 t22 -> eqType (size / 2) t11 t21 15 | && eqType (size / 2) t12 t22 16 | | _ -> False 17 | end 18 | | TInt -> case t2 of 19 | | TInt -> True 20 | | _ -> False 21 | end 22 | | TList -> case t2 of 23 | | TList -> True 24 | | _ -> False 25 | end 26 | end 27 | 28 | sig force :: Int -> Type -> Bool 29 | fun force size t = 30 | case t of 31 | | size % TArrow t1 t2 -> force (size / 2) t1 && force (size / 2) t2 32 | | 1 % TInt -> True 33 | | 1 % TList -> True 34 | end 35 | 36 | sig bind :: Int -> [(Int, Type)] -> Int -> Type -> Bool 37 | fun bind len g x t = 38 | case g of 39 | | [] -> False 40 | | g0:gs -> let' (gid, gt) = g0 in 41 | (x == gid && eqType 8 gt t) {1} || {len} (x /= gid && bind (len - 1) gs x t) 42 | end 43 | 44 | sig hasType :: Int -> Int -> [(Int, Type)] -> [(Int, Type)] -> Term -> Type -> Bool 45 | fun hasType ctxLen size env g e t = 46 | (case e of 47 | | 6 % Var x -> bind ctxLen g x t {1} || {4} bind 16 env x t 48 | | 4 % Abs x t1 e' -> 49 | -- eqType 5 t1 TInt && 50 | case t of 51 | | TArrow t1' t2' -> (x == ctxLen + 16) && eqType 4 t1 t1' 52 | && hasType (ctxLen + 1) (size/2) env ((x,t1'):g) e' t2' 53 | | _ -> False 54 | end 55 | | size % App t1 e1 e2 -> 56 | hasType ctxLen (size / 2) env g e1 (TArrow t1 t) 57 | && hasType ctxLen (size / 2) env g e2 t1 58 | end) -- { 1 } || { 1 } 59 | -- ((case e of 60 | -- | App t1' (App _ (Var v) (Var x)) e2 -> v == 15 && 61 | -- [| x | bind ctxLen g x (TArrow TList TList) |] && hasType ctxLen size env g e2 t 62 | -- | _ -> False 63 | -- end) || 64 | -- (case e of 65 | -- | App t1' (App _ (Var v) (Var x)) e2 -> v == 8 && 66 | -- [| x | bind ctxLen g x TInt |] && hasType ctxLen size env g e2 t 67 | -- | _ -> False 68 | -- end) || 69 | -- (case e of 70 | -- | App t1' (App _ (Var v) (Var x)) e2 -> v == 7 && 71 | -- [| x | bind ctxLen g x TList |] && hasType ctxLen size env g e2 t 72 | -- | _ -> False 73 | -- end)) 74 | 75 | sig closedTerm :: Term -> Bool 76 | fun closedTerm e = hasType 0 42 [(0, TInt) -- (undefined :: Int) 77 | ,(1, TArrow (TArrow TInt (TArrow TInt TInt)) (TArrow TInt (TArrow TInt TInt))) -- id @ Int -> Int -> Int 78 | ,(2, TArrow (TArrow TInt TInt) (TArrow TList TList)) -- seq :: (Int -> Int) -> [Int] -> [Int] 79 | ,(3, TArrow TInt TInt) -- id :: Int -> Int 80 | ,(4, TArrow TInt (TArrow TInt TInt)) -- seq :: Int -> Int -> Int 81 | -- ] [] e (TArrow TInt TInt) 82 | ] [] e (TArrow TList TList) 83 | -- ] [] e (TArrow TInt (TArrow TInt TInt)) 84 | 85 | -- 86 | -- [(0, TInt) -- Zero 87 | -- ,(1,TArrow TInt TInt) -- Succ 88 | -- ,(2, TList) -- Nil 89 | -- ,(3, TArrow TInt (TArrow TList TList)) -- Cons 90 | -- ,(4, TArrow (TArrow TInt TInt) (TArrow TList TList)) -- map 91 | -- ,(5, TList) -- undefined :: [Int] 92 | -- ,(6, TInt) -- undefined :: Int 93 | -- ,(7, TArrow TList (TArrow TList TList)) -- seq :: [Int] -> [Int] -> [Int] 94 | -- ,(8, TArrow TInt (TArrow TList TList)) -- seq :: Int -> [Int] -> [Int] 95 | -- ,(9, TArrow TList TInt) -- head 96 | -- ,(10, TArrow TList TList) -- id 97 | -- ,(11, TArrow TInt TInt) -- id 98 | -- ,(12, TArrow (TArrow TInt TInt) (TArrow TInt TInt)) -- id 99 | -- ,(13, TArrow (TArrow TList TList) (TArrow TList TList)) --id 100 | -- ,(14, TInt) -- (head []) 101 | -- ,(15, TArrow (TArrow TList TList) (TArrow TList TList)) -- seq 102 | -- ] [] e (TArrow TList TList) 103 | -- 104 | -- 105 | -- fun foo x = bind 5 106 | -------------------------------------------------------------------------------- /luck/examples/SigTest.luck: -------------------------------------------------------------------------------- 1 | data A = B | C 2 | 3 | sig foo :: Int -> Bool 4 | fun foo x = True 5 | 6 | -------------------------------------------------------------------------------- /luck/examples/Tree.luck: -------------------------------------------------------------------------------- 1 | data Tree a = Leaf a | Node a (Tree a) (Tree a) 2 | 3 | sig weird :: Tree Bool -> Bool 4 | fun weird x = 5 | case x of 6 | | Leaf x -> x 7 | | Node x l r -> not x && weird l && weird r 8 | end 9 | 10 | -------------------------------------------------------------------------------- /luck/examples/pirapirabug.luck: -------------------------------------------------------------------------------- 1 | data ContractElement = 2 | VariableDeclaration Int 3 | 4 | sig goodContractElement :: ContractElement -> Bool 5 | fun goodContractElement elm = 6 | case elm of 7 | | VariableDeclaration i -> i >= 0 8 | end 9 | 10 | sig goodContractElements :: [ContractElement] -> Bool 11 | fun goodContractElements lst = 12 | case lst of 13 | | 1 % [] -> True 14 | | 9 % h : t -> goodContractElement h && goodContractElements t 15 | end 16 | 17 | sig main :: [ContractElement] -> Bool 18 | fun main lst = 19 | goodContractElements lst 20 | -------------------------------------------------------------------------------- /luck/exec/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Luck.Main as Luck 4 | 5 | main = Luck.main 6 | -------------------------------------------------------------------------------- /luck/luck.cabal: -------------------------------------------------------------------------------- 1 | name: luck 2 | version: 0.1.0.0 3 | 4 | synopsis: A Language For Random Generators 5 | 6 | -- A longer description of the package. 7 | description: Luck is a domain specific language, which aims to make property-based random generators easier 8 | to write, read, and maintain. 9 | Target properties can be expressed in Luck as Boolean predicates, which are used to effectively 10 | direct the test generation of values by employing a combination of targeted bounded narrowing 11 | and constraint solving. 12 | The predicates can be decorated with lightweight annotations 13 | that allow controlling both the distribution of generated values and 14 | the amount of constraint solving that happens before each variable is instantiated. 15 | 16 | -- URL for the project homepage or repository. 17 | homepage: www.seas.upenn.edu/~llamp 18 | 19 | -- The license under which the package is released. 20 | license: MIT 21 | license-file: LICENSE 22 | 23 | author: Leonidas Lampropoulos 24 | 25 | maintainer: llamp@seas.upenn.edu 26 | 27 | -- A copyright notice. 28 | -- copyright: 29 | 30 | category: Testing 31 | build-type: Simple 32 | 33 | -- Extra files to be distributed with the package, such as examples or a 34 | -- README. 35 | -- extra-source-files: 36 | 37 | cabal-version: >=1.10 38 | 39 | data-files: src/Luck/Prelude.luck 40 | 41 | library 42 | hs-source-dirs: src 43 | build-depends: base >=4.7 && <5.0, pretty >=1.1 && <1.2, cmdargs, word8, 44 | utf8-string, bytestring, mtl >= 2.2.1 && < 2.3, array, 45 | containers, QuickCheck >= 2.7, random, MonadRandom >= 0.5, 46 | rosezipper >= 0.1, lens >= 4.9.1, template-haskell, 47 | transformers < 0.6, filepath 48 | build-tool-depends: happy:happy, alex:alex 49 | 50 | other-modules: Paths_luck 51 | 52 | -- Do all of these really need to be exposed? Main is probably enough for the mkGenQ's in the future 53 | exposed-modules: Common.Error, Common.SrcLoc, Common.Types, 54 | Common.Util, Common.Pretty, Common.Conversions 55 | 56 | Outer.AST, Outer.Parser, Outer.Types, 57 | Outer.Lexer, Outer.ParseMonad, Outer.Renamer, 58 | Outer.Expander, Outer.ClassMono 59 | 60 | Core.AST, Core.IntRep, Core.CSet, 61 | Core.Semantics, Core.Pretty, Core.Optimizations 62 | Core.Rigidify 63 | Core.Rigidify.Generator 64 | Core.Rigidify.Pretty 65 | Core.Rigidify.Data 66 | 67 | Luck.Main 68 | Luck.Template 69 | 70 | GHC-options: -O2 -fwarn-tabs 71 | -- GHC-options: -O2 -fwarn-tabs -fwarn-incomplete-patterns 72 | -- ghc-prof-options: -fprof-auto 73 | default-language: Haskell2010 74 | 75 | executable luck 76 | main-is: Main.hs 77 | build-depends: base >=4.8 && <5.0, luck 78 | -- GHC-options: -O2 -prof 79 | -- ghc-prof-options: -fprof-auto 80 | GHC-options: -O2 -rtsopts 81 | hs-source-dirs: exec 82 | default-language: Haskell2010 83 | -------------------------------------------------------------------------------- /luck/src/Common/Conversions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Common.Conversions (convertToCore, CoreTranslation(..), iBuiltIn) where 3 | 4 | import Common.Types 5 | import qualified Outer.AST as O 6 | import Outer.Types (oBuiltIn) 7 | import qualified Core.AST as I 8 | 9 | import Common.Error 10 | import Common.SrcLoc 11 | import Common.Util 12 | 13 | import Control.Applicative 14 | import Control.Monad 15 | import Control.Monad.State 16 | import Control.Monad.Reader 17 | import Control.Monad.Except 18 | import Control.Lens 19 | import Control.Arrow 20 | 21 | import Data.Maybe 22 | import Data.List 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as Map 25 | import Data.Set (Set) 26 | import qualified Data.Set as Set 27 | 28 | import Common.Pretty 29 | import Text.PrettyPrint.HughesPJ (Doc, (<+>)) 30 | import qualified Text.PrettyPrint.HughesPJ as PP 31 | 32 | import Debug.Trace 33 | 34 | data CoreTranslation = CT { ct_prog :: I.Prg 35 | , ct_tcEnv :: I.TcEnv 36 | , ct_vEnv :: Map O.VarId I.VarId 37 | , ct_vRev :: Map I.VarId O.VarId 38 | , ct_cEnv :: Map O.ConId I.ConId 39 | , ct_cRev :: Map I.ConId O.ConId 40 | } deriving (Show) 41 | 42 | convertToCore :: Map O.VarId O.VarId -> O.OTcEnv -> O.Prg -> 43 | Int -> 44 | Either Message CoreTranslation 45 | convertToCore vrRev tcEnv@TcEnv{..} prg defDepth = 46 | let cons = Map.keys conEnv 47 | cons' = [0..length cons] 48 | conenv' = Map.fromList $ zip cons cons' 49 | conRev' = Map.fromList $ zip cons' cons 50 | in do 51 | (prg', venv', vrev') <- convert vrRev tcEnv prg defDepth conenv' 52 | let varEnv' = Map.mapKeys (venv' !) varEnv 53 | conEnv' = Map.mapKeys (conenv' !) conEnv 54 | conIndices' = Map.mapKeys (conenv' !) conIndices 55 | tyConEnv' = Map.map (over _2 $ map (conenv' !)) tyConEnv 56 | 57 | tcEnv' :: I.TcEnv 58 | tcEnv' = TcEnv varEnv' conEnv' conIndices' tyConEnv' 59 | tcEnv' `seq` return (CT prg' tcEnv' venv' vrev' conenv' conRev') 60 | 61 | data CState = CS { venv :: Map O.VarId I.VarId 62 | , vrev :: Map I.VarId O.VarId 63 | , var :: Int 64 | , cenv :: Map O.ConId I.ConId 65 | , vrRev :: Map O.VarId O.VarId 66 | , defDepth :: Int 67 | } deriving (Show) 68 | 69 | initState :: Map O.ConId I.ConId -> Map O.VarId O.VarId -> Int -> CState 70 | initState cenv vrRev defDepth = CS Map.empty Map.empty 0 cenv vrRev defDepth 71 | 72 | type Converter = StateT CState (Either Message) 73 | 74 | freshVar :: O.VarId -> Converter I.VarId 75 | freshVar x = do 76 | rs@CS{..} <- get 77 | let x' = (var, 0) 78 | venv' = Map.insert x x' venv 79 | vrev' = Map.insert x' x vrev 80 | var' = var + 1 81 | put rs{vrev = vrev', var = var', venv = venv'} 82 | return x' 83 | 84 | addVar :: O.VarId -> I.VarId -> Converter () 85 | addVar x x' = do 86 | rs@CS{..} <- get 87 | let venv' = Map.insert x x' venv 88 | vrev' = Map.insert x' x vrev 89 | put rs{vrev = vrev', venv = venv'} 90 | 91 | lookupVar :: O.VarId -> Converter I.VarId 92 | lookupVar x = do 93 | CS{..} <- get 94 | case Map.lookup x venv of 95 | Just x' -> return x' 96 | Nothing -> throwParseE noLoc "Unknown variable" (x ++ " not found in " ++ show venv) 97 | 98 | lookupFun :: O.VarId -> Converter I.VarId 99 | lookupFun f = do 100 | CS{..} <- get 101 | case Map.lookup f venv of 102 | Just x -> return x 103 | Nothing -> throwParseE noLoc "Unknown function" f 104 | 105 | lookupCon :: O.ConId -> Converter I.ConId 106 | lookupCon x = do 107 | CS{..} <- get 108 | case Map.lookup x cenv of 109 | Just x' -> return x' 110 | Nothing -> throwParseE noLoc "Unknown constructor" x 111 | 112 | convert :: Map O.VarId O.VarId -> O.OTcEnv -> O.Prg -> Int -> Map O.ConId I.ConId -> 113 | Either Message (I.Prg, Map O.VarId I.VarId, Map I.VarId O.VarId) 114 | convert vrRev tcEnv decls defDepth cenv = 115 | case runStateT (do { CS{..} <- get 116 | ; mapM_ freshDecl decls 117 | ; decls' <- mapM (convertDecl tcEnv) decls 118 | ; return $ concat decls' } 119 | ) (initState cenv vrRev defDepth) of 120 | Right (decls', rs) -> Right (decls', venv rs, vrev rs) 121 | Left err -> Left err 122 | 123 | freshDecl :: O.Decl -> Converter () 124 | freshDecl (O.FunDecl _ fid _ _ _) = void (freshVar fid) 125 | freshDecl _ = return () 126 | 127 | convertDecl :: O.OTcEnv -> O.Decl -> Converter [I.Decl] 128 | convertDecl tcEnv (O.FunDecl loc fid vars e _) = do 129 | (fid',0) <- lookupVar fid 130 | vars' <- mapM (\(v,d) -> do 131 | v' <- freshVar v 132 | def <- defDepth <$> get 133 | case d of 134 | Just n -> return (v', n) 135 | Nothing -> return (v', def)) vars 136 | e' <- convertExp freshVar e 137 | return [ I.FunDecl loc (fid', 0) vars' e' ] 138 | convertDecl _tcEnv _decl = return [] 139 | 140 | convertAlt :: (O.VarId -> Converter I.VarId) -> O.Alt -> Converter [I.Alt] 141 | convertAlt l a@(O.Alt loc (Just exp) p e) = do 142 | exp' <- convertExp l exp 143 | p' <- convertPat l p 144 | e' <- convertExp l e 145 | return $ [I.Alt loc exp' p' e'] 146 | -- Nothings have been made Just 1 from earlier passes 147 | 148 | convertPat :: (O.VarId -> Converter I.VarId) -> O.Pat -> Converter I.Pat 149 | convertPat l (O.PVar x) = I.PVar <$> l x 150 | convertPat l (O.PLit (O.LitInt x)) = pure (I.PLit x) 151 | convertPat l O.PWild = pure $ I.PWild 152 | convertPat l (O.PApp cid pats) = do 153 | (I.ADT cid' _nil) <- convertExp l (O.Con cid) 154 | pats' <- mapM (convertPat l) pats 155 | return $ I.PApp cid' pats' 156 | 157 | convertOp2 :: O.Op2 -> I.Op2 158 | convertOp2 O.OpPlus = I.OpPlus 159 | convertOp2 O.OpMinus = I.OpMinus 160 | convertOp2 O.OpTimes = I.OpTimes 161 | convertOp2 O.OpDiv = I.OpDiv 162 | convertOp2 O.OpMod = I.OpMod 163 | convertOp2 O.OpEq = I.OpEq 164 | convertOp2 O.OpNe = I.OpNe 165 | convertOp2 O.OpLt = I.OpLt 166 | convertOp2 O.OpGt = I.OpGt 167 | convertOp2 O.OpLe = I.OpLe 168 | convertOp2 O.OpGe = I.OpGe 169 | 170 | flatten :: O.Exp -> (O.Exp, [O.Exp]) 171 | flatten (O.App (O.Con c) e) = (O.Con c, [e]) 172 | flatten (O.App (O.Var x) e) = (O.Var x, [e]) 173 | flatten (O.App (O.Fun args e) e') = (O.Fun args e, [e']) 174 | flatten (O.App e1 e2) = second (++[e2]) (flatten e1) 175 | flatten e = error ("Incorrect argument to flatten/Conversions" ++ show e) 176 | 177 | notMacro :: I.ConId -> I.ConId -> I.Exp -> I.Exp 178 | notMacro t f e = 179 | I.Case e [ (I.Alt noLoc (I.Lit 1) (I.PApp t []) (I.ADT f [])) 180 | , (I.Alt noLoc (I.Lit 1) (I.PApp f []) (I.ADT t [])) ] 181 | 182 | andMacro :: I.ConId -> I.ConId -> I.Exp -> I.Exp -> I.Exp 183 | andMacro t f e1 e2 = 184 | I.Case e1 [ (I.Alt noLoc (I.Lit 1) (I.PApp t []) e2) 185 | , (I.Alt noLoc (I.Lit 1) (I.PApp f []) (I.ADT f [])) ] 186 | 187 | orMacro :: I.VarId -> I.ConId -> I.ConId -> I.Exp -> I.Exp -> I.Exp -> I.Exp -> I.Exp 188 | orMacro u t f w1 w2 e1 e2 = 189 | I.Fresh u (I.Lit 1) $ 190 | I.Case (I.Var u) [ 191 | (I.Alt noLoc w1 (I.PApp t []) $ 192 | I.Case e1 [ (I.Alt noLoc (I.Lit 1) (I.PApp t []) (I.ADT t [])) 193 | , (I.Alt noLoc (I.Lit 1) (I.PApp f []) e2) ] 194 | ) , 195 | (I.Alt noLoc w2 (I.PApp f []) $ 196 | I.Case e2 [ (I.Alt noLoc (I.Lit 1) (I.PApp t []) (I.ADT t [])) 197 | , (I.Alt noLoc (I.Lit 1) (I.PApp f []) e1) ] 198 | ) ] 199 | 200 | convertExp :: (O.VarId -> Converter I.VarId) -> O.Exp -> Converter I.Exp 201 | convertExp l (O.Var (x, _)) = I.Var <$> lookupVar x 202 | convertExp l (O.Con c) = liftM2 I.ADT (lookupCon c) (pure []) 203 | convertExp l (O.Lit (O.LitInt x)) = pure $ I.Lit x 204 | convertExp l (O.Unop O.OpNot e) = do 205 | s <- get 206 | -- fid <- lookupVar $ vrRev s ! "notF" 207 | e' <- convertExp l e 208 | t <- lookupCon "True" 209 | f <- lookupCon "False" 210 | return $ notMacro t f e' 211 | convertExp l (O.Unop O.OpNeg e) = I.Unop I.OpNeg <$> convertExp l e 212 | -- Conj always does e1 first. 213 | -- Users can use "and" instead to explicitly control this 214 | convertExp l (O.Conj e1 e2) = do 215 | s <- get 216 | -- fid <- lookupVar $ vrRev s ! "and" 217 | e1' <- convertExp l e1 218 | e2' <- convertExp l e2 219 | trueCon <- lookupCon "True" 220 | falseCon <- lookupCon "False" 221 | return $ andMacro trueCon falseCon e1' e2' 222 | --I.Call fid [I.ADT trueCon [], I.Lit 1, I.Lit 1, e1', e2'] 223 | -- Disjunction generates a fresh unknown for choosing a branch 224 | -- Users can use "or" instead to explicitly control this 225 | convertExp l (O.Disj w1 e1 w2 e2) = do 226 | w1' <- case w1 of 227 | Just e -> convertExp l e 228 | _ -> pure $ I.Lit 1 229 | e1' <- convertExp l e1 230 | w2' <- case w2 of 231 | Just e -> convertExp l e 232 | _ -> pure $ I.Lit 1 233 | e2' <- convertExp l e2 234 | s <- get 235 | -- fid <- lookupVar $ vrRev s ! "or" 236 | freshX <- freshVar "uOr" 237 | t <- lookupCon "True" 238 | f <- lookupCon "False" 239 | return $ orMacro freshX t f w1' w2' e1' e2' 240 | -- return $ I.Fresh freshX (I.Lit 1) (I.Call fid [I.Var freshX, w1', w2', e1', e2']) 241 | convertExp l (O.Binop e1 op e2) = 242 | liftM3 I.Binop (convertExp l e1) (pure $ convertOp2 op) (convertExp l e2) 243 | convertExp l (O.App e1 e2) = 244 | case flatten (O.App e1 e2) of 245 | (O.Con c, es) -> do 246 | cid' <- lookupCon c 247 | es' <- mapM (convertExp l) es 248 | return $ I.ADT cid' es' 249 | (O.Var (fid, _), es) -> do 250 | fid' <- lookupFun fid 251 | es' <- mapM (convertExp l) es 252 | return $ I.Call (I.Var fid') es' 253 | (O.Fun args e, es) -> do 254 | fun <- convertExp l (O.Fun args e) 255 | es' <- mapM (convertExp l) es 256 | return $ I.Call fun es' 257 | _ -> error "Result of flatten incorrect/Conversions" 258 | convertExp l (O.If e1 e2 e3) = 259 | liftM3 I.If (convertExp l e1) (convertExp l e2) (convertExp l e3) 260 | convertExp l (O.Case e alts) = do 261 | e' <- convertExp l e 262 | alts' <- mapM (convertAlt l) alts 263 | return $ I.Case e' (concat alts') 264 | convertExp l (O.Let b e) = error "Implement convertExp for Let" 265 | convertExp l (O.Fun vs e) = do 266 | vars' <- forM vs $ \(v,d) -> do 267 | v' <- freshVar v 268 | def <- defDepth <$> get 269 | case d of 270 | Just n -> return (v', n) 271 | Nothing -> return (v', def) 272 | e' <- convertExp freshVar e 273 | return $ I.Fun vars' e' 274 | convertExp l (O.Fix e) = I.Fix <$> convertExp l e 275 | convertExp l (O.FixN n e) = I.FixN n <$> convertExp l e 276 | convertExp l (O.Inst e x) = 277 | liftM2 I.Inst (convertExp l e) (lookupVar x) 278 | convertExp l (O.Fresh x t en e) = 279 | liftM3 I.Fresh (freshVar x) (convertExp l en) (convertExp l e) 280 | convertExp l (O.TRACE x e) = liftM2 I.TRACE (convertExp l (O.Var (x, Nothing))) (convertExp l e) 281 | convertExp l (O.Collect e1 e2) = liftM2 I.Collect (convertExp l e1) (convertExp l e2) 282 | 283 | ppADT :: Map I.ConId O.ConId -> I.Exp -> Doc 284 | ppADT = fmap snd . sizedPpADT (Just 10) 285 | 286 | ppADTFull = fmap snd . sizedPpADT Nothing 287 | 288 | sizedPpADT :: Maybe Int -> Map I.ConId O.ConId -> I.Exp -> (Maybe Int, Doc) 289 | sizedPpADT size cenv (I.Lit n) = (size, PP.int n) 290 | sizedPpADT size cenv (I.ADT cid []) = (size, PP.text (cenv ! cid)) 291 | sizedPpADT (Just 0) _ e 292 | = (Just 0, PP.text $ "...[" ++ show (sz e) ++ " nodes]") 293 | where sz (I.ADT _ es) = 1 + sum (sz <$> es) 294 | sz (I.Lit _) = 1 295 | sz _ = error "Unhandled case: sz/Conversions" 296 | sizedPpADT size cenv (I.ADT cid es) = 297 | let (s1, docs) = mapAccumL (\s e -> sizedPpADT s cenv e) (decr size) es 298 | doc = PP.parens . PP.hang (PP.text (cenv ! cid)) 2 $ PP.sep docs 299 | in (s1, doc) 300 | sizedPpADT _ _ _ = error "Unhandled case: sizedPpADT/Conversions" 301 | 302 | decr = (subtract 1 <$>) 303 | 304 | showVals :: Bool 305 | -> Map I.ConId O.ConId -> Map I.VarId O.VarId -> [(I.VarId, I.Exp)] 306 | -> Doc 307 | showVals full crev vrev vs = PP.vcat . map ppSample $ vs 308 | where 309 | ppVar v = PP.text (vrev ! v) PP.<> PP.text ":" 310 | ppSample (v, x) = PP.hang (ppVar v) 2 (pp crev x) 311 | pp = if full then ppADTFull else ppADT 312 | 313 | iBuiltIn :: Map O.ConId I.ConId -> BuiltIn I.ConId I.TyConId I.TyVarId 314 | iBuiltIn cenv = 315 | let BuiltIn{..} = oBuiltIn 316 | in BuiltIn 317 | { biInt = biInt 318 | , biList = biList 319 | , biListArg = biListArg 320 | , biListCons = cenv Map.! biListCons 321 | , biListNil = cenv Map.! biListNil 322 | , biUnit = cenv Map.! biUnit 323 | } 324 | 325 | -------------------------------------------------------------------------------- /luck/src/Common/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | module Common.Error where 4 | 5 | import Common.SrcLoc 6 | import Common.Pretty 7 | 8 | import Data.Monoid 9 | 10 | import Text.PrettyPrint.HughesPJ ((<+>)) 11 | import qualified Text.PrettyPrint.HughesPJ as PP 12 | 13 | import System.Random 14 | import Control.Monad.Except ( MonadError (throwError) ) 15 | 16 | 17 | data MsgCode = LexerError String 18 | | ParseError String 19 | | TypeError String 20 | | InternalError String 21 | | UnSat String 22 | | BacktrackMax 23 | | GenericError String 24 | deriving (Show) 25 | 26 | instance PP MsgCode where 27 | pp (LexerError s) = PP.text "Lexical error:" <+> PP.text s 28 | pp (ParseError s) = PP.text "Parse error:" <+> PP.text s 29 | pp (TypeError s) = PP.text "Type error: " <+> PP.text s 30 | pp (InternalError s) = PP.text "Internal error: " <+> PP.text s 31 | pp (UnSat s) = PP.text "Not satisfiable: " <+> PP.text s 32 | pp (BacktrackMax) = PP.text "Maximum Backtracking Reached" 33 | pp (GenericError s) = PP.text s 34 | 35 | isUnSat :: Message -> Bool 36 | isUnSat (Message (UnSat _) _ _) = True 37 | isUnSat _ = False 38 | 39 | -- | Generic message datatype (fix later) 40 | data Message = Message { msgCode :: MsgCode 41 | , msgLoc :: SrcLoc 42 | , msgInfo :: String } 43 | deriving (Show) 44 | 45 | instance PP Message where 46 | pp (Message c l info) = 47 | PP.vcat [ pp c 48 | , PP.text "Starting at location:" <+> pp l 49 | , PP.text info ] 50 | 51 | mkInternalError :: String -> Message 52 | mkInternalError s = Message (InternalError s) noLoc "" 53 | 54 | mkLexerError :: String -> SrcLoc -> String -> Message 55 | mkLexerError s loc info = Message (LexerError s) loc info 56 | 57 | mkParseError :: String -> SrcLoc -> String -> Message 58 | mkParseError s loc info = Message (ParseError s) loc info 59 | 60 | -- | No locations for type errors is stupid 61 | mkTypeError :: String -> SrcLoc -> String -> Message 62 | mkTypeError s loc info = Message (TypeError s) loc info 63 | 64 | -- | UnSatisfiable errors 65 | mkUnSat :: String -> Message 66 | mkUnSat s = Message (UnSat s) noLoc "" 67 | 68 | mkBacktrackMax :: Message 69 | mkBacktrackMax = Message BacktrackMax noLoc "" 70 | 71 | mkError :: String -> Message 72 | mkError s = Message (GenericError s) noLoc "" 73 | 74 | -- | This is horrible :D 75 | instance Monoid Message where 76 | mempty = Message (GenericError "mempty") noLoc "" 77 | instance Semigroup Message where 78 | (<>) _m1 _m2 = error "Monoid message" 79 | 80 | instance MonadFail (Either Message) where 81 | fail s = Left $ Message (GenericError s) noLoc "" 82 | 83 | throwInternalE :: MonadError Message m => String -> m a 84 | throwInternalE = throwError . mkInternalError 85 | 86 | throwParseE :: MonadError Message m => SrcLoc -> String -> String -> m a 87 | throwParseE loc s info = throwError $ mkParseError s loc info 88 | 89 | throwTypeE :: MonadError Message m => SrcLoc -> String -> String -> m a 90 | throwTypeE loc s info = throwError $ mkTypeError s loc info 91 | 92 | throwE :: MonadError Message m => String -> m a 93 | throwE = throwError . mkError 94 | 95 | -------------------------------------------------------------------------------- /luck/src/Common/Haskellify.hs: -------------------------------------------------------------------------------- 1 | module Common.Haskellify where 2 | 3 | import Common.Pretty 4 | import Common.Conversions 5 | 6 | import qualified Outer.AST as O 7 | import qualified Core.AST as C 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /luck/src/Common/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | module Common.Pretty 3 | ( PP(..) 4 | , PPShow(..) 5 | , ppParensUnless 6 | , render 7 | , prettyPrint 8 | , module Text.PrettyPrint 9 | ) where 10 | 11 | import Text.PrettyPrint hiding (render) 12 | 13 | class PP a where 14 | pp :: a -> Doc 15 | 16 | instance PP Doc where 17 | pp = id 18 | 19 | instance PP String where 20 | pp = text 21 | 22 | instance PP Int where 23 | pp = int 24 | 25 | newtype PPShow a = PPShow a 26 | 27 | ppParensUnless :: PP a => (a -> Bool) -> a -> Doc 28 | ppParensUnless p e = (if p e then id else parens) (pp e) 29 | 30 | render :: Doc -> String 31 | render = renderStyle style { lineLength = 80 } 32 | 33 | prettyPrint :: PP a => a -> IO () 34 | prettyPrint = putStrLn . render . pp 35 | 36 | -------------------------------------------------------------------------------- /luck/src/Common/SrcLoc.hs: -------------------------------------------------------------------------------- 1 | module Common.SrcLoc where 2 | 3 | import Data.Word8 4 | import Data.Char 5 | 6 | import Common.Pretty 7 | import qualified Text.PrettyPrint.HughesPJ as PP 8 | 9 | -- | Source location information 10 | data SrcLoc = SrcLoc { srcFilename :: String 11 | , srcLine :: !Int 12 | , srcColumn :: !Int } 13 | -- ^ A single position in the source 14 | | UnknownLoc String 15 | -- ^ Generic indication of the position 16 | deriving (Eq, Ord) 17 | 18 | instance Show SrcLoc where 19 | show (SrcLoc f l c) = f ++ ":" ++ show l ++ ":" ++ show c 20 | show (UnknownLoc s) = "Unknown Location: " ++ s 21 | 22 | instance PP SrcLoc where 23 | pp = PP.text . show 24 | 25 | noLoc :: SrcLoc 26 | noLoc = UnknownLoc "-" 27 | 28 | -- | Move the source location by one word 29 | advanceSrcLoc :: SrcLoc -> Word8 -> SrcLoc 30 | advanceSrcLoc loc@(SrcLoc f l c) w 31 | | w >= 0x80 && w < 0xC0 = loc 32 | | w == fromIntegral (ord '\n') = SrcLoc f (l+1) 1 33 | | w == fromIntegral (ord '\r') = SrcLoc f l 1 34 | | otherwise = SrcLoc f l (c+1) 35 | advanceSrcLoc loc _ = loc 36 | 37 | data Located e = L { getLoc :: SrcLoc 38 | , unLoc :: e } 39 | deriving (Eq, Ord) 40 | 41 | instance Show a => Show (Located a) where 42 | show (L _loc e) = show e 43 | 44 | 45 | -------------------------------------------------------------------------------- /luck/src/Common/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | module Common.Types where 3 | 4 | import Data.Data (ConIndex) 5 | import Control.Arrow(first) 6 | import Data.Set(Set) 7 | import qualified Data.Set as Set 8 | import Data.Map.Strict(Map) 9 | import qualified Data.Map.Strict as Map 10 | 11 | import Common.Pretty (PP(..), Doc, (<+>)) 12 | import qualified Common.Pretty as PP 13 | 14 | data TcType tyconid tyvarid = TcCon tyconid Int [(TcType tyconid tyvarid)] 15 | | TcFun (TcType tyconid tyvarid) (TcType tyconid tyvarid) 16 | | TcVar tyvarid 17 | deriving (Eq, Ord, Show, Functor) 18 | 19 | fmap_tyvarid :: (tyvarid -> tyvarid') -> TcType tyconid tyvarid -> TcType tyconid tyvarid' 20 | fmap_tyvarid f (TcCon c n lst) = TcCon c n (map (fmap_tyvarid f) lst) 21 | fmap_tyvarid f (TcFun t1 t2) = TcFun (fmap_tyvarid f t1) (fmap_tyvarid f t2) 22 | fmap_tyvarid f (TcVar x) = TcVar (f x) 23 | 24 | data Scheme tyconid tyvarid = Forall (Set tyvarid) (TcType tyconid tyvarid) 25 | deriving (Eq, Show) 26 | 27 | data TcEnv varid conid tyconid tyvarid = 28 | TcEnv { varEnv :: Map varid (Scheme tyconid tyvarid) 29 | -- ^ maps variables to their types 30 | , conEnv :: Map conid (Scheme tyconid tyvarid) 31 | -- ^ maps data constructors to their types 32 | , conIndices :: Map conid ConIndex 33 | -- ^ maps data constructors to their indices in the datatype 34 | -- definition counting from 1, 35 | -- see Data.Data.ConIndex (base package) 36 | -- 37 | -- > data List a = Nil -- 1 38 | -- > | Cons a (List a) -- 2 39 | , tyConEnv :: Map tyconid ([tyvarid], [conid]) 40 | -- ^ maps type constructors to their type arguments and data constructors 41 | } deriving (Eq, Show) 42 | 43 | data BuiltIn c tc tv = BuiltIn 44 | { biInt :: tc 45 | , biList :: tc 46 | , biListArg :: tv 47 | , biListCons :: c 48 | , biListNil :: c 49 | , biUnit :: c } 50 | 51 | -- | Get the rightmost type in a function type. 52 | resultType :: TcType c v -> TcType c v 53 | resultType (TcFun _ r) = resultType r 54 | resultType t = t 55 | 56 | -- | Construct a function type 57 | mkFun :: [TcType c v] -> TcType c v -> TcType c v 58 | mkFun ts r = foldr TcFun r ts 59 | 60 | unFun :: TcType c v -> ([TcType c v], TcType c v) 61 | unFun (TcFun t1 t2) = first (t1 :) (unFun t2) 62 | unFun t = ([], t) 63 | 64 | resultTypeScheme :: Scheme c v -> TcType c v 65 | resultTypeScheme (Forall _ t) = resultType t 66 | 67 | newtype TSubstitution c v = Subs { unSubs :: Map v (TcType c v) } 68 | 69 | substVar :: Ord v => TSubstitution c v -> v -> Maybe (TcType c v) 70 | substVar = flip Map.lookup . unSubs 71 | 72 | emptySub :: TSubstitution c v 73 | emptySub = Subs Map.empty 74 | 75 | mkSub :: Ord v => [v] -> [TcType c v] -> TSubstitution c v 76 | mkSub vs ts = Subs . Map.fromList $ zip vs ts 77 | 78 | subst :: Ord v => TSubstitution c v -> TcType c v -> TcType c v 79 | subst s t@(TcVar y) = 80 | case substVar s y of 81 | Just t' -> t' 82 | Nothing -> t 83 | subst s (TcFun t1 t2) = TcFun (subst s t1) (subst s t2) 84 | subst s (TcCon c n ts) = TcCon c n (map (subst s) ts) 85 | 86 | after :: Ord v => TSubstitution c v -> TSubstitution c v -> TSubstitution c v 87 | s2 `after` s1 = Subs $ fmap (subst s2) (unSubs s1) `Map.union` unSubs s2 88 | 89 | instance (PP tc, PP tv) => PP (TcType tc tv) where 90 | pp = ppTy 0 91 | 92 | ppTy :: (PP tc, PP tv) => Int -> TcType tc tv -> Doc 93 | ppTy _ (TcVar v) = pp v 94 | ppTy _ (TcCon tc _ []) = pp tc 95 | ppTy n (TcCon tc _ targs) = 96 | par n conPrec . PP.hang (pp tc) 2 $ PP.sep (ppTy conPrec `fmap` targs) 97 | ppTy n (TcFun t1 t2) = 98 | par n funPrec . PP.hang (ppTy funPrec t1) 2 $ PP.text "->" <+> ppTy funPrec t2 99 | 100 | par n s = if n > s then PP.parens else id 101 | conPrec = 2 102 | funPrec = 1 103 | 104 | instance (PP c, PP t) => PP (Scheme c t) where 105 | pp (Forall fvs ty) = 106 | ( if Set.null fvs then id 107 | else PP.hang (PP.text "forall" <+> PP.hsep (map pp (Set.toList fvs)) <+> PP.text ".") 2 108 | ) (pp ty) 109 | 110 | -------------------------------------------------------------------------------- /luck/src/Common/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Common.Util where 3 | 4 | import Common.Error 5 | 6 | import System.Random 7 | import System.Exit 8 | 9 | import Data.Map.Strict(Map) 10 | import qualified Data.Map.Strict as Map 11 | 12 | import Control.Monad.Except 13 | import Control.Monad.Random 14 | import Control.Arrow 15 | 16 | -- import Debug.Trace 17 | 18 | -- | Randomness, ala QC 19 | frequencyR :: MonadRandom m => [(Int, m a)] -> m a 20 | frequencyR [] = error "frequencyR used with empty list" 21 | frequencyR freqs = join (frequencyR' freqs) 22 | 23 | frequencyR' :: MonadRandom m => [(Int, a)] -> m a 24 | frequencyR' [] = error "frequencyR' used with empty list" 25 | frequencyR' freqs = getRandomR (1, tot) >>= (`pick` freqs) 26 | where 27 | tot = sum (map fst freqs) 28 | pick n ((k,x):xs) 29 | | n <= k = return x 30 | | otherwise = pick (n-k) xs 31 | pick _ _ = error "internal error: frequencyR" 32 | 33 | frequencyStd :: RandomGen g => g -> [(Int, a)] -> (a, g) 34 | frequencyStd g freqs = runRand (frequencyR' freqs) g 35 | {- 36 | frequencyStd _g [] = error "frequencySTD used with empty list" 37 | frequencyStd g freqs = 38 | let (num, g') = randomR (1, tot) g 39 | in (pick num freqs, g') 40 | 41 | where tot = sum (map fst freqs) 42 | 43 | pick n ((k,x):xs) 44 | | n <= k = x 45 | | otherwise = pick (n-k) xs 46 | pick _ _ = error "internal error: frequencyR" 47 | -} 48 | 49 | freqRemoveStd :: RandomGen g => g -> [(Int, a)] -> ((a, [(Int,a)]), g) 50 | freqRemoveStd _g [] = error "freqRemoveStd used with empty list" 51 | freqRemoveStd g freqs = 52 | if tot == 0 -- Choose uniformly if all weights are 0 53 | then let (num, g') = randomR (0, length freqs - 1) g 54 | (a, (_, b) : c) = splitAt num freqs 55 | in ((b, a ++ c), g') 56 | else let (num, g') = randomR (1, tot) g 57 | in (pick num freqs, g') 58 | 59 | where tot = sum (map fst freqs) 60 | pick n ((k,x):xs) 61 | | n <= k = (x,xs) 62 | | otherwise = second ((k,x):) $ pick (n-k) xs 63 | pick _ _ = error $ "internal error: freqRemoveStd " ++ show (tot, map fst freqs) 64 | 65 | (!) :: (Show a, Ord a, Show b) => Map a b -> a -> b 66 | m ! x = 67 | case Map.lookup x m of 68 | Just x' -> x' 69 | Nothing -> error $ "ti malakies kaneis : " ++ show (x, m) 70 | 71 | -- | Converting maybe to an error 72 | note :: MonadError Message m => Message -> Maybe a -> m a 73 | note s Nothing = throwError s 74 | note _s (Just x) = return x 75 | 76 | type Choice a = [(Int, a)] 77 | 78 | choose :: MonadRandom m => Choice a -> m a 79 | choose = frequencyR' 80 | 81 | mapZip :: Ord tc => Map tc a -> Map tc b -> Map tc (a, b) 82 | mapZip = Map.intersectionWith (,) 83 | mapZip' :: Ord tc => Map tc (tvs, cs) -> Map tc alts -> Map tc (tvs, alts) 84 | mapZip' = Map.intersectionWith ((,) . fst) 85 | 86 | intSquareRoot n = last $ takeWhile (\x -> x * x <= n) [0 ..] 87 | 88 | type Bimap a b = (Map a b, Map b a) 89 | 90 | lookupL x m = Map.lookup x (fst m) 91 | lookupR y m = Map.lookup y (snd m) 92 | 93 | liftEither :: MonadError e m => Either e a -> m a 94 | liftEither = either throwError return 95 | 96 | failEither :: (Monad m, MonadFail m, Show e) => Either e a -> m a 97 | failEither = either (fail . show) return 98 | 99 | randomize :: (MonadRandom m) => [(Int, a)] -> m [a] 100 | randomize l = aux tot $ filter ((> 0) . fst) l 101 | where tot = sum $ map fst l 102 | 103 | pick n ((k,x):xs) 104 | | n <= k = ((k,x),xs) 105 | | otherwise = second ((k,x):) $ pick (n-k) xs 106 | pick n x = error $ "internal error: freqRemoveStd " ++ show (tot, n) 107 | 108 | aux _ [] = return [] 109 | aux w l = do 110 | n <- getRandomR (1, w) 111 | let ((wx, x), xs) = pick n l 112 | (x:) <$> aux (w - wx) xs 113 | -------------------------------------------------------------------------------- /luck/src/Core/AST.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Core.AST 4 | -- Copyright : (c) Leonidas Lampropoulos, 2014, 5 | -- 6 | -- License : ?? 7 | -- 8 | -- Standard AST for the Core language for generators. 9 | -- Heavily influenced by Language.Haskell.Src 10 | -- 11 | ----------------------------------------------------------------------------- 12 | module Core.AST where 13 | 14 | import Common.SrcLoc 15 | import Common.Pretty 16 | import qualified Common.Types as CT 17 | 18 | import Text.PrettyPrint.HughesPJ (Doc, (<+>)) 19 | import qualified Text.PrettyPrint.HughesPJ as PP 20 | 21 | import Data.Map.Strict(Map) 22 | import qualified Data.Map as Map 23 | 24 | -- | Types of Identifiers 25 | type ConId = Int 26 | type TyConId = String 27 | type VarId = (Int, Int) 28 | -- ^ First identifier is the unique translation from source 29 | -- string. Second is recursion depth. This approach retains type 30 | -- information (via the first) and allows sharing it across all 31 | -- "fresh" ones. 32 | type TyVarId = String 33 | type Unknown = (Int, Int) 34 | 35 | type TcType = CT.TcType TyConId TyVarId 36 | type Scheme = CT.Scheme TyConId TyVarId 37 | type TcEnv = CT.TcEnv VarId ConId TyConId TyVarId 38 | 39 | -- | Program is a list of top-level declarations 40 | type Prg = [Decl] 41 | 42 | -- | A function level declaration (types are already enforced at core level) 43 | data Decl = FunDecl SrcLoc VarId [(VarId,Int)] Exp 44 | deriving (Eq, Ord, Show) 45 | 46 | -- | Core Language Expressions. 47 | data Exp = Var {unVar :: VarId} -- ^ variable 48 | | Unknown {unUnknown :: Unknown} -- ^ unknowns 49 | | Lit Int -- ^ literal constant 50 | | Unop Op1 Exp -- ^ unary operators 51 | | Binop Exp Op2 Exp -- ^ infix application 52 | | If Exp Exp Exp -- ^ conditionals 53 | | ADT ConId [Exp] -- ^ fully applied constructor 54 | | Case Exp [Alt] -- ^ case expression 55 | | Inst Exp Unknown -- ^ instantiate an unknown after the expression 56 | | Fresh Unknown Exp Exp -- ^ fresh unknown at some depth. TODO: Include type info? 57 | | Fun [(VarId, Int)] Exp -- ^ Lambdas 58 | | Fix Exp -- ^ fix a transformer on some unknowns 59 | | FixN Int Exp -- ^ fix a transformer a certain number of times (opt) 60 | | TRACE Exp Exp 61 | | Collect Exp Exp 62 | | Call Exp [Exp] -- ^ Function call 63 | deriving (Eq, Ord, Show) 64 | 65 | -- | Alternatives in a case expression 66 | data Alt = Alt SrcLoc Exp Pat Exp 67 | -- ^ A possibly weighted alternative in a case expression 68 | deriving (Eq, Ord, Show) 69 | 70 | -- | Patterns for case expressions 71 | data Pat = PVar Unknown -- ^ variable 72 | | PLit Int -- ^ literal constant 73 | | PApp ConId [Pat] -- ^ constructor and argument patterns 74 | | PWild -- ^ wildcard pattern 75 | deriving (Eq, Ord, Show) 76 | 77 | -- | Binary operators 78 | data Op2 = OpPlus 79 | | OpMinus 80 | | OpTimes 81 | | OpDiv 82 | | OpMod 83 | -- Booleans from now on :) 84 | | OpEq 85 | | OpNe 86 | | OpLt 87 | | OpGt 88 | | OpLe 89 | | OpGe 90 | deriving (Eq, Ord, Show) 91 | 92 | boolBinop :: Op2 -> Bool 93 | boolBinop x = x >= OpEq 94 | 95 | getOp :: Op2 -> Int -> Int -> Int 96 | getOp OpPlus = (+) 97 | getOp OpMinus = (-) 98 | getOp OpTimes = (*) 99 | getOp OpDiv = div 100 | getOp OpMod = mod 101 | 102 | -- | Unary operators 103 | data Op1 = OpNeg 104 | deriving (Eq, Ord, Show) 105 | 106 | -- | Gather all top level function definitions 107 | gatherTopFuns :: Prg -> [(VarId, [(VarId,Int)], Exp)] 108 | gatherTopFuns [] = [] 109 | gatherTopFuns (FunDecl _ x args e : xs) = (x,args,e) : gatherTopFuns xs 110 | 111 | -- | Information for a single function 112 | data FItem = FItem { _fArgs :: [(VarId, Int)] 113 | , _fExp :: !Exp 114 | } deriving (Eq, Show) 115 | 116 | 117 | -- | Maps from function identifiers to function information 118 | type FMap = Map VarId FItem 119 | 120 | -------------------------------------------------------------------------------- /luck/src/Core/AST/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- Not DRY at all with Outer.AST.Pretty 2 | module Core.AST.Pretty where 3 | 4 | import Common.Pretty 5 | import Core.AST 6 | import Text.PrettyPrint 7 | 8 | -- Hand written pretty-printer 9 | instance PP Op2 where 10 | pp = text . op2ToString 11 | 12 | op2ToString :: Op2 -> String 13 | op2ToString op 14 | = case op of 15 | OpPlus -> "+" 16 | OpMinus -> "-" 17 | OpTimes -> "*" 18 | OpDiv -> "/" 19 | OpMod -> "%" 20 | OpEq -> "==" 21 | OpNe -> "/=" 22 | OpLt -> "<" 23 | OpLe -> "<=" 24 | OpGt -> ">" 25 | OpGe -> ">=" 26 | 27 | instance PP Op1 where 28 | pp = text . op1ToString 29 | 30 | op1ToString OpNeg = "-" 31 | op1ToString OpNot = "!" 32 | 33 | ppVarId :: VarId -> Doc 34 | ppVarId (a, b) = text $ "v_" ++ show a ++ "_" ++ show b 35 | 36 | ppUnknown :: VarId -> Doc 37 | ppUnknown (a, b) = text $ "u_" ++ show a ++ "_" ++ show b 38 | 39 | ppConId :: ConId -> Doc 40 | ppConId c = text $ "c_" ++ show c 41 | 42 | instance PP Decl where 43 | pp (FunDecl _ f xs e) 44 | = hang (sep [text "fun", ppVarId f, sep (map ppVarId xs), text "="]) 2 (pp e) 45 | 46 | instance PP Exp where 47 | pp (Var v) = ppVarId v 48 | pp (Unknown u) = ppUnknown u 49 | pp (Lit i) = int i 50 | pp (Unop op1 e) = pp op1 <+> ppParensUnless isCallOrAtom e 51 | pp (Conj e1 e2) = ppParensUnless isCallOrAtom e1 <+> text "&&" <+> ppParensUnless isCallOrAtom e2 52 | pp (Disj w1 e1 w2 e2) = ppParensUnless isCallOrAtom e1 <+> text "||" <+> ppParensUnless isCallOrAtom e2 53 | pp (Binop e1 op2 e2) 54 | = ppParensUnless isCallOrAtom e1 55 | <+> pp op2 <+> ppParensUnless isCallOrAtom e2 56 | pp (If e1 e2 e3) 57 | = text "if" <+> pp e1 58 | <+> text "then" <+> pp e2 59 | <+> text "else" <+> pp e3 60 | pp (Case e alts) 61 | = sep [ sep [text "case", nest 2 (pp e), text "of"] 62 | , vcat (map pp alts) 63 | , text "end"] 64 | pp (Let bs e) 65 | = text "let" <+> vcat (map pp bs) <+> text "in" <+> pp e 66 | pp (ADT c es) = ppConId c <+> sep (map (ppParensUnless isAtomExp) es) 67 | pp (Call f es) = ppVarId f <+> sep (map (ppParensUnless isAtomExp) es) 68 | pp (Fix vs e) 69 | = text "Fix" <+> braces (sep (map ppVarId vs) <> char '|' <+> pp e) 70 | pp (FixN n e) 71 | = text "Fix" <+> braces (int n <> char '|' <+> pp e) 72 | pp (Partition v e) 73 | = brackets (ppVarId v <> char '|' <+> pp e) 74 | 75 | isAtomExp (Var _) = True 76 | isAtomExp (Lit _) = True 77 | isAtomExp (Fix _ _) = True 78 | isAtomExp (FixN _ _) = True 79 | isAtomExp (Partition _ _) = True 80 | isAtomExp e = False 81 | 82 | isCallOrAtom (Call _ _) = True 83 | isCallOrAtom e = isAtomExp e 84 | 85 | instance PP Alt where 86 | pp (Alt _ w p e) 87 | = hang 88 | (hsep [ char '|', pp w, char '%', pp p, text "->"]) 89 | 2 (pp e) 90 | 91 | instance PP Pat where 92 | pp (PApp c ps) 93 | = ppConId c <+> sep (map (ppParensUnless isAtomPat) ps) 94 | pp (PVar v) = ppVarId v 95 | pp PWild = char '_' 96 | pp _ = error "Unimplemented" 97 | 98 | isAtomPat (PApp _ []) = False 99 | isAtomPat _ = True 100 | 101 | ppPrg :: Prg -> Doc 102 | ppPrg = vcat . map pp 103 | 104 | -------------------------------------------------------------------------------- /luck/src/Core/IntRep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Core.IntRep where 3 | 4 | import Data.List(intersperse) 5 | 6 | import Control.Monad 7 | import Control.Monad.Random 8 | 9 | import Common.Util 10 | 11 | -- | Smarter representation for primitives, allowing for faster (in-/dis-)equalities 12 | 13 | data Rep tt = Point tt 14 | -- ^ A single point 15 | | Range tt tt 16 | -- ^ Range A B. A < B (strict) 17 | | Union [Rep tt] 18 | -- ^ Union of non-overlapping, ordered, flattened, (>1) intervals 19 | deriving (Eq, Show) 20 | 21 | printRep :: Show tt => Rep tt -> String 22 | printRep (Point a) = show a 23 | printRep (Range a b) = "[" ++ show a ++ ".." ++ show b ++ "]" 24 | printRep (Union rs) = concat $ intersperse "-" $ map printRep rs 25 | 26 | -- | Inject a single value into a representation 27 | singleton :: tt -> Rep tt 28 | singleton = Point 29 | 30 | -- | Inject a range of values into a representation. Assumes arg1 < arg2 31 | range :: tt -> tt -> Rep tt 32 | range = Range 33 | 34 | -- | Attempts to extract the value of a representation. 35 | toSingleton :: Rep a -> Maybe a 36 | toSingleton (Point x) = Just x 37 | toSingleton _ = Nothing 38 | 39 | -- | Intersection of two representations 40 | intersect :: Ord a => Rep a -> Rep a -> Maybe (Rep a) 41 | intersect (Point x) (Point y) | x == y = Just $ Point x 42 | | otherwise = Nothing 43 | intersect (Point x) (Range low high) 44 | | x < low || x > high = Nothing 45 | | otherwise = Just $ Point x 46 | intersect (Range low high) (Point x) 47 | | x < low || x > high = Nothing 48 | | otherwise = Just $ Point x 49 | intersect r1@(Range l1 h1) r2@(Range l2 h2) 50 | | r1 == r2 = Just r1 51 | | l' == h' = Just $ Point l' 52 | | l' < h' = Just $ Range l' h' 53 | | otherwise = Nothing 54 | where l' = max l1 l2 55 | h' = min h1 h2 56 | intersect p1@(Union cs) p2 57 | | p1 == p2 = Just p1 58 | | otherwise = fromMaybeList $ map (intersect p2) cs 59 | intersect p1 p2@(Union cs) 60 | | p1 == p2 = Just p1 61 | | otherwise = fromMaybeList $ map (intersect p1) cs 62 | 63 | -- | Refiner format of intersection 64 | refineEQ :: (Ord a) => Rep a -> Rep a -> Maybe (Rep a, Rep a) 65 | refineEQ = (fmap (join (,)) .) . intersect 66 | 67 | -- | Gets a list of option representations and converts it to a representation 68 | fromMaybeList :: [Maybe (Rep a)] -> Maybe (Rep a) 69 | fromMaybeList [] = Nothing 70 | fromMaybeList [x] = x 71 | fromMaybeList (Nothing:t) = fromMaybeList t 72 | fromMaybeList ((Just h):t) = 73 | case fromMaybeList t of 74 | Just (Union lst) -> Just (Union (h:lst)) 75 | Just x -> Just (Union [h,x]) 76 | Nothing -> Just h 77 | 78 | -- | Removes a single point from a representation 79 | removePoint :: (Enum a, Ord a) => a -> Rep a -> Maybe (Rep a) 80 | removePoint x o@(Point y) | x /= y = Just o 81 | | otherwise = Nothing 82 | removePoint x o@(Range low high) 83 | | x < low || x > high = Just o 84 | | x == low && high == succ low = Just $ Point high 85 | | x == high && high == succ low = Just $ Point low 86 | | x == low = Just $ Range (succ low) high 87 | | x == high = Just $ Range low (pred high) 88 | | x == succ low && x == pred high = Just $ Union [Point low, Point high] 89 | | x == succ low = Just $ Union [Point low, Range (succ x) high] 90 | | x == pred high = Just $ Union [Range low (pred x), Point high] 91 | | otherwise = Just $ Union [Range low (pred x), Range (succ x) high] 92 | removePoint x (Union cs) = fromMaybeList $ map (removePoint x) cs 93 | 94 | -- | Refine into an inequality 95 | refineNE :: (Ord a, Enum a) => Rep a -> Rep a -> Maybe (Rep a, Rep a) 96 | refineNE (Point x) o = fmap (Point x,) $ removePoint x o 97 | refineNE o (Point x) = fmap (,Point x) $ removePoint x o 98 | refineNE o1 o2 = Just (o1,o2) 99 | 100 | -- | Remove everything less than a point 101 | removeLT :: (Enum a, Ord a) => a -> Rep a -> Maybe (Rep a) 102 | removeLT x o@(Point y) | x < y = Just o 103 | | otherwise = Nothing 104 | removeLT x o@(Range low high) 105 | | x < low = Just o 106 | | succ x < high = Just $ Range (succ x) high 107 | | x == pred high = Just $ Point high 108 | | x >= high = Nothing 109 | removeLT x (Union lst) = 110 | fromMaybeList $ map (removeLT x) lst 111 | removeLT _ _ = error "Can't refine Point LTE for non-point argument" 112 | 113 | removeLE :: (Enum a, Ord a) => a -> Rep a -> Maybe (Rep a) 114 | removeLE x o@(Point y) | x <= y = Just o 115 | | otherwise = Nothing 116 | removeLE x o@(Range low high) 117 | | x <= low = Just o 118 | | x < high = Just $ Range x high 119 | | x == high = Just $ Point high 120 | | x > high = Nothing 121 | removeLE x (Union lst) = 122 | fromMaybeList $ map (removeLE x) lst 123 | removeLE _ _ = error "Can't refine Point LE for non-point argument" 124 | 125 | removeGT :: (Enum a, Ord a) => a -> Rep a -> Maybe (Rep a) 126 | removeGT x o@(Point y) | x > y = Just o 127 | | otherwise = Nothing 128 | removeGT x o@(Range low high) 129 | | x > high = Just o 130 | | pred x > low = Just $ Range low (pred x) 131 | | pred x == low = Just $ Point low 132 | | x <= low = Nothing 133 | removeGT x (Union lst) = 134 | fromMaybeList $ map (removeGT x) lst 135 | removeGT _ _ = error "Can't refine GTE for non-point argument" 136 | 137 | removeGE :: (Enum a, Ord a) => a -> Rep a -> Maybe (Rep a) 138 | removeGE x o@(Point y) | x >= y = Just o 139 | | otherwise = Nothing 140 | removeGE x o@(Range low high) 141 | | x >= high = Just o 142 | | x > low = Just $ Range low x 143 | | x == low = Just $ Point low 144 | | x < low = Nothing 145 | removeGE x (Union lst) = 146 | fromMaybeList $ map (removeGE x) lst 147 | removeGE _ _ = error "Can't refine GE for non-point argument" 148 | 149 | -- | Refiner versions of inequalities 150 | refineGT :: (Enum a, Ord a) => Rep a -> Rep a -> Maybe (Rep a, Rep a) 151 | refineGT p1 p2 = do 152 | p1' <- removeLT l2 p1 153 | p2' <- removeGT h1 p2 154 | return $ (p1',p2') 155 | where h1 = getHighPartialPrim p1 156 | l2 = getLowPartialPrim p2 157 | 158 | refineGE :: (Enum a, Ord a) => Rep a -> Rep a -> Maybe (Rep a, Rep a) 159 | refineGE p1 p2 = do 160 | p1' <- removeLE l2 p1 161 | p2' <- removeGE h1 p2 162 | return $ (p1',p2') 163 | where h1 = getHighPartialPrim p1 164 | l2 = getLowPartialPrim p2 165 | 166 | refineLT :: (Enum a, Ord a) => Rep a -> Rep a -> Maybe (Rep a, Rep a) 167 | refineLT p1 p2 = do 168 | p1' <- removeGT h2 p1 169 | p2' <- removeLT l1 p2 170 | return $ (p1',p2') 171 | where l1 = getLowPartialPrim p1 172 | h2 = getHighPartialPrim p2 173 | 174 | refineLE :: (Enum a, Ord a) => Rep a -> Rep a -> Maybe (Rep a, Rep a) 175 | refineLE p1 p2 = do 176 | p1' <- removeGE h2 p1 177 | p2' <- removeLE l1 p2 178 | return $ (p1',p2') 179 | where l1 = getLowPartialPrim p1 180 | h2 = getHighPartialPrim p2 181 | 182 | -- | Lowest point of a representation 183 | getLowPartialPrim :: Rep a -> a 184 | getLowPartialPrim (Point a) = a 185 | getLowPartialPrim (Range low _) = low 186 | getLowPartialPrim (Union (h:_)) = getLowPartialPrim h 187 | getLowPartialPrim (Union _) = error "Empty union" 188 | 189 | -- | Highest point of a representation 190 | getHighPartialPrim :: Rep a -> a 191 | getHighPartialPrim (Point a) = a 192 | getHighPartialPrim (Range _ high) = high 193 | getHighPartialPrim (Union [h]) = getHighPartialPrim h 194 | getHighPartialPrim (Union (_:t)) = getHighPartialPrim $ Union t 195 | getHighPartialPrim (Union _) = error "Empty union" 196 | 197 | -- | Pick a value in the representation domain 198 | chooseStd :: Random a => StdGen -> Rep a -> (a, StdGen) 199 | chooseStd g r = runRand (choose' r) g 200 | 201 | choose' :: (MonadRandom m, Random a) => Rep a -> m a 202 | choose' (Point i) = return i 203 | choose' (Range low high) = getRandomR (low,high) 204 | choose' (Union cs) = frequencyR' (map (1,) cs) >>= choose' 205 | 206 | -------------------------------------------------------------------------------- /luck/src/Core/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Core.Pretty where 2 | 3 | import Common.Util 4 | import Core.AST 5 | import Text.PrettyPrint 6 | 7 | import Data.Map(Map) 8 | import qualified Data.Map as Map 9 | 10 | printExp v c e = render $ ppExp v c e 11 | printAlt v c a = render $ ppAlt v c a 12 | printPat v c p = render $ ppPat v c p 13 | printAltPats v c as = render $ vcat $ map (\(Alt _ _ p _) -> ppPat v c p) as 14 | 15 | --prettyU :: Unknown -> Map VarId O.VarId -> String 16 | prettyU (u,n) m | Just x <- Map.lookup (u,0) m = x ++ "@" ++ show n 17 | | otherwise = show (u,n) 18 | 19 | ppExp v c (Var u) = parens (char 'V' <+> text (prettyU u v)) 20 | ppExp v c (Unknown u) = text (prettyU u v) 21 | ppExp v c (Lit i) = int i 22 | ppExp v c (Unop OpNeg e) = char '-' <+> ppExp v c e 23 | ppExp v c (Binop e1 op e2) = parens (ppExp v c e1 <+> text (show op) <+> ppExp v c e2) 24 | ppExp v c (If e1 e2 e3) = text "if " <+> ppExp v c e1 <+> text " then " $$ 25 | ppExp v c e2 $$ text " else " <+> ppExp v c e3 26 | ppExp v c (ADT cid es) = text (c ! cid) $$ (nest 2 (vcat (map (ppExp v c) es))) 27 | ppExp v c (Case e alts) = text "CASE " <+> ppExp v c e $$ (nest 2 (vcat $ map (ppAlt v c) alts)) 28 | ppExp v c (Inst e u) = text "Inst " <+> ppExp v c e <+> text (prettyU u v) 29 | ppExp v c (Fresh u en e) = text ("Fresh " ++ prettyU u v ++ " :: ") <+> ppExp v c en <+> text " in " <+> ppExp v c e 30 | ppExp v c (Fix e) = text "Fix " <+> ppExp v c e 31 | ppExp v c (FixN n e) = text "FixN " <+> int n <+> ppExp v c e 32 | ppExp v c (Fun vs e) = text "Fun" <+> hcat (map (text . show . fst) vs) <+> (ppExp v c e) 33 | -- Trace 34 | -- Collect 35 | ppExp v c (Call (Var f) es) = text (v ! (fst f, 0)) $$ (nest 2 $ vcat (map (ppExp v c) es)) 36 | ppExp v c (Call e es) = ppExp v c e $$ (nest 2 $ vcat (map (ppExp v c) es)) 37 | ppAlt v c (Alt _ ew p e) = text "ALT {" <+> ppExp v c ew <+> text "} " <+> ppPat v c p $$ nest 2 (text " |-> " <+> ppExp v c e) 38 | 39 | ppPat v c PWild = char '_' 40 | ppPat v c (PApp cid ps) = text (c ! cid) $$ (nest 2 $ vcat (map (ppPat v c) ps)) 41 | ppPat v c (PLit n) = int n 42 | ppPat v c (PVar u) = text (prettyU u v) 43 | -------------------------------------------------------------------------------- /luck/src/Core/Rigidify.hs: -------------------------------------------------------------------------------- 1 | -- | Fully instantiate unknowns randomly 2 | {-# LANGUAGE FlexibleContexts, TupleSections #-} 3 | module Core.Rigidify 4 | ( UMap 5 | , Gen.DataTree(..) 6 | , Gen.make 7 | , DataGenMap' 8 | , simpleMake 9 | , finalizeTargets 10 | , partializeTargets 11 | , ppBindings 12 | , convert 13 | ) where 14 | 15 | import qualified Common.Pretty as Pretty 16 | import qualified Common.Types as Ty 17 | 18 | import Core.AST 19 | import Core.CSet 20 | import Core.IntRep (Rep) 21 | import qualified Core.IntRep as Rep 22 | import Core.Rigidify.Data 23 | import Core.Rigidify.Generator as Gen 24 | import Core.Rigidify.Pretty 25 | 26 | import Control.Lens 27 | import Control.Monad.State 28 | import Control.Monad.Random 29 | import Control.Arrow(first, second) 30 | 31 | import Data.Map (Map) 32 | import qualified Data.Map as Map 33 | import Data.Maybe (fromJust) 34 | import Data.Traversable 35 | 36 | import Debug.Trace 37 | 38 | type UMap = Map Unknown (DataTree ConId) 39 | type DataGenMap' m 40 | = Gen.DataGenMap ConId TyConId TyVarId (Sized m) 41 | 42 | simpleMake :: (MonadRandom m, Ord c, Ord tc, Ord tv) 43 | => Ty.TcEnv v c tc tv -> Ty.BuiltIn c tc tv 44 | -> DataGenMap c tc tv (Sized m) 45 | simpleMake = (fmap . fmap) (^. _1) Gen.make 46 | 47 | -- | Finalize a value of a given type. 48 | finalize :: MonadRandom m 49 | => Unknown -- ^ Adding an unknown denoting where the Ctr came from 50 | -> TcEnv 51 | -> DataGenMap ConId TyConId TyVarId (Sized m) 52 | -> Map TyVarId (Sized m (DataTree ConId)) -- ^ Type variables to generators 53 | -> Ctr -> TcType 54 | -> StateT (UMap, CtrSet) m (DataTree ConId) 55 | finalize u tcEnv gen tvGen = finalize u 56 | where 57 | finalize u (Undef size) ty = 58 | (lift . Gen.runSized size) (Gen.typedGen gen tvGen ty) 59 | -- TODO: run ac3? 60 | finalize u (ZC _) _ty = do 61 | cs <- snd <$> get 62 | -- traceShowM ("Finalizing ZC for", u) 63 | mc <- lift $ instantiate u cs 64 | -- traceShowM mc 65 | case mc of 66 | Just (CtrSet cset') -> do 67 | modify (second $ const (CtrSet cset')) 68 | let (ZC (z,_)) = cset' Map.! u 69 | return $ DInt $ fromJust $ Rep.toSingleton z 70 | Nothing -> error "Please report: Shouldn't fail at this stage (finalize/Nothing)" 71 | finalize u (DC c cArgs) (Ty.TcCon tc _ tArgs) = 72 | let (vs, _) = Ty.tyConEnv tcEnv Map.! tc 73 | sub = Ty.mkSub vs tArgs 74 | Ty.Forall _ cTy = Ty.conEnv tcEnv Map.! c 75 | (cArgTys', _) = Ty.unFun cTy 76 | cArgTys = map (Ty.subst sub) cArgTys' 77 | in DCon c <$> sequence (zipWith (finalize undefined) cArgs cArgTys) 78 | finalize _ (U u) ty = do 79 | -- traceShowM ("Finalizing", u) 80 | (uMap, CtrSet cset) <- get 81 | case Map.lookup u uMap of 82 | Just x -> return x 83 | Nothing -> do 84 | x <- finalize u (cset Map.! u) ty 85 | modify (first $ Map.insert u x) 86 | return x 87 | finalize _ (DC _ _) (Ty.TcVar _) = error "Found a DC with an abstract type!?" 88 | finalize _ _ (Ty.TcFun _ _) = error "Found a hole with a function type!?" 89 | 90 | -- | List version 91 | finalizeTargets :: MonadRandom m 92 | => TcEnv 93 | -> DataGenMap ConId TyConId TyVarId (Sized m) 94 | -> CtrSet 95 | -> [(Unknown, TcType)] 96 | -> m (CtrSet, [DataTree ConId]) 97 | finalizeTargets = (fmap . fmap . fmap . fmap . fmap) fst finalizeTargets' 98 | 99 | finalizeTargets' tcEnv gen cset us = runStateT (do us' <- traverse f us 100 | (_, cset') <- get 101 | return (cset', us') 102 | ) (Map.empty, cset) 103 | where 104 | f = uncurry (finalize undefined tcEnv gen Map.empty . U) 105 | 106 | partialize cset (Undef _) = DCon (-777) [] 107 | partialize cset (ZC (z,_)) = case Rep.toSingleton z of 108 | Nothing -> DCon (-888) [] 109 | Just x -> DInt x 110 | partialize cset (DC c cArgs) = DCon c (fmap (partialize cset) cArgs) 111 | partialize cset@(CtrSet cset') (U u) = partialize cset (cset' Map.! u) 112 | 113 | partializeTargets cset us = (cset, fmap (partialize cset . U) us) 114 | 115 | ppBindings size vars vals = 116 | let nonZero 0 = Nothing 117 | nonZero n = Just n 118 | in Pretty.prettyPrint $ sizedPpVals (nonZero size) (zip vars vals) 119 | -------------------------------------------------------------------------------- /luck/src/Core/Rigidify/Data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Core.Rigidify.Data (DataTree(..), convert, example) where 3 | 4 | import Control.Monad.State 5 | import Data.Data 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Common.Types 9 | import Core.Rigidify.Generator (DataTree(..)) 10 | import Outer.Types (initOTcEnv) 11 | 12 | -- | Convert the generic representation of terms to the represented value 13 | -- in Haskell. 14 | -- 15 | -- It is assumed that the input term is well-formed, and that the 16 | -- datatype definitions in Haskell and in Luck are identical (in particular 17 | -- data constructors should be declared in the same order). 18 | convert :: (Data a, Ord c) 19 | => (c -> String) -- ^ Display the conflicting constructor in case of error. 20 | -- Useful for debugging, using the reverse mapping from Conversion. 21 | -> Map c ConIndex -- ^ Map from constructors to their indices 22 | -> DataTree c -> a 23 | convert _ _ (DInt n) = res 24 | where res = fromConstr $ mkIntegralConstr (dataTypeOf res) n 25 | convert showCon env (DCon c cargs) = 26 | if null residue 27 | then result 28 | else error' "Too many arguments." 29 | where 30 | ty = dataTypeOf result 31 | i = maybe (error $ "convert: Con not found " ++ showCon c) id 32 | $ Map.lookup c env 33 | c' = indexConstr ty i 34 | (result, residue) = flip runState cargs $ fromConstrM 35 | (StateT $ \case 36 | [] -> error' "Not enough arguments." 37 | arg : args -> return (convert showCon env arg, args)) 38 | c' 39 | error' :: String -> x 40 | error' s = error $ "convert: " ++ s 41 | ++ " Luck:" ++ showCon c 42 | ++ " Hask:" ++ showConstr c' 43 | 44 | example :: [Int] 45 | example = convert id (conIndices initOTcEnv) 46 | $ DCon "Cons" [DInt 2015, DCon "Nil" []] 47 | 48 | -------------------------------------------------------------------------------- /luck/src/Core/Rigidify/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Core.Rigidify.Pretty where 2 | 3 | import Prelude hiding ((<>)) 4 | import Data.List 5 | import Data.Map (Map) 6 | import qualified Data.Map as Map 7 | 8 | import Common.Pretty 9 | import Common.Types 10 | import Core.Rigidify.Generator 11 | 12 | instance PP Void where 13 | pp _ = text "_" 14 | 15 | instance (PP c, PP b) => PP (DataPat' c b) where 16 | pp = ppDP id 17 | 18 | instance PP c => PP (DataTree c) where 19 | pp = snd . sizedPpDT Nothing id 20 | 21 | ppDP p (DPLeaf b) = braces (pp b) 22 | ppDP p (DPCon c []) = pp c 23 | ppDP p (DPCon c cargs) = p . hang (pp c) 2 $ sep (ppDP parens `fmap` cargs) 24 | 25 | sizedPpDT :: PP c => Maybe Int -> (Doc -> Doc) -> DataTree c -> (Maybe Int, Doc) 26 | sizedPpDT s p (DInt n) = (s, pp n) 27 | sizedPpDT s p (DCon c []) = (s, pp c) 28 | sizedPpDT (Just 0) _ dt = 29 | (Just 0, text $ "...[" ++ show (sz dt) ++ " nodes]") 30 | where sz (DCon _ ts) = 1 + sum (map sz ts) 31 | sz (DInt _) = 1 :: Int 32 | sizedPpDT s p (DCon c cargs) = 33 | let (s1, docs) = mapAccumL (\s t -> sizedPpDT s parens t) (decr s) cargs 34 | doc = p . hang (pp c) 2 $ sep docs 35 | in (s1, doc) 36 | where decr = fmap (subtract 1) 37 | 38 | ppDataPat :: (PP c, PP tc, PP tv) => DataPat c tc tv -> Doc 39 | ppDataPat = pp 40 | 41 | ppInline :: (PP c, PP tc, PP tv) => tc -> [tv] -> [(Int, DataPat c tc tv)] -> Doc 42 | ppInline tc vs alts = 43 | hang (hsep (pp tc : fmap pp vs) <+> text "=") 2 44 | . sep . flip map alts 45 | $ \(w, a) -> text "|" <+> int w <+> text "%" <+> ppDataPat a 46 | 47 | ppInlined :: (PP c, PP tc, PP tv) => Map tc ([tv], [(Int, DataPat c tc tv)]) -> Doc 48 | ppInlined inl = vcat . map (\(tc, (vs, alts)) -> ppInline tc vs alts) 49 | $ Map.toList inl 50 | 51 | sizedPpVals s = ((render . vcat) .) . map $ \(v, x) -> 52 | hang (pp v <> text ":") 2 . snd $ sizedPpDT s id x 53 | 54 | -------------------------------------------------------------------------------- /luck/src/Core/Types/Data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Core.Types.Data (DataTree(..), convert, example) where 3 | 4 | import Control.Monad.State 5 | import Data.Data 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Common.Types 9 | import Core.Types.Generator (DataTree(..)) 10 | import Outer.Types (initOTcEnv) 11 | 12 | -- | Convert the generic representation of terms to the represented value 13 | -- in Haskell. 14 | -- 15 | -- It is assumed that the input term is well-formed, and that the 16 | -- datatype definitions in Haskell and in Luck are identical (in particular 17 | -- data constructors should be declared in the same order). 18 | convert :: (Data a, Ord c) 19 | => (c -> String) -- ^ Display the conflicting constructor in case of error. 20 | -- Useful for debugging, using the reverse mapping from Conversion. 21 | -> Map c ConIndex -- ^ Map from constructors to their indices 22 | -> DataTree c -> a 23 | convert _ _ (DInt n) = res 24 | where res = fromConstr $ mkIntegralConstr (dataTypeOf res) n 25 | convert showCon env (DCon c cargs) = 26 | if null residue 27 | then result 28 | else error' "Too many arguments." 29 | where 30 | ty = dataTypeOf result 31 | i = maybe (error $ "convert: Con not found " ++ showCon c) id 32 | $ Map.lookup c env 33 | c' = indexConstr ty i 34 | (result, residue) = flip runState cargs $ fromConstrM 35 | (StateT $ \case 36 | [] -> error' "Not enough arguments." 37 | arg : args -> return (convert showCon env arg, args)) 38 | c' 39 | error' :: String -> x 40 | error' s = error $ "convert: " ++ s 41 | ++ " Luck:" ++ showCon c 42 | ++ " Hask:" ++ showConstr c' 43 | 44 | example :: [Int] 45 | example = convert id (conIndices initOTcEnv) 46 | $ DCon "Cons" [DInt 2015, DCon "Nil" []] 47 | 48 | -------------------------------------------------------------------------------- /luck/src/Core/Types/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Core.Types.Pretty where 2 | 3 | import Data.List 4 | import Data.Map (Map) 5 | import qualified Data.Map as Map 6 | 7 | import Common.Pretty 8 | import Common.Types 9 | import Core.Types.Generator 10 | 11 | instance PP Void where 12 | pp _ = text "_" 13 | 14 | instance (PP c, PP b) => PP (DataPat' c b) where 15 | pp = ppDP id 16 | 17 | instance PP c => PP (DataTree c) where 18 | pp = snd . sizedPpDT Nothing id 19 | 20 | ppDP p (DPLeaf b) = braces (pp b) 21 | ppDP p (DPCon c []) = pp c 22 | ppDP p (DPCon c cargs) = p . hang (pp c) 2 $ sep (ppDP parens `fmap` cargs) 23 | 24 | sizedPpDT :: PP c => Maybe Int -> (Doc -> Doc) -> DataTree c -> (Maybe Int, Doc) 25 | sizedPpDT s p (DInt n) = (s, pp n) 26 | sizedPpDT s p (DCon c []) = (s, pp c) 27 | sizedPpDT (Just 0) _ dt = 28 | (Just 0, text $ "...[" ++ show (sz dt) ++ " nodes]") 29 | where sz (DCon _ ts) = 1 + sum (map sz ts) 30 | sz (DInt _) = 1 :: Int 31 | sizedPpDT s p (DCon c cargs) = 32 | let (s1, docs) = mapAccumL (\s t -> sizedPpDT s parens t) (decr s) cargs 33 | doc = p . hang (pp c) 2 $ sep docs 34 | in (s1, doc) 35 | where decr = fmap (subtract 1) 36 | 37 | ppDataPat :: (PP c, PP tc, PP tv) => DataPat c tc tv -> Doc 38 | ppDataPat = pp 39 | 40 | ppInline :: (PP c, PP tc, PP tv) => tc -> [tv] -> [(Int, DataPat c tc tv)] -> Doc 41 | ppInline tc vs alts = 42 | hang (hsep (pp tc : fmap pp vs) <+> text "=") 2 43 | . sep . flip map alts 44 | $ \(w, a) -> text "|" <+> int w <+> text "%" <+> ppDataPat a 45 | 46 | ppInlined :: (PP c, PP tc, PP tv) => Map tc ([tv], [(Int, DataPat c tc tv)]) -> Doc 47 | ppInlined inl = vcat . map (\(tc, (vs, alts)) -> ppInline tc vs alts) 48 | $ Map.toList inl 49 | 50 | sizedPpVals s = ((render . vcat) .) . map $ \(v, x) -> 51 | hang (pp v <> text ":") 2 . snd $ sizedPpDT s id x 52 | 53 | -------------------------------------------------------------------------------- /luck/src/Luck/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, RecordWildCards, 2 | DeriveDataTypeable, BangPatterns, LambdaCase, GADTs 3 | #-} 4 | module Luck.Main where 5 | 6 | import Control.Monad 7 | import Control.Monad.Random 8 | 9 | import Common.Pretty (render, prettyPrint, pp) 10 | import Common.SrcLoc 11 | import Common.Util 12 | import Common.Types hiding (subst) 13 | import Common.Conversions (convertToCore, CoreTranslation(..), iBuiltIn) 14 | import Outer.Parser 15 | import Outer.ParseMonad 16 | import Outer.Renamer(rename) 17 | import Outer.Types(typeInference, removeClassBindings) 18 | import Outer.Expander(expandWildcards) 19 | import Outer.ClassMono(monomorphiseClasses) 20 | 21 | import Core.AST 22 | import qualified Outer.AST as OAST 23 | import Core.CSet 24 | import Core.Semantics hiding (rename) 25 | import Core.Optimizations 26 | import Core.Pretty 27 | 28 | import Debug.Trace 29 | 30 | import Paths_luck 31 | 32 | import System.Environment 33 | import System.Random 34 | import System.Console.CmdArgs 35 | import System.Exit 36 | import qualified System.FilePath as FN 37 | 38 | import Data.Functor.Identity 39 | import Data.Map(Map) 40 | import qualified Data.Map as Map 41 | 42 | import qualified Data.ByteString as BS 43 | import qualified Data.ByteString.Char8 as BS8 44 | 45 | import Core.Rigidify (DataTree) 46 | import qualified Core.Rigidify as Rigidify 47 | 48 | data RunMode = Single | Evaluate 49 | deriving (Eq, Show, Read, Typeable, Data) 50 | 51 | -- This is a hack which allows to reuse the existing huge main function without 52 | -- packing/unpacking the whole context of intermediate computations, 53 | -- which introduce a lot of variables. 54 | data Returns m a where 55 | RunSingle :: Returns IO () 56 | RunEvaluate :: Returns IO () 57 | Cont :: TProxy a -> Returns Identity (StdGen -> Maybe a) 58 | 59 | data TProxy a where 60 | TProxy0 :: TProxy () 61 | TProxyS :: Data a => TProxy b -> TProxy (a, b) 62 | TProxyF :: (a -> b) -> TProxy a -> TProxy b 63 | 64 | runModeReturns Single = RunSingle 65 | runModeReturns Evaluate = RunEvaluate 66 | 67 | data Flags = Flags { _fileName :: String 68 | , _function :: Maybe String 69 | , _runMode :: RunMode 70 | , _evalTries :: Int 71 | -- , _tryGenerator :: Maybe (String, Int, Int) 72 | , _fullOutput :: Int 73 | , _noSample :: Bool 74 | , _maxUnroll :: Int 75 | -- , _warnings :: Bool 76 | , _maxBacktrack :: Int 77 | , _defDepth :: Int 78 | , _intRangeMin :: Int 79 | , _intRangeMax :: Int 80 | } 81 | deriving (Eq, Show, Read, Typeable, Data) 82 | 83 | defFlags = Flags { _fileName = "" &= argPos 0 &= typFile 84 | , _function = Nothing &= name "fun" 85 | , _runMode = Single &= name "mode" 86 | , _evalTries = 1000 &= name "reps" 87 | -- , _tryGenerator = Nothing &= name "debug-trygen" 88 | -- &= typ "TYPE,SIZE,RPT" 89 | -- &= help "Generate RPT random values of type TYPE \ 90 | -- \with size SIZE, ex: \"[[Bool]]\",14,4" 91 | , _fullOutput = 5 &= name "f" &= name "full-output" 92 | &= opt (0 :: Int) 93 | &= help "With no argument, do not truncate the output. \ 94 | \With INT, keep INT internal nodes." 95 | , _noSample = False &= name "no-sample" 96 | &= help "Do not sample holes" 97 | , _maxUnroll = 0 &= name "maxUnroll" 98 | &= help "Maximum number of times to unroll a function" 99 | -- , _warnings = True &= name "warnings" 100 | , _maxBacktrack = maxBound &= name "max-backtrack" 101 | , _defDepth = 10 &= name "default-depth" 102 | , _intRangeMin = -42 &= name "irmin" &= help "Bottom of default int range" 103 | , _intRangeMax = 42 &= name "irmax" &= help "Top of default int range" 104 | } 105 | 106 | preludeLuck = getDataFileName "src/Luck/Prelude.luck" 107 | 108 | main :: IO () 109 | main = do 110 | flags@Flags{..} <- cmdArgs defFlags 111 | ast <- getOAST flags 112 | parse flags ast (runModeReturns _runMode) 113 | 114 | handleIncludes :: String -> OAST.Decl -> IO [OAST.Decl] 115 | handleIncludes relPath (OAST.IncludeDecl fileName) = do 116 | newFile <- BS.readFile (relPath FN. (fileName ++ ".luck")) 117 | let pState = mkPState newFile (SrcLoc fileName 1 1) 118 | newAst <- failEither $ runP parser pState 119 | handleAllInclusions relPath newAst 120 | handleIncludes _ x = return [x] 121 | 122 | handleAllInclusions :: String -> [OAST.Decl] -> IO [OAST.Decl] 123 | handleAllInclusions relPath l = concat <$> mapM (handleIncludes relPath) l 124 | 125 | getOAST :: Flags -> IO OAST.Prg 126 | getOAST flags@Flags{..} = do 127 | preludePath <- preludeLuck 128 | prelude <- BS.readFile preludePath 129 | contents <- BS.readFile _fileName 130 | let relativePath = FN.takeDirectory _fileName 131 | parseFiles flags relativePath prelude contents 132 | 133 | parseFiles Flags{..} relativePath prelude contents = do 134 | astPrelude <- failEither $ runP parser $ mkPState prelude (SrcLoc "Prelude" 1 1) 135 | let pState = mkPState contents (SrcLoc _fileName 1 1) 136 | astOriginal <- failEither $ runP parser pState 137 | astIncluded <- handleAllInclusions relativePath astOriginal 138 | return (astPrelude ++ astIncluded) 139 | 140 | parse :: (Monad m, MonadFail m) => Flags -> OAST.Prg -> Returns m a -> m a 141 | parse Flags{..} ast r = do 142 | (fwdRenMap, revRenMap, astRenamed) <- failEither $ rename ast 143 | -- traceM $ unlines (map show astRenamed) 144 | (astAnnotated, tcEnv') <- failEither $ typeInference astRenamed 145 | -- traceM $ unlines (map show astAnnotated) 146 | (astClass, tcEnv'') <- failEither $ monomorphiseClasses astAnnotated tcEnv' 147 | -- traceM $ unlines (map show astClass) 148 | let tcEnv = removeClassBindings astAnnotated tcEnv'' 149 | -- traceShowM ("TC:", tcEnv) 150 | -- traceM $ unlines ("DeClassed:" : map show astClass) 151 | -- TODO: -42..42 needs to *at least* be parameterized 152 | astExpanded <- failEither $ expandWildcards astClass tcEnv (-42) 42 153 | -- traceM $ unlines ("EXPANDED:" : map show astExpanded) 154 | coreResult <- failEither $ convertToCore fwdRenMap tcEnv astExpanded _defDepth 155 | let topFuns = gatherTopFuns $ ct_prog coreResult 156 | toFItem (fid, args, e) = (fid, FItem args e) 157 | initFMap = Map.fromList (map toFItem topFuns) 158 | (fid, FItem args e) <- case _function of 159 | Nothing -> return $ toFItem $ last topFuns 160 | Just f -> error "implement specific function test" 161 | let conTrue = ct_cEnv coreResult ! "True" 162 | conFalse = ct_cEnv coreResult ! "False" 163 | c = ct_cRev coreResult 164 | v = ct_vRev coreResult 165 | args' = map fst args 166 | e' = subst e args' (map Unknown args') 167 | (eFinal, idx0, step, fenvFinal) = inlineAndPropagate v c conTrue conFalse _maxUnroll initFMap e' 168 | rs = mkReaderState fenvFinal (ct_tcEnv coreResult) (ct_vRev coreResult) (ct_cRev coreResult) conTrue conFalse (_intRangeMin, _intRangeMax) 169 | fbs = mkFBState (idx0+1) step _maxBacktrack 170 | k = initCtrSet args 171 | -- Value rigidification 172 | (fid', _) = fid 173 | Forall _ fty = varEnv (ct_tcEnv coreResult) Map.! (fid', 0) 174 | (argTys, _) = unFun fty 175 | typedArgs = zip args' argTys 176 | dataGens :: MonadRandom n => Rigidify.DataGenMap' n 177 | dataGens = Rigidify.simpleMake (ct_tcEnv coreResult) (iBuiltIn (ct_cEnv coreResult)) 178 | finalize :: MonadRandom n => CtrSet -> n (CtrSet, [DataTree ConId]) 179 | finalize k = case _noSample of 180 | True -> return (Rigidify.partializeTargets k args') 181 | False -> Rigidify.finalizeTargets (ct_tcEnv coreResult) dataGens k typedArgs 182 | oArgs = map (ct_vRev coreResult Map.!) args' 183 | oValues :: [DataTree ConId] -> [DataTree String] 184 | oValues = fmap . fmap $ conName 185 | conName = \case 186 | -777 -> "_" -- Unconstrained ADT 187 | -888 -> "_'" -- Unconstrained Int 188 | c -> ct_cRev coreResult Map.! c 189 | nonZero 0 = Nothing 190 | nonZero n = Just n 191 | run_ :: (ReaderState -> FBState -> Exp -> Pat -> CtrSet -> t1 -> t) -> t1 -> t 192 | run_ runLuck g = runLuck rs fbs eFinal (PApp conTrue []) k g 193 | run = run_ runLuck 194 | run' = run_ runLuck' 195 | 196 | -- putStrLn $ show (idx0+1, step) 197 | -- forM_ (Map.assocs fenvFinal) $ \(fid, FItem args e) -> do 198 | -- putStrLn $ (((ct_vRev coreResult) ! fid) ++ " : ") 199 | -- putStrLn $ printExp (ct_vRev coreResult) (ct_cRev coreResult) e 200 | -- putStrLn $ printExp (ct_vRev coreResult) (ct_cRev coreResult) eFinal 201 | case r of 202 | RunSingle -> do 203 | -- putStrLn $ printExp (ct_vRev coreResult) (ct_cRev coreResult) eFinal 204 | g <- getStdGen 205 | case run g of 206 | Right (_,k') -> do 207 | -- traceShowM ("Ran", k') 208 | (k'', vs) <- finalize k' 209 | Rigidify.ppBindings _fullOutput oArgs (oValues vs) 210 | Left err -> error err 211 | RunEvaluate -> 212 | let aux !cnt 0 = return cnt 213 | aux !cnt n = do 214 | g <- newStdGen 215 | case run g of 216 | Right (_,k') -> 217 | aux (cnt + countFor k' args') (n-1) 218 | Left _ -> aux cnt n 219 | in do 220 | g <- getStdGen 221 | res <- aux 0 _evalTries 222 | putStrLn $ show res 223 | Cont p -> 224 | let 225 | convert_ :: Data a => DataTree ConId -> a 226 | convert_ = Rigidify.convert conName (conIndices (ct_tcEnv coreResult)) 227 | convert' :: TProxy a -> [DataTree ConId] -> a 228 | convert' TProxy0 [] = () 229 | convert' (TProxyS p) (x : xs) = strictPair (convert_ x) (convert' p xs) 230 | convert' (TProxyF f p) xs = f (convert' p xs) 231 | convert' _ _ = error "convert': arity mismatch" 232 | f = convert' p 233 | in 234 | return $ \g -> 235 | case run' g of 236 | Right (((_,k'), _), g) -> Just (f (evalRand (snd <$> finalize k') g)) 237 | Left _ -> Nothing 238 | 239 | strictPair :: a -> b -> (a, b) 240 | strictPair x y = x `seq` y `seq` (x, y) 241 | -------------------------------------------------------------------------------- /luck/src/Luck/Prelude.luck: -------------------------------------------------------------------------------- 1 | data Maybe a = Just a | Nothing 2 | 3 | fun or u w1 w2 e1 e2 = 4 | case u of 5 | | w1 % True -> 6 | case e1 of 7 | | True -> True 8 | | False -> e2 9 | end 10 | | w2 % False -> 11 | case e2 of 12 | | True -> True 13 | | False -> e1 14 | end 15 | end 16 | 17 | fun and u w1 w2 e1 e2 = 18 | case u of 19 | | w1 % True -> 20 | case e1 of 21 | | True -> e2 22 | | False -> False 23 | end 24 | | w2 % False -> 25 | case e2 of 26 | | True -> e1 27 | | False -> False 28 | end 29 | end 30 | 31 | fun notF e = 32 | case e of 33 | | True -> False 34 | | False -> True 35 | end 36 | -------------------------------------------------------------------------------- /luck/src/Luck/Template.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveLift #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# OPTIONS_GHC -fno-warn-missing-fields #-} 5 | 6 | module Luck.Template 7 | ( mkGenQ 8 | , TProxy (..) 9 | , tProxy1 10 | , tProxy2 11 | , tProxy3 12 | , Flags (..) 13 | , defFlags 14 | ) where 15 | 16 | import Common.SrcLoc (SrcLoc(..)) 17 | import Common.Types 18 | import Outer.AST 19 | import Luck.Main 20 | 21 | import Language.Haskell.TH.Syntax (Lift(..), Q, runIO) 22 | import qualified Language.Haskell.TH as TH 23 | 24 | import System.Random 25 | import Data.Data (Data) 26 | import Data.Functor.Identity 27 | import qualified Test.QuickCheck.Gen as QC 28 | 29 | import Paths_luck 30 | 31 | import qualified Data.ByteString as BS 32 | 33 | -- * Luck to Haskell 34 | 35 | -- | Import a Luck generator as a Haskell value generator at compile time. 36 | -- 37 | -- > {-# LANGUAGE TemplateHaskell #-} 38 | -- > {- - @MyType@ should be an instance of @Data@; 39 | -- > - the definitions of types involved in @MyType@ 40 | -- > should match those in the Luck program; 41 | -- > - The target predicate (i.e., the last function) should have type 42 | -- > @MyType -> Bool@. 43 | -- > -} 44 | -- > luckyGen :: QC.Gen (Maybe MyType) 45 | -- > luckyGen = $(mkGenQ defFlags{_fileName="path/to/MyLuckPrg.luck"}) tProxy1 46 | -- 47 | -- Depending on the arity of the predicate, use 'tProxy1', 'tProxy2', 'tProxy3', 48 | -- or the 'TProxy' constructors. (The type of the 'TProxy' argument 49 | -- contains the result type of the generator.) 50 | -- 51 | -- For example, for a 4-ary predicate of type 52 | -- @A -> B -> C -> D -> Bool@, 53 | -- we can create the following generator: 54 | -- 55 | -- > luckGen :: QC.Gen (A, (B, (C, (D, ())))) 56 | -- > luckGen = $(mkGenQ defFlags{_fileName="path/to/MyLuckPrg.luck"}) 57 | -- > (TProxyS . TProxyS . TProxyS . TProxyS $ TProxy0) 58 | mkGenQ :: Flags -> Q TH.Exp 59 | mkGenQ flags = do 60 | ast <- runIO $ getOAST flags 61 | [| \proxy -> stdGenToGen (runIdentity (parse 62 | $(lift flags) 63 | $(lift ast) 64 | (Cont proxy))) |] 65 | 66 | stdGenToGen :: (StdGen -> a) -> QC.Gen a 67 | stdGenToGen f = QC.MkGen $ \qcGen _ -> f' qcGen 68 | where f' = f . mkStdGen . fst . next 69 | 70 | tProxy1 :: Data a => TProxy a 71 | tProxy1 = TProxyF (\(a, ()) -> a) (TProxyS TProxy0) 72 | 73 | tProxy2 :: (Data a, Data b) => TProxy (a, b) 74 | tProxy2 = TProxyF (\(a, (b, ())) -> (a, b)) (TProxyS . TProxyS $ TProxy0) 75 | 76 | tProxy3 :: (Data a, Data b, Data c) => TProxy (a, b, c) 77 | tProxy3 = TProxyF (\(a, (b, (c, ()))) -> (a, b, c)) (TProxyS . TProxyS . TProxyS $ TProxy0) 78 | 79 | deriving instance Lift RunMode 80 | deriving instance Lift Flags 81 | deriving instance Lift ConDecl 82 | deriving instance Lift Decl 83 | deriving instance Lift Exp 84 | deriving instance Lift TyVarId' 85 | deriving instance Lift Pat 86 | deriving instance Lift Literal 87 | deriving instance Lift Alt 88 | deriving instance Lift Op1 89 | deriving instance Lift Op2 90 | deriving instance Lift SrcLoc 91 | deriving instance (Lift c, Lift v) => Lift (TcType c v) 92 | -------------------------------------------------------------------------------- /luck/src/Outer/AST.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Core.AST 4 | -- Copyright : (c) Leonidas Lampropoulos, 2016, 5 | -- 6 | -- License : ?? 7 | -- 8 | -- Standard AST for the Core language for generators. 9 | -- Heavily influenced by Language.Haskell.Src 10 | -- 11 | ----------------------------------------------------------------------------- 12 | {-# LANGUAGE ViewPatterns #-} 13 | module Outer.AST where 14 | 15 | import Common.SrcLoc 16 | import qualified Common.Types as CT 17 | 18 | import Data.List 19 | 20 | -- | Types of Identifiers 21 | type ConId = String 22 | type TyConId = String 23 | type VarId = String 24 | type TyVarId = String 25 | type ClassId = String 26 | 27 | type OTcType = CT.TcType TyConId VarId 28 | type OScheme = CT.Scheme TyConId TyVarId 29 | type OTcEnv = CT.TcEnv VarId ConId TyConId TyVarId 30 | 31 | -- | Primes (@'@) mark an intermediate representation of types that 32 | -- distinguishes rigid variables from flexible ones. 33 | data TyVarId' = Flexible TyVarId 34 | | Rigid TyVarId 35 | deriving (Eq, Ord, Show) 36 | 37 | type OTcType' = CT.TcType TyConId TyVarId' 38 | type OScheme' = CT.Scheme TyConId TyVarId' 39 | type OTcEnv' = CT.TcEnv VarId ConId TyConId TyVarId' 40 | 41 | -- | Program is a list of top-level declarations 42 | type Prg = [Decl] 43 | 44 | -- | Constructor declaration 45 | data ConDecl = ConDecl ConId [OTcType] -- ^ ordinary data constructor 46 | deriving (Eq, Ord, Show) 47 | 48 | -- | A top level declaration 49 | data Decl = DataDecl SrcLoc TyConId [TyVarId] [ConDecl] 50 | -- ^ Datatype declaration 51 | | TypeSig SrcLoc VarId [(ClassId, OTcType)] OTcType 52 | -- ^ TcType signature declaration 53 | | FunDecl SrcLoc VarId [(VarId,Maybe Int)] Exp (Maybe OTcType') 54 | -- ^ Function declaration. 55 | | IncludeDecl String 56 | | ClassDecl SrcLoc ClassId TyVarId [(VarId, OTcType)] 57 | | InstanceDecl SrcLoc ClassId OTcType [(ClassId, OTcType)] [(VarId, [(VarId, Maybe Int)], Exp, Maybe OTcType')] 58 | deriving (Eq, Ord, Show) 59 | 60 | -- | Core Language Expressions. Expose boolean primitives 61 | data Exp = Var (VarId, Maybe OTcType') -- ^ variable and (maybe) type 62 | | Con ConId -- ^ data constructor 63 | | Lit Literal -- ^ literal constant 64 | | Unop Op1 Exp -- ^ unary operators 65 | | Conj Exp Exp -- ^ conjunction 66 | | Disj (Maybe Exp) Exp (Maybe Exp) Exp -- ^ disjunction 67 | | Binop Exp Op2 Exp -- ^ infix application 68 | | App Exp Exp -- ^ function application 69 | | If Exp Exp Exp -- ^ if expression 70 | | Case Exp [Alt] -- ^ case expression 71 | | Let Binds Exp -- ^ local declarations let ... in ... 72 | | Fix Exp -- ^ Fixpoint 73 | | FixN Int Exp -- ^ Indexed fixpoint 74 | | Fun [(VarId, Maybe Int)] Exp -- ^ Anonymous functions 75 | | Fresh VarId OTcType Exp Exp -- ^ Generate Fresh Variable of some type with some depth limit 76 | | Inst Exp VarId -- ^ Post-fix Instantiation point 77 | | TRACE VarId Exp -- ^ Trace a variable (debugging) 78 | | Collect Exp Exp -- ^ Collect statistics 79 | deriving (Eq, Ord, Show) 80 | 81 | -- | Binding groups are just lists of declarations 82 | type Binds = [Decl] 83 | 84 | -- | Alternatives in a case expression 85 | data Alt = Alt 86 | { altLoc :: SrcLoc 87 | , altWeight :: Maybe Exp 88 | , altPat :: Pat 89 | , altExp :: Exp 90 | } -- ^ A possibly weighted alternative in a case expression 91 | deriving (Eq, Ord, Show) 92 | 93 | -- | Implicit weights are equal to 1. 94 | altWeight' :: Alt -> Exp 95 | altWeight' (altWeight -> Just n) = n 96 | altWeight' _ = litIntE 1 97 | 98 | -- | Helper constructor for literal expressions. 99 | litIntE :: Int -> Exp 100 | litIntE = Lit . LitInt 101 | 102 | -- | let' x = e in e' 103 | letE :: VarId -> Exp -> Exp -> Exp 104 | letE x e e' = Case e [Alt noLoc (Just $ litIntE 1) (PVar x) e'] 105 | 106 | -- | Constant literals 107 | data Literal = LitInt Int -- ^ integer literals 108 | deriving (Eq, Ord, Show) 109 | 110 | -- | Patterns for case expressions 111 | data Pat = PVar VarId -- ^ variable 112 | | PLit Literal -- ^ literal constant 113 | | PApp ConId [Pat] -- ^ constructor and argument patterns 114 | | PWild -- ^ wildcard pattern 115 | deriving (Eq, Ord, Show) 116 | 117 | isDefaultPat :: Pat -> Bool 118 | isDefaultPat (PVar _) = True 119 | isDefaultPat PWild = True 120 | isDefaultPat _ = False 121 | 122 | -- | Binary operators 123 | data Op2 = OpPlus 124 | | OpMinus 125 | | OpTimes 126 | | OpDiv 127 | | OpMod 128 | | OpEq 129 | | OpNe 130 | | OpLt 131 | | OpGt 132 | | OpLe 133 | | OpGe 134 | deriving (Eq, Ord, Show) 135 | 136 | -- | Unary operators 137 | data Op1 = OpNeg 138 | | OpNot 139 | deriving (Eq, Ord, Show) 140 | 141 | -- | Pre-defined constructors 142 | list_tycon_name :: TyConId 143 | list_tycon_name = "List" 144 | 145 | nil_con_name, cons_con_name :: ConId 146 | nil_con_name = "Nil" 147 | cons_con_name = "Cons" 148 | 149 | tuple_tycon_name :: Int -> TyConId 150 | tuple_tycon_name n = "Tuple " ++ show n 151 | 152 | tuple_con_name :: Int -> ConId 153 | tuple_con_name n = "#" ++ show n 154 | 155 | tc_int_tycon, tc_bool_tycon, tc_unit_tycon :: CT.TcType TyConId v 156 | tc_int_tycon = CT.TcCon "Int" 0 [] 157 | tc_bool_tycon = CT.TcCon "Bool" 0 [] 158 | tc_unit_tycon = CT.TcCon "Unit" 0 [] 159 | 160 | -- | Smart constructor that simplifies constants. 161 | times :: Exp -> Exp -> Exp 162 | times (Binop e1 OpTimes e2) e3 = times e1 . times e2 $ e3 163 | times (Lit (LitInt n)) (Lit (LitInt m)) = litIntE (n * m) 164 | times (Lit (LitInt n)) (Binop (Lit (LitInt m)) OpTimes e3) 165 | = Binop (litIntE (n * m)) OpTimes e3 166 | times (Lit (LitInt 1)) e3 = e3 167 | times e1 (Binop (Lit (LitInt n)) OpTimes e2) 168 | = Binop (litIntE n) OpTimes (Binop e1 OpTimes e2) 169 | times e1 e2 = Binop e1 OpTimes e2 170 | 171 | -- | Smart constructor that simplifies constants. 172 | plus :: Exp -> Exp -> Exp 173 | plus (Lit (LitInt n)) (Lit (LitInt m)) = litIntE (n + m) 174 | plus e1 e2 = Binop e1 OpTimes e2 175 | 176 | -- | Expression of a long sum. 177 | sumE :: [Exp] -> Exp 178 | sumE es = foldl1' plus es 179 | 180 | -------------------------------------------------------------------------------- /luck/src/Outer/AST/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | module Outer.AST.Pretty where 3 | 4 | import Common.Pretty 5 | import Outer.AST 6 | import Text.PrettyPrint 7 | 8 | -- Hand written pretty-printer 9 | instance PP Op2 where 10 | pp = text . op2ToString 11 | 12 | op2ToString :: Op2 -> String 13 | op2ToString op 14 | = case op of 15 | OpPlus -> "+" 16 | OpMinus -> "-" 17 | OpTimes -> "*" 18 | OpDiv -> "/" 19 | OpMod -> "%" 20 | OpEq -> "==" 21 | OpNe -> "/=" 22 | OpLt -> "<" 23 | OpLe -> "<=" 24 | OpGt -> ">" 25 | OpGe -> ">=" 26 | 27 | instance PP Op1 where 28 | pp = text . op1ToString 29 | 30 | op1ToString OpNeg = "-" 31 | op1ToString OpNot = "!" 32 | 33 | ppVarId = text 34 | ppConId = text 35 | 36 | instance PP Decl where 37 | pp (FunDecl _ f xs e) 38 | = hang 39 | (sep [text "fun", ppVarId f, sep (map (ppVarId . snd) xs), text "="]) 40 | 2 (pp e) 41 | pp d = text $ show d 42 | 43 | instance PP Exp where 44 | pp (Var v) = ppVarId v 45 | pp (Con c) = ppConId c 46 | pp (Lit (LitInt i)) = int i 47 | pp (Unop op1 e) = pp op1 <+> ppParensUnless isAppOrAtom e 48 | pp (Conj e1 e2) = sep [ ppParensUnless isAppOrAtom e1 49 | , text "&&" 50 | , ppParensUnless isAppOrAtom e2 ] 51 | -- | TODO: Pretty-yPrint weights? 52 | pp (Disj w1 e1 w2 e2) = sep [ ppParensUnless isAppOrAtom e1 53 | , text "||" 54 | , ppParensUnless isAppOrAtom e2 ] 55 | pp (Binop e1 op2 e2) 56 | = sep [ ppParensUnless isAppOrAtom e1 57 | , pp op2 58 | , ppParensUnless isAppOrAtom e2 ] 59 | pp (If e1 e2 e3) 60 | = sep [ text "if" <+> pp e1 61 | , text "then" <+> pp e2 62 | , text "else" <+> pp e3 ] 63 | pp (Case e alts) 64 | = sep [ sep [text "case", nest 2 (pp e), text "of"] 65 | , vcat (map pp alts) 66 | , text "end" ] 67 | pp (Let bs e) 68 | = vcat [text "let" <+> vcat (map pp bs) <+> text "in", pp e] 69 | pp (App e1 e2) 70 | = sep [ ppParensUnless isAppOrAtom e1, ppParensUnless isAtomExp e2 ] 71 | pp (Delay v e) 72 | = text "[|" <> text v <> char '|' <+> pp e <+> text "|]" 73 | pp (TRACE _ e) = pp e 74 | 75 | isAtomExp (Var _) = True 76 | isAtomExp (Con _) = True 77 | isAtomExp (Lit _) = True 78 | isAtomExp (Delay _ _) = True 79 | isAtomExp e = False 80 | 81 | isAppOrAtom (App _ _) = True 82 | isAppOrAtom e = isAtomExp e 83 | 84 | instance PP Alt where 85 | pp (Alt _ w p e) 86 | = hang 87 | (hsep [ char '|', pp (maybe (litIntE 1) id w), char '%' 88 | , pp p, text "->"]) 89 | 2 (pp e) 90 | 91 | instance PP Pat where 92 | pp (PApp c ps) 93 | = ppConId c <+> sep (map (ppParensUnless isAtomPat) ps) 94 | pp (PVar v) = ppVarId v 95 | pp PWild = char '_' 96 | pp _ = error "Unimplemented" 97 | 98 | isAtomPat (PApp _ []) = True 99 | isAtomPat e = isDefaultPat e 100 | 101 | instance PP Prg where 102 | pp = vcat . map pp 103 | 104 | -------------------------------------------------------------------------------- /luck/src/Outer/ClassMono.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, RecordWildCards, TemplateHaskell #-} 2 | module Outer.ClassMono where 3 | 4 | import Data.Data 5 | import Data.Functor 6 | import Data.List 7 | import Data.Foldable (foldlM) 8 | import Data.Map.Lazy (Map) 9 | import qualified Data.Map.Lazy as Map 10 | import Data.Set (Set) 11 | import qualified Data.Set as Set 12 | 13 | import Control.Monad.State 14 | import Control.Monad.Except 15 | import Control.Monad.Writer hiding (Alt) 16 | import Control.Arrow 17 | 18 | import Control.Lens 19 | 20 | import Outer.AST 21 | import Common.Pretty (PP(..), (<+>)) 22 | import qualified Common.Pretty as PP 23 | import Common.SrcLoc 24 | import Common.Error 25 | import Common.Types 26 | import Outer.Types 27 | 28 | import Debug.Trace 29 | 30 | monomorphiseClasses :: Prg -> OTcEnv -> Either Message (Prg, OTcEnv) 31 | monomorphiseClasses dcls tc = do 32 | (decls, st) <- runStateT (mapM monomorphiseDecl dcls) (REnv Set.empty Map.empty) 33 | let tc' = Set.foldr (\fid (TcEnv ve ce ci tce) -> TcEnv (Map.delete fid ve) ce ci tce) (aux (concat decls) tc) (constrained st) 34 | return (snd $ unzip (concat decls), tc') 35 | where aux [] tc = tc 36 | aux ((False, _):rest) tc = tc 37 | aux ((True, FunDecl _ fid _ _ (Just t)):rest) (TcEnv ve ce ci tce) = 38 | -- New binding, add! 39 | let t' = fmap_tyvarid unPrimeTyVarId t in 40 | aux rest (TcEnv (Map.insert fid (Forall (fv t') t') ve) ce ci tce) 41 | 42 | data REnv = REnv { constrained :: Set VarId 43 | , renv :: Map VarId (Map OTcType' (Bool, VarId, Exp)) 44 | } deriving (Eq, Ord, Show) 45 | 46 | -- | Assumes ALL variables have different IDs (Rewriting phase needed!) 47 | type Declass a = StateT REnv (Either Message) a 48 | 49 | registerClassFun :: VarId -> Declass () 50 | registerClassFun fid = modify $ \st -> st{renv = Map.insert fid Map.empty (renv st)} 51 | 52 | registerInstance :: Bool -> VarId -> [(VarId, Maybe Int)] -> Exp -> OTcType' -> Declass () 53 | registerInstance b fid vars e ty = 54 | modify $ \st -> st {renv = Map.adjust (Map.insert ty (b, fid, Fun vars e)) fid (renv st)} 55 | 56 | registerConstrained :: VarId -> Declass () 57 | registerConstrained fid = 58 | modify $ \st -> st {constrained = Set.insert fid (constrained st)} 59 | 60 | monomorphiseDecl :: Decl -> Declass [(Bool, Decl)] 61 | monomorphiseDecl (ClassDecl _ _ _ binds) = do 62 | forM_ binds $ registerClassFun . fst 63 | pure [] 64 | monomorphiseDecl (InstanceDecl _ _ _ _ binds) = do 65 | forM_ binds $ \(fid, vars, e, Just ty) -> 66 | registerInstance True fid vars e ty 67 | pure [] 68 | monomorphiseDecl (TypeSig _ _ [] _) = pure [] 69 | monomorphiseDecl (TypeSig _ fid _ ty) = 70 | registerConstrained fid >> pure [] 71 | monomorphiseDecl (FunDecl loc fid args e mt) = do 72 | let Just t = mt -- This shouldn't fail 73 | st <- get 74 | if Set.member fid (constrained st) then do 75 | -- traceShowM ("Registering Constrained", fid) 76 | registerClassFun fid 77 | registerInstance True fid args e t 78 | pure [] 79 | else do 80 | (decls, e') <- replaceBindings e 81 | -- traceShowM ("Replace into", decls, fid, e') 82 | return (decls ++ [(False, FunDecl loc fid args e' mt)]) 83 | monomorphiseDecl d = pure [(False, d)] 84 | 85 | -- mgu' works with rigids as well. TODO: think about this more 86 | mgu' :: OTcType' -> OTcType' -> String -> Either Message Substitution 87 | mgu' (TcFun l1 r1) (TcFun l2 r2) err = do 88 | s1 <- mgu' l1 l2 err 89 | s2 <- mgu' (subst s1 r1) (subst s1 r2) err 90 | return $ s1 `after` s2 91 | mgu' (TcVar a) t _err = varAsgn a t 92 | mgu' t (TcVar a) _err = varAsgn a t 93 | --mgu' (TcVar (Rigid a)) (TcVar (Rigid b)) _err | a == b = return emptySub 94 | mgu' (TcCon c1 n1 ts1) (TcCon c2 n2 ts2) err 95 | | c1 == c2 && n1 == n2 = 96 | -- traceShow ("Here", c1, n1, "Folding over", ts1, ts2) $ 97 | foldM (\s (t1,t2) -> do 98 | s' <- mgu' (subst s t1) (subst s t2) err 99 | return $ s `after` s' 100 | ) emptySub (zip ts1 ts2) 101 | | otherwise = throwTypeE noLoc "Mismatched constructors" 102 | (show (c1,n1) ++ " - " ++ show (c2,n2) ++ " AT " ++ err) 103 | mgu' t1 t2 err = 104 | throwTypeE noLoc "Types do not unify" 105 | (show t1 ++ " - " ++ show t2 ++ " AT " ++ err) 106 | 107 | replaceBindings :: Exp -> Declass ([(Bool,Decl)], Exp) 108 | replaceBindings (Var (x, Nothing)) = return ([], Var (x, Nothing)) 109 | replaceBindings (Var (x, Just t)) = do 110 | st <- get 111 | let r = renv st 112 | -- traceShowM ("Replacing Binding of", x, t) 113 | case Map.lookup x r of 114 | Nothing -> {- trace "No lookup" $ -} return ([], Var (x, Just t)) 115 | Just m -> 116 | case Map.lookup t m of 117 | Just (b, _, e') -> if b then replaceBindings e' else return ([], Var (x, Just t)) 118 | Nothing -> aux (reverse $ Map.toAscList m) 119 | where aux [] = error ("TypeClass Resolution Failure: " ++ show x) 120 | aux ((t', (False, _, _)):bs) = aux bs -- Should have been found/monomorphized 121 | aux ( (t', (True, fidOrig, Fun vars eb)) : bs ) = do 122 | case mgu' t t' "Class things" of 123 | Left _ -> aux bs 124 | Right sub -> 125 | if Set.member x (constrained st) then do --Potentially recursive, do fancy stuff 126 | -- traceShowM ("Found!", t', fidOrig, eb) 127 | let fid' = x ++ show t -- Too much? 128 | eb' = subRecFun (fidOrig, fid') $ substExp sub eb 129 | registerClassFun fid' 130 | registerInstance False fid' vars (error " Should not be accessed... ClassMono" ) t 131 | (decls, eb'') <- replaceBindings eb' 132 | return ((True, FunDecl noLoc fid' vars eb'' (Just t)) : decls, (Var (fid', Just t))) 133 | else -- class definition, just continue after instantiating types in the body 134 | replaceBindings (Fun vars $ substExp sub eb) 135 | replaceBindings (Con c) = return . ([],) $ Con c 136 | replaceBindings (Lit l) = return . ([],) $ Lit l 137 | replaceBindings (Unop op e) = (second (Unop op)) <$> (replaceBindings e) 138 | replaceBindings (Conj e1 e2) = do 139 | (d1, e1') <- replaceBindings e1 140 | (d2, e2') <- replaceBindings e2 141 | return (d1 ++ d2, Conj e1' e2') 142 | replaceBindings (Disj me1 e1 me2 e2) = do 143 | (d1m, me1') <- replaceBindingsM me1 144 | (d1, e1') <- replaceBindings e1 145 | (d2m, me2') <- replaceBindingsM me2 146 | (d2, e2') <- replaceBindings e2 147 | return $ (d1m ++ d1 ++ d2m ++ d2, Disj me1' e1' me2' e2') 148 | replaceBindings (Binop e1 op e2) = do 149 | (d1, e1') <- replaceBindings e1 150 | (d2, e2') <- replaceBindings e2 151 | return (d1 ++ d2, Binop e1' op e2') 152 | replaceBindings (App e1 e2) = do 153 | (d1, e1') <- replaceBindings e1 154 | (d2, e2') <- replaceBindings e2 155 | return (d1 ++ d2, App e1' e2') 156 | replaceBindings (If e1 e2 e3) = do 157 | (d1, e1') <- replaceBindings e1 158 | (d2, e2') <- replaceBindings e2 159 | (d3, e3') <- replaceBindings e3 160 | return (d1 ++ d2 ++ d3, If e1' e2' e3') 161 | replaceBindings (Case e alts) = do 162 | (decls, e') <- replaceBindings e 163 | (decls', alts') <- unzip <$> mapM replaceBindingsAlt alts 164 | return (decls ++ concat decls', Case e' alts') 165 | replaceBindings (Fun args e) = 166 | second (Fun args) <$> (replaceBindings e) 167 | replaceBindings (Fresh x t s e) = 168 | second (Fresh x t s) <$> (replaceBindings e) 169 | replaceBindings (Inst e x) = second (\e' -> Inst e' x) <$> replaceBindings e 170 | replaceBindings (TRACE x e) = (second (TRACE x)) <$> (replaceBindings e) 171 | replaceBindings (Collect e1 e2) = do 172 | (dcl1, e1') <- replaceBindings e1 173 | (dcl2, e2') <- replaceBindings e2 174 | return $ (dcl1 ++ dcl2, Collect e1' e2') 175 | 176 | replaceBindingsM :: Maybe Exp -> Declass ([(Bool, Decl)], Maybe Exp) 177 | replaceBindingsM (Nothing) = return ([], Nothing) 178 | replaceBindingsM (Just e) = second Just <$> replaceBindings e 179 | 180 | replaceBindingsAlt (Alt loc me p e) = do 181 | (dcl, e') <- replaceBindings e 182 | return (dcl, Alt loc me p e') 183 | 184 | subRecFun :: (VarId, VarId) -> Exp -> Exp 185 | subRecFun (y, y') (Var (x, mt)) | x == y = Var (y', mt) 186 | | otherwise = {- traceShow ("subrecfun", x, y, y') $ -} Var (x, mt) 187 | subRecFun s (Con c) = Con c 188 | subRecFun s (Lit l) = Lit l 189 | subRecFun s (Unop op e) = Unop op $ subRecFun s e 190 | subRecFun s (Conj e1 e2) = Conj (subRecFun s e1) (subRecFun s e2) 191 | subRecFun s (Disj me1 e1 me2 e2) = Disj (subRecFun s <$> me1) (subRecFun s e1) 192 | (subRecFun s <$> me2) (subRecFun s e2) 193 | subRecFun s (Binop e1 op e2) = Binop (subRecFun s e1) op (subRecFun s e2) 194 | subRecFun s (App e1 e2) = App (subRecFun s e1) (subRecFun s e2) 195 | subRecFun s (If e1 e2 e3) = If (subRecFun s e1) (subRecFun s e2) (subRecFun s e3) 196 | subRecFun s (Case e alts) = Case (subRecFun s e) (map (subRecFunAlt s) alts) 197 | subRecFun s (Fun vars e) = Fun vars (subRecFun s e) 198 | subRecFun s (Fresh x t e1 e2) = Fresh x t (subRecFun s e1) (subRecFun s e2) 199 | subRecFun s (Inst e x) = Inst (subRecFun s e) x 200 | subRecFun s (TRACE x e) = TRACE x (subRecFun s e) 201 | subRecFun s (Collect e1 e2) = Collect (subRecFun s e1) (subRecFun s e2) 202 | 203 | subRecFunAlt s (Outer.AST.Alt loc weight pat e) = Outer.AST.Alt loc weight pat (subRecFun s e) 204 | -------------------------------------------------------------------------------- /luck/src/Outer/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | -- Turn off warnings in generated code 3 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 4 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 5 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 6 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 7 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 8 | {-# OPTIONS_GHC -funbox-strict-fields -fno-warn-tabs #-} 9 | 10 | module Outer.Lexer where 11 | 12 | import Common.SrcLoc 13 | import Common.Error 14 | import Outer.ParseMonad 15 | 16 | import Control.Monad.Except 17 | 18 | import Data.Char 19 | import Data.Int 20 | import Data.Word (Word8) 21 | import qualified Data.ByteString as BS 22 | import qualified Data.ByteString.Char8 as BSC 23 | import qualified Data.ByteString.UTF8 as BSU 24 | 25 | } 26 | 27 | $digit = 0-9 28 | $lower = [a-z] 29 | $upper = [A-Z] 30 | $alpha = [a-z A-Z] 31 | 32 | @lid = $lower [$alpha \_ \' \. $digit]* 33 | @uid = $upper [$alpha \_ \' \. $digit]* 34 | @str = \" .* \" 35 | 36 | tokens :- 37 | 38 | $white+ ; 39 | 40 | <0> { 41 | case { token TCase } 42 | of { token TOf } 43 | end { token TEnd } 44 | let { token TLet } 45 | let' { token TLetPrime } 46 | in { token TIn } 47 | if { token TIf } 48 | then { token TThen } 49 | else { token TElse } 50 | not { token TNot } 51 | data { token TData } 52 | sig { token TSig } 53 | fun { token TFun } 54 | fix { token TFix } 55 | fresh { token TFresh } 56 | collect { token TCollect } 57 | include { token TInclude } 58 | class { token TClass } 59 | instance { token TInstance } 60 | where { token TWhere } 61 | record { token TRecord } 62 | 63 | @str { lexStr } 64 | @lid { lexLid } 65 | @uid { lexUid } 66 | $digit+ { lexInt } 67 | 68 | "#TRACE" { token TTRACE } 69 | "=" { token TAssign } 70 | "()" { token TUnit } 71 | "(" { token TLParen } 72 | ")" { token TRParen } 73 | "[|" { token TLDelBracket } 74 | "|]" { token TRDelBracket } 75 | "[" { token TLBracket } 76 | "]" { token TRBracket } 77 | "{" { token TLCurBracket } 78 | "}" { token TRCurBracket } 79 | "_" { token TUnd } 80 | "!" { token TBang } 81 | "," { token TComma } 82 | ":" { token TColon } 83 | "::" { token TCons } 84 | "+" { token TPlus } 85 | "-" { token TMinus } 86 | "*" { token TTimes } 87 | "/" { token TDiv } 88 | "%" { token TPercent } 89 | "&&" { token TLAnd } 90 | "||" { token TLOr } 91 | "==" { token TEq } 92 | "/=" { token TNe } 93 | "<" { token TLt } 94 | ">" { token TGt } 95 | "<=" { token TLe } 96 | ">=" { token TGe } 97 | "->" { token TArrow } 98 | "|" { token TBar } 99 | "=>" { token TFatArrow } 100 | ";" { token TSemiColon } 101 | "." { token TDot } 102 | 103 | "*)" { mkLexerErrorP "Trying to close an unstarted comment" } 104 | } 105 | 106 | "--" .* ; 107 | "(*" { embedComment } 108 | { 109 | "*)" { unembedComment } 110 | . ; 111 | } 112 | 113 | . { unknownChar } 114 | 115 | { 116 | data Token 117 | = TAssign 118 | | TInt Int 119 | | TVar String 120 | | TCon String 121 | | TStr String 122 | | TUnit 123 | | TLParen 124 | | TRParen 125 | | TLBracket 126 | | TRBracket 127 | | TLDelBracket 128 | | TRDelBracket 129 | | TLCurBracket 130 | | TRCurBracket 131 | | TBang 132 | | TInclude 133 | | TCase 134 | | TOf 135 | | TEnd 136 | | TLet 137 | | TLetPrime 138 | | TIn 139 | | TIf 140 | | TThen 141 | | TElse 142 | | TData 143 | | TSig 144 | | TFun 145 | | TClass 146 | | TInstance 147 | | TRecord 148 | | TWhere 149 | | TInp 150 | | TUnd 151 | | TCons 152 | | TColon 153 | | TComma 154 | | TNot 155 | | TPlus 156 | | TMinus 157 | | TTimes 158 | | TDiv 159 | | TPercent 160 | | TLAnd 161 | | TLOr 162 | | TEq 163 | | TNe 164 | | TLt 165 | | TGt 166 | | TLe 167 | | TGe 168 | | TArrow 169 | | TFatArrow 170 | | TBar 171 | | TEof 172 | | TTRACE 173 | | TFix 174 | | TFresh 175 | | TCollect 176 | | TSemiColon 177 | | TDot 178 | deriving (Eq, Show) 179 | 180 | -- | Lexer actions :: Position -> Buffer -> Length -> P (Located Token) 181 | type Action = SrcLoc -> BS.ByteString -> Int -> P (Located Token) 182 | 183 | -- | Create a token at a given location 184 | token :: Token -> Action 185 | token t loc _buf _len = return (L loc t) 186 | 187 | -- | Skip 188 | skip :: Action 189 | skip _loc _buf _len = lexToken 190 | 191 | -- | Chain actions 192 | chain :: Action -> Int -> Action 193 | chain act code loc buf len = do {setLexState code ; act loc buf len} 194 | 195 | -- | Begin a specific code action 196 | begin :: Int -> Action 197 | begin code = skip `chain` code 198 | 199 | -- | Lex a string 200 | lexStr :: Action 201 | lexStr loc buf len = do 202 | let _:str = BSU.toString $ BSU.take (fromIntegral (len-1)) buf 203 | str `seq` return $ L loc (TStr str) 204 | 205 | -- | Lex a lowercase identifier 206 | lexLid :: Action 207 | lexLid loc buf len = do 208 | let id = BSU.toString $ BSU.take (fromIntegral len) buf 209 | id `seq` return $ L loc (TVar id) 210 | 211 | -- | Lex an uppercase identifier 212 | lexUid :: Action 213 | lexUid loc buf len = do 214 | let id = BSU.toString $ BSU.take (fromIntegral len) buf 215 | id `seq` return $ L loc (TCon id) 216 | 217 | -- | Lex an integer literal 218 | lexInt :: Action 219 | lexInt loc buf len = do 220 | case BSC.readInteger buf of 221 | Just (num, _) -> num `seq` return $ L loc (TInt $ fromInteger num) 222 | Nothing -> throwError $ mkInternalError "lexInt" 223 | 224 | -- | Start a new nested comment 225 | embedComment :: Action 226 | embedComment loc buf len = do 227 | incCommState 228 | begin comments loc buf len 229 | 230 | -- | End a possibly nested comment 231 | unembedComment :: Action 232 | unembedComment loc buf len = do 233 | decCommState 234 | status <- getCommState 235 | if status == 0 236 | then begin 0 loc buf len 237 | else lexToken 238 | 239 | -- | Unknown character.. error 240 | unknownChar :: Action 241 | unknownChar loc buf len = do 242 | case BSU.decode buf of 243 | Just (c,_) -> 244 | c `seq` mkLexerErrorP ("Unknown character `" ++ [c] ++ "'") loc buf len 245 | Nothing -> throwError $ mkInternalError "unknownChar" 246 | 247 | -- | Creates a Lexing error message 248 | mkLexerErrorP :: String -> Action 249 | mkLexerErrorP msg loc buf len = 250 | let tok = BSU.toString $ BSU.take (fromIntegral len) buf in 251 | throwError $ mkLexerError msg loc ("At token: " ++ tok) 252 | 253 | -- | lexToken is called every time a new token must be read from the input 254 | lexToken :: P (Located Token) 255 | lexToken = do 256 | inp@(AI loc1 buf) <- getInput 257 | sc <- getLexState 258 | case alexScan inp sc of 259 | AlexEOF -> do 260 | setLastToken loc1 "" 261 | if sc > 0 262 | then mkLexerErrorP "Unterminated comments" loc1 buf 0 263 | else return (L loc1 TEof) 264 | AlexError (AI loc2 buf2) -> 265 | mkLexerErrorP "Unknown" loc2 buf2 0 266 | AlexSkip inp2 _ -> do 267 | setInput inp2 268 | lexToken 269 | AlexToken inp2@(AI end _) len t -> do 270 | setInput inp2 271 | setLastToken loc1 (BSU.toString $ BSU.take (fromIntegral len) buf) 272 | t loc1 buf len 273 | 274 | -- | Full lexer with continuation 275 | lexer :: (Located Token -> P a) -> P a 276 | lexer cont = do 277 | tok@(L _span _tok__) <- lexToken 278 | cont tok 279 | 280 | -- | Dummy lexer for debugging 281 | lexDummy :: P [(Located Token)] 282 | lexDummy = do 283 | tok@(L _span t) <- lexToken 284 | if t == TEof 285 | then return [tok] 286 | else lexDummy >>= return . (tok:) 287 | 288 | } 289 | -------------------------------------------------------------------------------- /luck/src/Outer/ParseMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Outer.ParseMonad where 3 | 4 | import Common.Error 5 | import Common.SrcLoc 6 | 7 | import Data.Char 8 | import Data.Word (Word8) 9 | import qualified Data.ByteString as BS 10 | 11 | import Control.Monad.State 12 | 13 | -- | Parser State 14 | data PState = PState { 15 | _buffer :: BS.ByteString, 16 | _last_loc :: SrcLoc, -- pos of previous token 17 | _last_tok :: !String, -- string of the previous token 18 | _cur_loc :: SrcLoc, -- current loc (end of token + 1) 19 | _lex_state :: !Int, 20 | _comment_state :: !Int 21 | } 22 | 23 | -- | Create an initial Parser State 24 | mkPState :: BS.ByteString -> SrcLoc -> PState 25 | mkPState buf loc = 26 | PState { 27 | _buffer = buf, 28 | _last_loc = loc, 29 | _last_tok = "", 30 | _cur_loc = loc, 31 | _lex_state = 0, 32 | _comment_state = 0 33 | } 34 | 35 | -- | Parsing Monad 36 | type P a = StateT PState (Either Message) a 37 | 38 | runP :: P a -> PState -> Either Message a 39 | runP = evalStateT 40 | 41 | -- | Input for Alex interop 42 | data AlexInput = AI SrcLoc BS.ByteString 43 | -- ^ current position & current input string 44 | 45 | -- | Get the current (located) input of the parser 46 | getInput :: P AlexInput 47 | getInput = do 48 | PState{..} <- get 49 | return $ AI _cur_loc _buffer 50 | 51 | -- | Set the input of the parser 52 | setInput :: AlexInput -> P () 53 | setInput (AI loc buf) = modify $ \s -> s{_cur_loc = loc 54 | ,_buffer = buf} 55 | 56 | -- | Get the current lexing state 57 | getLexState :: P Int 58 | getLexState = get >>= return . _lex_state 59 | 60 | -- | Set the current lexing state 61 | setLexState :: Int -> P () 62 | setLexState new_state = modify $ \s -> s{_lex_state = new_state} 63 | 64 | -- | Get the current source location 65 | getSrcLoc :: P SrcLoc 66 | getSrcLoc = get >>= return . _cur_loc 67 | 68 | -- | Set the current source location 69 | setSrcLoc :: SrcLoc -> P () 70 | setSrcLoc new_loc = modify $ \s -> s{_cur_loc = new_loc} 71 | 72 | -- | Set the last token of the parser state 73 | setLastToken :: SrcLoc -> String -> P () 74 | setLastToken loc str = 75 | modify $ \s -> s {_last_loc = loc 76 | ,_last_tok = str} 77 | 78 | -- | Increase comment state (for nesting) 79 | incCommState :: P () 80 | incCommState = modify $ \ s-> s{_comment_state = _comment_state s + 1} 81 | 82 | -- | Decrease comment state (ends nesting) 83 | decCommState :: P () 84 | decCommState = modify $ \s -> s{_comment_state = _comment_state s - 1} 85 | 86 | -- | Get current comment state 87 | getCommState :: P Int 88 | getCommState = get >>= return . _comment_state 89 | 90 | -- | TODO: implement if needed 91 | alexInputPrevChar :: AlexInput -> Char 92 | alexInputPrevChar _ = error "alexInputPrevChar not implemented" 93 | 94 | -- | Get the next byte from the input. 95 | alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) 96 | alexGetByte (AI loc buf) 97 | | BS.null buf = Nothing 98 | | otherwise = 99 | let w = BS.head buf 100 | buf' = BS.tail buf 101 | loc' = advanceSrcLoc loc w 102 | in w `seq` loc' `seq` Just (w, AI loc' buf') 103 | 104 | -- | Alex 2.x compatibility 105 | alexGetChar :: AlexInput -> Maybe (Char, AlexInput) 106 | alexGetChar i = 107 | case alexGetByte i of 108 | Nothing -> Nothing 109 | Just (b,i') -> 110 | if b<0x80 111 | then 112 | Just (chr (fromIntegral b), i') 113 | else 114 | undefined 115 | 116 | -------------------------------------------------------------------------------- /luck/src/Outer/Renamer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections, FlexibleContexts #-} 2 | module Outer.Renamer 3 | ( rename 4 | , subsExp 5 | ) where 6 | 7 | import Outer.AST 8 | import Common.Error 9 | import Common.SrcLoc 10 | 11 | import Control.Applicative 12 | import Control.Monad 13 | import Control.Monad.State 14 | import Control.Monad.Reader 15 | import Control.Monad.Except 16 | import Control.Arrow 17 | 18 | import Data.Map (Map) 19 | import qualified Data.Map as Map 20 | 21 | import Debug.Trace 22 | import qualified Common.Types as CT 23 | 24 | data RState = RS { env :: Map VarId VarId 25 | , rev :: Map VarId VarId 26 | , nat :: Int 27 | } deriving (Show) 28 | 29 | -- | Modifies the behavior of renaming actions. 30 | data RenamerMode = RM 31 | { _fresh :: VarId -> Renamer_ VarId 32 | , _lookupVar :: VarId -> Renamer_ VarId 33 | } 34 | 35 | -- | Renaming parameterized by @RenamerMode@. 36 | type Renamer = ReaderT RenamerMode Renamer_ 37 | -- | The original Renamer monad. 38 | type Renamer_ = StateT RState (Either Message) 39 | 40 | lookupWith f x = do 41 | lookupF <- f <$> ask 42 | lift $ lookupF x 43 | 44 | fresh :: VarId -> Renamer VarId 45 | fresh = lookupWith _fresh 46 | 47 | lookupVar :: VarId -> Renamer VarId 48 | lookupVar = lookupWith _lookupVar 49 | 50 | -- | Modifier for the renaming phase. 51 | uniqueRM :: RenamerMode 52 | uniqueRM = RM 53 | { _fresh = \x -> do 54 | rs@RS{..} <- get 55 | let x' = x ++ "@" ++ show nat 56 | env' = Map.insert x x' env 57 | rev' = Map.insert x' x rev 58 | nat' = nat + 1 59 | put rs{rev = rev', nat = nat', env = env'} 60 | return x' 61 | , _lookupVar = \x -> do 62 | RS{..} <- get 63 | case Map.lookup x env of 64 | Just x' -> return x' 65 | Nothing -> throwParseE noLoc "(Renamer) Unknown variable: " x 66 | } 67 | 68 | withEnv :: Map VarId VarId -> Renamer a -> Renamer a 69 | withEnv e m = do 70 | rs <- get 71 | put rs{env = e} 72 | m 73 | 74 | rename :: Prg -> Either Message (Map VarId VarId, Map VarId VarId, Prg) 75 | rename decls = 76 | case runStateT (renamerUnique $ mapM_ renameSigs decls >> mapM renameDecl decls) empty of 77 | Right (decls', rs) -> Right (env rs, rev rs, decls') 78 | Left err -> Left err 79 | where 80 | renamerUnique :: Renamer a -> Renamer_ a 81 | renamerUnique m = runReaderT m uniqueRM 82 | empty = RS Map.empty Map.empty 0 83 | 84 | -- | Modifier for simple substitutions. 85 | subsRM :: RenamerMode 86 | subsRM = RM 87 | { _fresh = subs -- Rename bound variables 88 | , _lookupVar = subs 89 | } where subs x = Map.findWithDefault x x . env <$> get 90 | 91 | runSubs :: Map VarId VarId -> Renamer a -> a 92 | runSubs s m 93 | = case evalStateT (renamerSubs m) s' of 94 | Left m -> error $ "Invalid arguments. " ++ show m 95 | Right e' -> e' 96 | where 97 | renamerSubs :: Renamer a -> Renamer_ a 98 | renamerSubs m = runReaderT m subsRM 99 | s' = RS s (error "Unused") (error "Unused") 100 | 101 | subsExp :: Map VarId VarId -> Exp -> Exp 102 | subsExp s e = runSubs s (renameExp e) 103 | 104 | renameSigs :: Decl -> Renamer () 105 | renameSigs (TypeSig loc fid _ ty) = do 106 | _ <- fresh fid 107 | return () 108 | renameSigs _ = return () 109 | 110 | renameDecl :: Decl -> Renamer Decl 111 | renameDecl (FunDecl loc fid vars e mt) = do 112 | rs <- get 113 | fid' <- case Map.lookup fid (env rs) of 114 | Nothing -> fresh fid 115 | Just f -> return f 116 | vars' <- mapM (\(a,b) -> (,b) <$> fresh a) vars 117 | e' <- renameExp e 118 | return $ FunDecl loc fid' vars' e' mt 119 | renameDecl (TypeSig loc fid ctrs ty) = do 120 | rs <- get 121 | case Map.lookup fid (env rs) of 122 | Nothing -> error "Sig not processed twice? (rename)" 123 | Just fid' -> return $ TypeSig loc fid' ctrs ty 124 | renameDecl d@(ClassDecl loc cid typ bindings) = do 125 | bindings' <- mapM (\(a,b) -> (,b) <$> fresh a) bindings 126 | return (ClassDecl loc cid typ bindings') 127 | renameDecl (InstanceDecl loc cid typ ctrs bindings) = do 128 | bindings' <- mapM (\(fid, vars, e, mt) -> do 129 | fid' <- lookupVar fid 130 | vars' <- mapM (\(a,b) -> (,b) <$> fresh a) vars 131 | e' <- renameExp e 132 | return (fid', vars', e', mt) 133 | ) bindings 134 | return (InstanceDecl loc cid typ ctrs bindings') 135 | renameDecl d = pure d 136 | 137 | renameAlt :: Alt -> Renamer Alt 138 | renameAlt (Alt loc Nothing p e) = 139 | liftM2 (Alt loc Nothing) (renamePat p) (renameExp e) 140 | renameAlt (Alt loc (Just w) p e) = 141 | liftM3 (Alt loc) (fmap Just $ renameExp w) (renamePat p) (renameExp e) 142 | 143 | renamePat :: Pat -> Renamer Pat 144 | renamePat (PVar x) = fmap PVar $ fresh x 145 | renamePat (PLit l) = pure $ PLit l 146 | renamePat PWild = pure $ PWild 147 | renamePat (PApp x pats) = fmap (PApp x) $ mapM renamePat pats 148 | 149 | renameMaybeExp :: Maybe Exp -> Renamer (Maybe Exp) 150 | renameMaybeExp Nothing = return Nothing 151 | renameMaybeExp (Just e) = do 152 | e' <- renameExp e 153 | return $ Just e' 154 | 155 | renameExp :: Exp -> Renamer Exp 156 | renameExp (Var (x, _)) = lookupVar x >>= (\x' -> return $ Var (x', Nothing)) 157 | renameExp (Con c) = pure $ Con c 158 | renameExp (Lit l) = pure $ Lit l 159 | renameExp (Unop op e) = fmap (Unop op) $ renameExp e 160 | renameExp (Conj e1 e2) = liftM2 Conj (renameExp e1) (renameExp e2) 161 | renameExp (Disj w1 e1 w2 e2) = liftM4 Disj (renameMaybeExp w1) (renameExp e1) 162 | (renameMaybeExp w2) (renameExp e2) 163 | renameExp (Binop e1 op e2) = 164 | liftM3 Binop (renameExp e1) (pure op) (renameExp e2) 165 | renameExp (App e1 e2) = 166 | liftM2 App (renameExp e1) (renameExp e2) 167 | renameExp (If e1 e2 e3) = 168 | liftM3 If (renameExp e1) (renameExp e2) (renameExp e3) 169 | renameExp (Case e alts) = do 170 | e' <- renameExp e 171 | RS{env = env} <- get 172 | alts' <- mapM (withEnv env . renameAlt) alts 173 | return $ Case e' alts' 174 | renameExp (Fun vs e) = do 175 | vs' <- mapM (\(v,d) -> (,d) <$> fresh v) vs 176 | Fun vs' <$> renameExp e 177 | renameExp (Let b e) = error "Implement renameExp" 178 | renameExp (Fix e) = Fix <$> renameExp e 179 | renameExp (FixN n e) = FixN n <$> renameExp e 180 | renameExp (Inst e x) = liftM2 Inst (renameExp e) (lookupVar x) 181 | renameExp (Fresh x t en e) = liftM4 Fresh (fresh x) (pure t) (renameExp en) (renameExp e) 182 | renameExp (TRACE v e) = liftM2 TRACE (lookupVar v) (renameExp e) 183 | renameExp (Collect e1 e2) = liftM2 Collect (renameExp e1) (renameExp e2) 184 | 185 | --renameTcEnv :: Map VarId VarId -> OTcEnv -> OTcEnv 186 | --renameTcEnv venv t = 187 | -- t{CT.varEnv = Map.mapKeys (venv Map.!) $ CT.varEnv t} 188 | -------------------------------------------------------------------------------- /luck/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.11 2 | packages: 3 | - . 4 | extra-deps: 5 | - 'rosezipper-0.2' 6 | flags: {} 7 | extra-package-dbs: [] 8 | --------------------------------------------------------------------------------