diff options
| author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
|---|---|---|
| committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
| commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
| tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/array/should_run | |
| parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
| download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz | |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/array/should_run')
46 files changed, 950 insertions, 0 deletions
diff --git a/testsuite/tests/array/should_run/Makefile b/testsuite/tests/array/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/array/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/array/should_run/all.T b/testsuite/tests/array/should_run/all.T new file mode 100644 index 0000000000..8b1ab2dd4d --- /dev/null +++ b/testsuite/tests/array/should_run/all.T @@ -0,0 +1,25 @@ + +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero + +test('arr001', skip_if_fast, compile_and_run, ['']) +test('arr002', skip_if_fast, compile_and_run, ['']) +test('arr003', compose(skip_if_fast,exit_code(1)), compile_and_run, ['']) +test('arr004', compose(skip_if_fast,exit_code(1)), compile_and_run, ['']) +test('arr005', skip_if_fast, compile_and_run, ['']) +test('arr006', skip_if_fast, compile_and_run, ['']) +test('arr007', compose(skip_if_fast,exit_code(1)), compile_and_run, ['']) +test('arr008', compose(skip_if_fast,exit_code(1)), compile_and_run, ['']) +test('arr009', skip_if_fast, compile_and_run, ['']) +test('arr010', skip_if_fast, compile_and_run, ['']) +test('arr011', skip_if_fast, compile_and_run, ['']) +test('arr012', skip_if_fast, compile_and_run, ['']) +test('arr013', skip_if_fast, compile_and_run, ['']) +test('arr014', skip_if_fast, compile_and_run, ['']) +test('arr015', skip_if_fast, compile_and_run, ['']) +test('arr016', reqlib('random'), compile_and_run, ['']) +test('arr017', skip_if_fast, compile_and_run, ['']) +test('arr018', skip_if_fast, compile_and_run, ['']) +test('arr019', normal, compile_and_run, ['']) diff --git a/testsuite/tests/array/should_run/arr001.hs b/testsuite/tests/array/should_run/arr001.hs new file mode 100644 index 0000000000..325ce1bc09 --- /dev/null +++ b/testsuite/tests/array/should_run/arr001.hs @@ -0,0 +1,9 @@ +-- !!! Simple array creation + +import Data.Array + +main = + let a1 = array (1,3) (zip [2,3,1] ['a'..'d']) in + print a1 + +-- Result: diff --git a/testsuite/tests/array/should_run/arr001.stdout b/testsuite/tests/array/should_run/arr001.stdout new file mode 100644 index 0000000000..5d4420352e --- /dev/null +++ b/testsuite/tests/array/should_run/arr001.stdout @@ -0,0 +1 @@ +array (1,3) [(1,'c'),(2,'a'),(3,'b')] diff --git a/testsuite/tests/array/should_run/arr002.hs b/testsuite/tests/array/should_run/arr002.hs new file mode 100644 index 0000000000..a26a60281c --- /dev/null +++ b/testsuite/tests/array/should_run/arr002.hs @@ -0,0 +1,23 @@ +-- !!! Array creation, (index,value) list with duplicates. +-- +-- Haskell library report 1.3 (and earlier) specifies +-- that `array' values created with lists containing dups, +-- are undefined ( _|_ ). +-- +-- GHC-2.02 (and earlier) does not flag this as such, the +-- last (index,value) is instead used. +-- +-- The report also specifies `array' is spine strict in +-- the (index,value) list argument and to check the +-- validity of the index values upon creation, it also +-- strict for the indices. To test this, we do (a!1) +-- twice, expecting to see the same value.. +-- +import Data.Array + +main = + let a1 = array (1,3) (zip (1:[1..3]) ['a'..'d']) in + print (a1!1) >> + print a1 >> + print (a1!1) + diff --git a/testsuite/tests/array/should_run/arr002.stdout b/testsuite/tests/array/should_run/arr002.stdout new file mode 100644 index 0000000000..ca55f16bbc --- /dev/null +++ b/testsuite/tests/array/should_run/arr002.stdout @@ -0,0 +1,3 @@ +'b' +array (1,3) [(1,'b'),(2,'c'),(3,'d')] +'b' diff --git a/testsuite/tests/array/should_run/arr003.hs b/testsuite/tests/array/should_run/arr003.hs new file mode 100644 index 0000000000..8f156ab6d9 --- /dev/null +++ b/testsuite/tests/array/should_run/arr003.hs @@ -0,0 +1,16 @@ +-- !!! Array creation, (index,value) list with out of bound index. +-- +-- Haskell library report 1.3 (and earlier) specifies +-- that `array' values created with lists containing out-of-bounds indices, +-- are undefined ( _|_ ). +-- +-- GHC implementation of `array' catches this (or, rather, +-- `index' does) - the argument list to `array' is defined +-- to have its spine be evaluated - so the indexing below +-- should cause a failure. +-- +import Data.Array + +main = + let a1 = array (1::Int,3) (zip ([1..4]) ['a'..'d']) in + print (a1!2) diff --git a/testsuite/tests/array/should_run/arr003.stderr b/testsuite/tests/array/should_run/arr003.stderr new file mode 100644 index 0000000000..8f3945286b --- /dev/null +++ b/testsuite/tests/array/should_run/arr003.stderr @@ -0,0 +1 @@ +arr003: Ix{Int}.index: Index (4) out of range ((1,3)) diff --git a/testsuite/tests/array/should_run/arr003.stderr-hugs b/testsuite/tests/array/should_run/arr003.stderr-hugs new file mode 100644 index 0000000000..0f838fa8cd --- /dev/null +++ b/testsuite/tests/array/should_run/arr003.stderr-hugs @@ -0,0 +1 @@ +arr003: Ix.index: index out of range diff --git a/testsuite/tests/array/should_run/arr004.hs b/testsuite/tests/array/should_run/arr004.hs new file mode 100644 index 0000000000..0d7e5b445f --- /dev/null +++ b/testsuite/tests/array/should_run/arr004.hs @@ -0,0 +1,15 @@ +-- !!! Array - accessing undefined element +-- +-- Sample Haskell implementation in the 1.3 Lib report defines +-- this as being undefined/error. + +import Data.Array + +main = + let a1 = array (1,3) (zip ([1,2]) ['a'..'d']) in + print (a1!3) + +-- output: Fail: (Array.!): undefined array element + + + diff --git a/testsuite/tests/array/should_run/arr004.stderr b/testsuite/tests/array/should_run/arr004.stderr new file mode 100644 index 0000000000..b69cbf5b62 --- /dev/null +++ b/testsuite/tests/array/should_run/arr004.stderr @@ -0,0 +1 @@ +arr004: (Array.!): undefined array element diff --git a/testsuite/tests/array/should_run/arr004.stderr-hugs b/testsuite/tests/array/should_run/arr004.stderr-hugs new file mode 100644 index 0000000000..2d1decd612 --- /dev/null +++ b/testsuite/tests/array/should_run/arr004.stderr-hugs @@ -0,0 +1 @@ +arr004: undefined array element diff --git a/testsuite/tests/array/should_run/arr005.hs b/testsuite/tests/array/should_run/arr005.hs new file mode 100644 index 0000000000..274f8bb1c1 --- /dev/null +++ b/testsuite/tests/array/should_run/arr005.hs @@ -0,0 +1,16 @@ +-- !!! Array - recurrences +-- +-- array does not evaluate the elements. +-- +import Data.Array + +main = + let + a1 = array (1,100) ((1,1::Integer):[(i,i*a1!(i-1))|i<-[2..100]]) + in + print a1 + +-- + + + diff --git a/testsuite/tests/array/should_run/arr005.stdout b/testsuite/tests/array/should_run/arr005.stdout new file mode 100644 index 0000000000..5048dd0479 --- /dev/null +++ b/testsuite/tests/array/should_run/arr005.stdout @@ -0,0 +1 @@ +array (1,100) [(1,1),(2,2),(3,6),(4,24),(5,120),(6,720),(7,5040),(8,40320),(9,362880),(10,3628800),(11,39916800),(12,479001600),(13,6227020800),(14,87178291200),(15,1307674368000),(16,20922789888000),(17,355687428096000),(18,6402373705728000),(19,121645100408832000),(20,2432902008176640000),(21,51090942171709440000),(22,1124000727777607680000),(23,25852016738884976640000),(24,620448401733239439360000),(25,15511210043330985984000000),(26,403291461126605635584000000),(27,10888869450418352160768000000),(28,304888344611713860501504000000),(29,8841761993739701954543616000000),(30,265252859812191058636308480000000),(31,8222838654177922817725562880000000),(32,263130836933693530167218012160000000),(33,8683317618811886495518194401280000000),(34,295232799039604140847618609643520000000),(35,10333147966386144929666651337523200000000),(36,371993326789901217467999448150835200000000),(37,13763753091226345046315979581580902400000000),(38,523022617466601111760007224100074291200000000),(39,20397882081197443358640281739902897356800000000),(40,815915283247897734345611269596115894272000000000),(41,33452526613163807108170062053440751665152000000000),(42,1405006117752879898543142606244511569936384000000000),(43,60415263063373835637355132068513997507264512000000000),(44,2658271574788448768043625811014615890319638528000000000),(45,119622220865480194561963161495657715064383733760000000000),(46,5502622159812088949850305428800254892961651752960000000000),(47,258623241511168180642964355153611979969197632389120000000000),(48,12413915592536072670862289047373375038521486354677760000000000),(49,608281864034267560872252163321295376887552831379210240000000000),(50,30414093201713378043612608166064768844377641568960512000000000000),(51,1551118753287382280224243016469303211063259720016986112000000000000),(52,80658175170943878571660636856403766975289505440883277824000000000000),(53,4274883284060025564298013753389399649690343788366813724672000000000000),(54,230843697339241380472092742683027581083278564571807941132288000000000000),(55,12696403353658275925965100847566516959580321051449436762275840000000000000),(56,710998587804863451854045647463724949736497978881168458687447040000000000000),(57,40526919504877216755680601905432322134980384796226602145184481280000000000000),(58,2350561331282878571829474910515074683828862318181142924420699914240000000000000),(59,138683118545689835737939019720389406345902876772687432540821294940160000000000000),(60,8320987112741390144276341183223364380754172606361245952449277696409600000000000000),(61,507580213877224798800856812176625227226004528988036003099405939480985600000000000000),(62,31469973260387937525653122354950764088012280797258232192163168247821107200000000000000),(63,1982608315404440064116146708361898137544773690227268628106279599612729753600000000000000),(64,126886932185884164103433389335161480802865516174545192198801894375214704230400000000000000),(65,8247650592082470666723170306785496252186258551345437492922123134388955774976000000000000000),(66,544344939077443064003729240247842752644293064388798874532860126869671081148416000000000000000),(67,36471110918188685288249859096605464427167635314049524593701628500267962436943872000000000000000),(68,2480035542436830599600990418569171581047399201355367672371710738018221445712183296000000000000000),(69,171122452428141311372468338881272839092270544893520369393648040923257279754140647424000000000000000),(70,11978571669969891796072783721689098736458938142546425857555362864628009582789845319680000000000000000),(71,850478588567862317521167644239926010288584608120796235886430763388588680378079017697280000000000000000),(72,61234458376886086861524070385274672740778091784697328983823014963978384987221689274204160000000000000000),(73,4470115461512684340891257138125051110076800700282905015819080092370422104067183317016903680000000000000000),(74,330788544151938641225953028221253782145683251820934971170611926835411235700971565459250872320000000000000000),(75,24809140811395398091946477116594033660926243886570122837795894512655842677572867409443815424000000000000000000),(76,1885494701666050254987932260861146558230394535379329335672487982961844043495537923117729972224000000000000000000),(77,145183092028285869634070784086308284983740379224208358846781574688061991349156420080065207861248000000000000000000),(78,11324281178206297831457521158732046228731749579488251990048962825668835325234200766245086213177344000000000000000000),(79,894618213078297528685144171539831652069808216779571907213868063227837990693501860533361810841010176000000000000000000),(80,71569457046263802294811533723186532165584657342365752577109445058227039255480148842668944867280814080000000000000000000),(81,5797126020747367985879734231578109105412357244731625958745865049716390179693892056256184534249745940480000000000000000000),(82,475364333701284174842138206989404946643813294067993328617160934076743994734899148613007131808479167119360000000000000000000),(83,39455239697206586511897471180120610571436503407643446275224357528369751562996629334879591940103770870906880000000000000000000),(84,3314240134565353266999387579130131288000666286242049487118846032383059131291716864129885722968716753156177920000000000000000000),(85,281710411438055027694947944226061159480056634330574206405101912752560026159795933451040286452340924018275123200000000000000000000),(86,24227095383672732381765523203441259715284870552429381750838764496720162249742450276789464634901319465571660595200000000000000000000),(87,2107757298379527717213600518699389595229783738061356212322972511214654115727593174080683423236414793504734471782400000000000000000000),(88,185482642257398439114796845645546284380220968949399346684421580986889562184028199319100141244804501828416633516851200000000000000000000),(89,16507955160908461081216919262453619309839666236496541854913520707833171034378509739399912570787600662729080382999756800000000000000000000),(90,1485715964481761497309522733620825737885569961284688766942216863704985393094065876545992131370884059645617234469978112000000000000000000000),(91,135200152767840296255166568759495142147586866476906677791741734597153670771559994765685283954750449427751168336768008192000000000000000000000),(92,12438414054641307255475324325873553077577991715875414356840239582938137710983519518443046123837041347353107486982656753664000000000000000000000),(93,1156772507081641574759205162306240436214753229576413535186142281213246807121467315215203289516844845303838996289387078090752000000000000000000000),(94,108736615665674308027365285256786601004186803580182872307497374434045199869417927630229109214583415458560865651202385340530688000000000000000000000),(95,10329978488239059262599702099394727095397746340117372869212250571234293987594703124871765375385424468563282236864226607350415360000000000000000000000),(96,991677934870949689209571401541893801158183648651267795444376054838492222809091499987689476037000748982075094738965754305639874560000000000000000000000),(97,96192759682482119853328425949563698712343813919172976158104477319333745612481875498805879175589072651261284189679678167647067832320000000000000000000000),(98,9426890448883247745626185743057242473809693764078951663494238777294707070023223798882976159207729119823605850588608460429412647567360000000000000000000000),(99,933262154439441526816992388562667004907159682643816214685929638952175999932299156089414639761565182862536979208272237582511852109168640000000000000000000000),(100,93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000)] diff --git a/testsuite/tests/array/should_run/arr006.hs b/testsuite/tests/array/should_run/arr006.hs new file mode 100644 index 0000000000..52d21c6f3d --- /dev/null +++ b/testsuite/tests/array/should_run/arr006.hs @@ -0,0 +1,11 @@ +-- !!! Array - empty arrays +-- +-- print a couple of them to try to expose empty arrays +-- to a GC or two. +import Data.Array + +main = + let + a1 = array (1,0) [] + in + print (take 300 $ repeat (a1 :: Array Int Int)) diff --git a/testsuite/tests/array/should_run/arr006.stdout b/testsuite/tests/array/should_run/arr006.stdout new file mode 100644 index 0000000000..289deeec07 --- /dev/null +++ b/testsuite/tests/array/should_run/arr006.stdout @@ -0,0 +1 @@ +[array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) [],array (1,0) []] diff --git a/testsuite/tests/array/should_run/arr007.hs b/testsuite/tests/array/should_run/arr007.hs new file mode 100644 index 0000000000..d4461d8d5e --- /dev/null +++ b/testsuite/tests/array/should_run/arr007.hs @@ -0,0 +1,11 @@ +-- !!! Array - accessing empty arrays +-- +-- empty arrays are legal, but indexing them is undefined! +-- +import Data.Array + +main = + let + a1 = array (1::Int,0) [(1,'a')] + in + print (a1!0) diff --git a/testsuite/tests/array/should_run/arr007.stderr b/testsuite/tests/array/should_run/arr007.stderr new file mode 100644 index 0000000000..feaa5d8363 --- /dev/null +++ b/testsuite/tests/array/should_run/arr007.stderr @@ -0,0 +1 @@ +arr007: Ix{Int}.index: Index (1) out of range ((1,0)) diff --git a/testsuite/tests/array/should_run/arr007.stderr-hugs b/testsuite/tests/array/should_run/arr007.stderr-hugs new file mode 100644 index 0000000000..aa4c83b32e --- /dev/null +++ b/testsuite/tests/array/should_run/arr007.stderr-hugs @@ -0,0 +1 @@ +arr007: Ix.index: index out of range diff --git a/testsuite/tests/array/should_run/arr008.hs b/testsuite/tests/array/should_run/arr008.hs new file mode 100644 index 0000000000..14152c5a9d --- /dev/null +++ b/testsuite/tests/array/should_run/arr008.hs @@ -0,0 +1,14 @@ +-- !!! Array - out-of-range (index,value) pairs +-- +-- supplying a list containing one or more pairs +-- with out-of-range index is undefined. +-- +-- +import Data.Array + +main = + let + a1 = array (1::Int,0) [] + a2 = array (0::Int,1) (zip [0..] ['a'..'z']) + in + print (a1::Array Int Int) >> print a2 diff --git a/testsuite/tests/array/should_run/arr008.stderr b/testsuite/tests/array/should_run/arr008.stderr new file mode 100644 index 0000000000..f926f7288c --- /dev/null +++ b/testsuite/tests/array/should_run/arr008.stderr @@ -0,0 +1 @@ +arr008: Ix{Int}.index: Index (2) out of range ((0,1)) diff --git a/testsuite/tests/array/should_run/arr008.stderr-hugs b/testsuite/tests/array/should_run/arr008.stderr-hugs new file mode 100644 index 0000000000..4de58dad3b --- /dev/null +++ b/testsuite/tests/array/should_run/arr008.stderr-hugs @@ -0,0 +1 @@ +arr008: Ix.index: index out of range diff --git a/testsuite/tests/array/should_run/arr008.stdout b/testsuite/tests/array/should_run/arr008.stdout new file mode 100644 index 0000000000..825444d25b --- /dev/null +++ b/testsuite/tests/array/should_run/arr008.stdout @@ -0,0 +1 @@ +array (1,0) [] diff --git a/testsuite/tests/array/should_run/arr008.stdout-hugs b/testsuite/tests/array/should_run/arr008.stdout-hugs new file mode 100644 index 0000000000..bbad9774f5 --- /dev/null +++ b/testsuite/tests/array/should_run/arr008.stdout-hugs @@ -0,0 +1,2 @@ +array (1,0) [] +array
\ No newline at end of file diff --git a/testsuite/tests/array/should_run/arr009.hs b/testsuite/tests/array/should_run/arr009.hs new file mode 100644 index 0000000000..290147d0a0 --- /dev/null +++ b/testsuite/tests/array/should_run/arr009.hs @@ -0,0 +1,17 @@ +-- !!! Array - derived ops +-- +-- testing the well-behavedness of +-- derived ops for empty and non-empty arrays +-- +import Data.Array + +main = + let + a1 = array (1,0) ([]::[(Int,Int)]) + a2 = array (1,26) (zip [1..] ['a'..'z']) + + dump a = (bounds a, indices a, elems a, assocs a) + in + print (dump a1) >> + print (dump a2) + diff --git a/testsuite/tests/array/should_run/arr009.stdout b/testsuite/tests/array/should_run/arr009.stdout new file mode 100644 index 0000000000..5816fd7906 --- /dev/null +++ b/testsuite/tests/array/should_run/arr009.stdout @@ -0,0 +1,2 @@ +((1,0),[],[],[]) +((1,26),[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26],"abcdefghijklmnopqrstuvwxyz",[(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e'),(6,'f'),(7,'g'),(8,'h'),(9,'i'),(10,'j'),(11,'k'),(12,'l'),(13,'m'),(14,'n'),(15,'o'),(16,'p'),(17,'q'),(18,'r'),(19,'s'),(20,'t'),(21,'u'),(22,'v'),(23,'w'),(24,'x'),(25,'y'),(26,'z')]) diff --git a/testsuite/tests/array/should_run/arr010.hs b/testsuite/tests/array/should_run/arr010.hs new file mode 100644 index 0000000000..d5b7f38c1c --- /dev/null +++ b/testsuite/tests/array/should_run/arr010.hs @@ -0,0 +1,18 @@ +-- !!! Array - accumulated arrays +-- +-- +module Main(main) where + +import Data.Array +import Data.Ix + +hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b +hist bnds is = accumArray (+) 0 bnds [(i,1) | i <- is , inRange bnds i] + +main = + let + a1 = hist (0,10) (concat $ take 2 $ repeat [1..20]) + in + print a1 + + diff --git a/testsuite/tests/array/should_run/arr010.stdout b/testsuite/tests/array/should_run/arr010.stdout new file mode 100644 index 0000000000..cc8297ea19 --- /dev/null +++ b/testsuite/tests/array/should_run/arr010.stdout @@ -0,0 +1 @@ +array (0,10) [(0,0),(1,2),(2,2),(3,2),(4,2),(5,2),(6,2),(7,2),(8,2),(9,2),(10,2)] diff --git a/testsuite/tests/array/should_run/arr011.hs b/testsuite/tests/array/should_run/arr011.hs new file mode 100644 index 0000000000..1516b0e866 --- /dev/null +++ b/testsuite/tests/array/should_run/arr011.hs @@ -0,0 +1,20 @@ +-- !!! Array - array difference operator +-- +-- +module Main(main) where + +import Data.Array +import Data.Ix + +hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b +hist bnds is = accumArray (+) 0 bnds [(i,1) | i <- is , inRange bnds i] + +main = + let + a1 = hist (0,10) (concat $ take 2 $ repeat [1..20]) + in + print a1 >> + print (a1 // [ (i,0) | i<-[0..10], odd i]) + + + diff --git a/testsuite/tests/array/should_run/arr011.stdout b/testsuite/tests/array/should_run/arr011.stdout new file mode 100644 index 0000000000..9491d9c780 --- /dev/null +++ b/testsuite/tests/array/should_run/arr011.stdout @@ -0,0 +1,2 @@ +array (0,10) [(0,0),(1,2),(2,2),(3,2),(4,2),(5,2),(6,2),(7,2),(8,2),(9,2),(10,2)] +array (0,10) [(0,0),(1,0),(2,2),(3,0),(4,2),(5,0),(6,2),(7,0),(8,2),(9,0),(10,2)] diff --git a/testsuite/tests/array/should_run/arr012.hs b/testsuite/tests/array/should_run/arr012.hs new file mode 100644 index 0000000000..231d625812 --- /dev/null +++ b/testsuite/tests/array/should_run/arr012.hs @@ -0,0 +1,19 @@ +-- !!! Array map operations +-- +-- +module Main(main) where + +import Data.Array +import Data.Char + +main = + let + a1 = array (0,10) (zip [0..10] ['a'..'z']) + in + print a1 >> + print (fmap (toUpper) a1) >> + print (ixmap (3,8) (+1) a1) + + + + diff --git a/testsuite/tests/array/should_run/arr012.stdout b/testsuite/tests/array/should_run/arr012.stdout new file mode 100644 index 0000000000..b8c8fda13a --- /dev/null +++ b/testsuite/tests/array/should_run/arr012.stdout @@ -0,0 +1,3 @@ +array (0,10) [(0,'a'),(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f'),(6,'g'),(7,'h'),(8,'i'),(9,'j'),(10,'k')] +array (0,10) [(0,'A'),(1,'B'),(2,'C'),(3,'D'),(4,'E'),(5,'F'),(6,'G'),(7,'H'),(8,'I'),(9,'J'),(10,'K')] +array (3,8) [(3,'e'),(4,'f'),(5,'g'),(6,'h'),(7,'i'),(8,'j')] diff --git a/testsuite/tests/array/should_run/arr013.hs b/testsuite/tests/array/should_run/arr013.hs new file mode 100644 index 0000000000..f9e63aa5ba --- /dev/null +++ b/testsuite/tests/array/should_run/arr013.hs @@ -0,0 +1,17 @@ +import Data.Ratio -- 1.3 +import Data.Array -- 1.3 +infix 1 =: +(=:) a b = (a,b) + +main = putStr (shows sub_b "\n") + where + sub_b :: Array Int Double + sub_b = ixmap (102, 113) id b + + b :: Array Int Double + b = fmap ( \ r -> fromRational r / pi ) + (ixmap (101,200) (\ i -> toInteger i - 100) a) + + a :: Array Integer (Ratio Integer) + a = array (1,100) ((1 =: 1) : [i =: fromInteger i * a!(i-1) + | i <- [2..100]]) diff --git a/testsuite/tests/array/should_run/arr013.stdout b/testsuite/tests/array/should_run/arr013.stdout new file mode 100644 index 0000000000..4d9bf4f505 --- /dev/null +++ b/testsuite/tests/array/should_run/arr013.stdout @@ -0,0 +1 @@ +array (102,113) [(102,0.6366197723675814),(103,1.909859317102744),(104,7.639437268410976),(105,38.197186342054884),(106,229.1831180523293),(107,1604.281826366305),(108,12834.25461093044),(109,115508.29149837396),(110,1155082.9149837396),(111,1.2705912064821135e7),(112,1.5247094477785364e8),(113,1.9821222821120973e9)] diff --git a/testsuite/tests/array/should_run/arr014.hs b/testsuite/tests/array/should_run/arr014.hs new file mode 100644 index 0000000000..59541c09ff --- /dev/null +++ b/testsuite/tests/array/should_run/arr014.hs @@ -0,0 +1,26 @@ +-- !!! multi-dimensional arrays + +module Main ( main ) where +import Control.Monad.ST +import Data.Array.ST + +type TwoD s = STArray s Int (STArray s Int Int) + +setup :: ST s (TwoD s) +setup = let isz = 10 + imax = isz - 1 + osz = 2 + omax = osz - 1 in + do + -- gives : undefined reference to `IOBase_error_closure' +-- x <- newArray (0, omax) (error "uninitialised") + dmy <- newArray (0, imax) 0 + x <- newArray (0, omax) dmy + as <- (sequence . replicate osz) (newArray (0, imax) 6) + mapM_ (\(i,v) -> writeArray x i v) (zip [0..omax] as) + return x + +main :: IO () +main = do + a <- stToIO setup + return () diff --git a/testsuite/tests/array/should_run/arr014.stdout b/testsuite/tests/array/should_run/arr014.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/array/should_run/arr014.stdout diff --git a/testsuite/tests/array/should_run/arr015.hs b/testsuite/tests/array/should_run/arr015.hs new file mode 100644 index 0000000000..4a6e8c431a --- /dev/null +++ b/testsuite/tests/array/should_run/arr015.hs @@ -0,0 +1,50 @@ +-- !!! Array test +-- This one fails in Hugs (Feb 2001) + +module Main where + +import Data.Array + +-- All in main is only to show the strange behaviour. +-- +-- arrS is the array that foo (NB (1.0,1)) shows in Hugs. +-- But (foo (NB (1.0,1)))==arrS is False. + +-- If I write NB (f,p) -> hCMt [(p,listArray ((1,1),(1,1)) [f])] instead of line 16 +-- the bug disappears. That is also the reason why I have to keep the data declaration RD. +-- If I put the type signature of line 18 in scope the bug also disappears. +-- If I write hCMt po_arL = (accumArray (\a _-> a) ZM ((1,1),(1,2)) []) // +-- (map (\(po,ar) -> ((1,po),M ar)) po_arL) +-- instead of line 19 and 20 it also vanishes. + +data CM a = ZM | M (Array (Int,Int) a) deriving (Show,Eq) + +data RD = NB !(Double,Int) + +main = do + let arr = foo (NB (1.0,1)) + -- arr = { (1,1) -> M { (1,1) -> 1.0 }, (1,2) -> ZM } + + -- All these should return True + putStr ("arr==arrS "++show (arr==arrS)++"\n") + putStr ("arrS==arr "++show (arrS==arr)++"\n") + putStr ("bnds arr arrS "++show ((bounds arr)==(bounds arrS))++"\n") + putStr ("bnds +id arr arrS "++show (((bounds.id) arr)==((bounds) arrS))++"\n") + putStr ("id +bnds arr arrS "++show (((id.bounds) arr)==((bounds) arrS))++"\n") + + +foo :: RD -> Array (Int,Int) (CM Double) +foo rd = case rd of + NB (f,p) -> h where h = hCMt [(p,listArray ((1,1),(1,1)) [f])] + -- h = { (1,p) -> M { (1,1) -> f }, other -> ZM } + where + --h0CMt :: Array (Int, Int) (CM Double) + -- h0CMt = { (1,1) -> ZM, (1,2) -> ZM } + h0CMt = accumArray (\a _-> a) ZM ((1,1),(1,2)) [] + + hCMt prs = h0CMt // (map (\(po,ar) -> ((1,po),M ar)) prs) + -- [ (1,p), M { (1,1) -> f } ] + + +arrS :: Array (Int,Int) (CM Double) +arrS = listArray ((1,1),(1,2)) [M (listArray ((1,1),(1,1)) [1.0]),ZM] diff --git a/testsuite/tests/array/should_run/arr015.stdout b/testsuite/tests/array/should_run/arr015.stdout new file mode 100644 index 0000000000..be8c55085c --- /dev/null +++ b/testsuite/tests/array/should_run/arr015.stdout @@ -0,0 +1,5 @@ +arr==arrS True +arrS==arr True +bnds arr arrS True +bnds +id arr arrS True +id +bnds arr arrS True diff --git a/testsuite/tests/array/should_run/arr016.hs b/testsuite/tests/array/should_run/arr016.hs new file mode 100644 index 0000000000..055e6602be --- /dev/null +++ b/testsuite/tests/array/should_run/arr016.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE ScopedTypeVariables, DatatypeContexts #-} + +module Main where + +{- + - This is a test framework for Arrays, using QuickCheck + - + -} + +import qualified Data.Array as Array +import Data.List +import Control.Monad ( liftM2, liftM3, liftM4 ) +import System.Random + + +import Data.Ix +import Data.List( (\\) ) + +infixl 9 !, // +infixr 0 ==> +infix 1 `classify` + +prop_array = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + Array.array b vs + `same_arr` + array b vs +prop_listArray = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (vector (length [fst b..snd b])) + $ \ (vs :: [Bool]) -> + Array.listArray b vs == Array.array b (zipWith (\ a b -> (a,b)) + (Array.range b) vs) + +prop_indices = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + let arr = Array.array b vs + in Array.indices arr == ((Array.range . Array.bounds) arr) + +prop_elems = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + let arr = Array.array b vs + in Array.elems arr == [arr Array.! i | i <- Array.indices arr] + +prop_assocs = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + let arr = Array.array b vs + in Array.assocs arr == [(i, arr Array.! i) | i <- Array.indices arr] + +prop_slashslash = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + let arr = Array.array b vs + us = [] + in arr Array.// us == Array.array (Array.bounds arr) + ([(i,arr Array.! i) + | i <- Array.indices arr \\ [i | (i,_) <- us]] + ++ us) +prop_accum = + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + + forAll (genIVPs b 10) $ \ (us :: [(Int,Int)]) -> + forAll (choose (0,length us)) + $ \ n -> + let us' = take n us in + forAll arbitrary $ \ (fn :: Int -> Int -> Int) -> + let arr = Array.array b vs + in Array.accum fn arr us' + == foldl (\a (i,v) -> a Array.// [(i,fn (a Array.! i) v)]) arr us' + +prop_accumArray = + forAll arbitrary $ \ (f :: Int -> Int -> Int) -> + forAll arbitrary $ \ (z :: Int) -> + forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) -> + Array.accumArray f z b vs == Array.accum f + (Array.array b [(i,z) | i <- Array.range b]) vs + + +same_arr :: (Eq b) => Array.Array Int b -> Array Int b -> Bool +same_arr a1 a2 = a == c && b == d + && all (\ n -> (a1 Array.! n) == (a2 ! n)) [a..b] + where (a,b) = Array.bounds a1 :: (Int,Int) + (c,d) = bounds a2 :: (Int,Int) + +genBounds :: Gen (Int,Int) +genBounds = do m <- choose (0,20) + n <- choose (minBound,maxBound-m) + return (n,n+m-1) + +genIVP :: Arbitrary a => (Int,Int) -> Gen (Int,a) +genIVP b = do { i <- choose b + ; v <- arbitrary + ; return (i,v) + } + +genIVPs :: Arbitrary a => (Int,Int) -> Int -> Gen [(Int,a)] +genIVPs b@(low,high) s + = do { let is = [low..high] + ; vs <- vector (length is) + ; shuffle s (zip is vs) + } + +prop_id = forAll genBounds $ \ (b :: (Int,Int)) -> + forAll (genIVPs b 10) $ \ (ivps :: [(Int,Int)]) -> + label (show (ivps :: [(Int,Int)])) True + +-- rift takes a list, split it (using an Int argument), +-- and then rifts together the split lists into one. +-- Think: rifting a pack of cards. +rift :: Int -> [a] -> [a] +rift n xs = comb (drop n xs) (take n xs) + where + comb (a:as) (b:bs) = a : b : comb as bs + comb (a:as) [] = a : as + comb [] (b:bs) = b : bs + comb [] [] = [] + + +-- suffle makes n random rifts. Typically after +-- log n rifts, the list is in a pretty random order. +-- (where n is the number of elements in the list) + +shuffle :: Int -> [a] -> Gen [a] +shuffle 0 m = return m +shuffle n m = do { r <- choose (1,length m) + ; shuffle (n-1) (rift r m) + } +prop_shuffle = + forAll (shuffle 10 [1..10::Int]) $ \ lst -> + label (show lst) True + +------------------------------------------------------------------------------ + +main = do test prop_array + test prop_listArray + test prop_indices + test prop_elems + test prop_assocs + test prop_slashslash + test prop_accum + test prop_accumArray + + +instance Show (a -> b) where { show _ = "<FN>" } + +------------------------------------------------------------------------------ + +data (Ix a) => Array a b = MkArray (a,a) (a -> b) deriving () + +array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b +array b ivs = + if and [inRange b i | (i,_) <- ivs] + then MkArray b + (\j -> case [v | (i,v) <- ivs, i == j] of + [v] -> v + [] -> error "Array.!: \ + \undefined array element" + _ -> error "Array.!: \ + \multiply defined array element") + else error "Array.array: out-of-range array association" + +listArray :: (Ix a) => (a,a) -> [b] -> Array a b +listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs) + +(!) :: (Ix a) => Array a b -> a -> b +(!) (MkArray _ f) = f + +bounds :: (Ix a) => Array a b -> (a,a) +bounds (MkArray b _) = b + +indices :: (Ix a) => Array a b -> [a] +indices = range . bounds + +elems :: (Ix a) => Array a b -> [b] +elems a = [a!i | i <- indices a] + +assocs :: (Ix a) => Array a b -> [(a,b)] +assocs a = [(i, a!i) | i <- indices a] + +(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b +a // us = array (bounds a) + ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]] + ++ us) + +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] + -> Array a b +accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)]) + +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] + -> Array a b +accumArray f z b = accum f (array b [(i,z) | i <- range b]) + +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c + -> Array a c +ixmap b f a = array b [(i, a ! f i) | i <- range b] + +instance (Ix a) => Functor (Array a) where + fmap fn (MkArray b f) = MkArray b (fn . f) + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) +-------------------------------------------------------------------- + +-- QuickCheck v.0.2 +-- DRAFT implementation; last update 000104. +-- Koen Claessen, John Hughes. +-- This file represents work in progress, and might change at a later date. + + +-------------------------------------------------------------------- +-- Generator + +newtype Gen a + = Gen (Int -> StdGen -> a) + +sized :: (Int -> Gen a) -> Gen a +sized fgen = Gen (\n r -> let Gen m = fgen n in m n r) + +resize :: Int -> Gen a -> Gen a +resize n (Gen m) = Gen (\_ r -> m n r) + +rand :: Gen StdGen +rand = Gen (\n r -> r) + +promote :: (a -> Gen b) -> Gen (a -> b) +promote f = Gen (\n r -> \a -> let Gen m = f a in m n r) + +variant :: Int -> Gen a -> Gen a +variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1))) + where + rands r0 = r1 : rands r2 where (r1, r2) = split r0 + +generate :: Int -> StdGen -> Gen a -> a +generate n rnd (Gen m) = m size rnd' + where + (size, rnd') = randomR (0, n) rnd + +instance Functor Gen where + fmap f m = m >>= return . f + +instance Monad Gen where + return a = Gen (\n r -> a) + Gen m >>= k = + Gen (\n r0 -> let (r1,r2) = split r0 + Gen m' = k (m n r1) + in m' n r2) + +-- derived + +--choose :: Random a => (a, a) -> Gen a +choose bounds = ((fst . randomR bounds) `fmap` rand) + +elements :: [a] -> Gen a +elements xs = (xs !!) `fmap` choose (0, length xs - 1) + +vector :: Arbitrary a => Int -> Gen [a] +vector n = sequence [ arbitrary | i <- [1..n] ] + +oneof :: [Gen a] -> Gen a +oneof gens = elements gens >>= id + +frequency :: [(Int, Gen a)] -> Gen a +frequency xs = choose (1, tot) >>= (`pick` xs) + where + tot = sum (map fst xs) + + pick n ((k,x):xs) + | n <= k = x + | otherwise = pick (n-k) xs + +-- general monadic + +two :: Monad m => m a -> m (a, a) +two m = liftM2 (,) m m + +three :: Monad m => m a -> m (a, a, a) +three m = liftM3 (,,) m m m + +four :: Monad m => m a -> m (a, a, a, a) +four m = liftM4 (,,,) m m m m + +-------------------------------------------------------------------- +-- Arbitrary + +class Arbitrary a where + arbitrary :: Gen a + coarbitrary :: a -> Gen b -> Gen b + +instance Arbitrary () where + arbitrary = return () + coarbitrary _ = variant 0 + +instance Arbitrary Bool where + arbitrary = elements [True, False] + coarbitrary b = if b then variant 0 else variant 1 + +instance Arbitrary Int where + arbitrary = sized $ \n -> choose (-n,n) + coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1) + +instance Arbitrary Integer where + arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n) + coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1)) + +instance Arbitrary Float where + arbitrary = liftM3 fraction arbitrary arbitrary arbitrary + coarbitrary x = coarbitrary (decodeFloat x) + +instance Arbitrary Double where + arbitrary = liftM3 fraction arbitrary arbitrary arbitrary + coarbitrary x = coarbitrary (decodeFloat x) + +fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1)) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where + arbitrary = liftM2 (,) arbitrary arbitrary + coarbitrary (a, b) = coarbitrary a . coarbitrary b + +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where + arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary + coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => Arbitrary (a, b, c, d) + where + arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d + +instance Arbitrary a => Arbitrary [a] where + arbitrary = sized (\n -> choose (0,n) >>= vector) + coarbitrary [] = variant 0 + coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where + arbitrary = promote (`coarbitrary` arbitrary) + coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f) + +-------------------------------------------------------------------- +-- Testable + +data Result + = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] } + +nothing :: Result +nothing = Result{ ok = Nothing, stamp = [], arguments = [] } + +newtype Property + = Prop (Gen Result) + +result :: Result -> Property +result res = Prop (return res) + +evaluate :: Testable a => a -> Gen Result +evaluate a = gen where Prop gen = property a + +class Testable a where + property :: a -> Property + +instance Testable () where + property _ = result nothing + +instance Testable Bool where + property b = result (nothing{ ok = Just b }) + +instance Testable Result where + property res = result res + +instance Testable Property where + property prop = prop + +instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where + property f = forAll arbitrary f + +forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property +forAll gen body = Prop $ + do a <- gen + res <- evaluate (body a) + return (argument a res) + where + argument a res = res{ arguments = show a : arguments res } + +(==>) :: Testable a => Bool -> a -> Property +True ==> a = property a +False ==> a = property () + +label :: Testable a => String -> a -> Property +label s a = Prop (add `fmap` evaluate a) + where + add res = res{ stamp = s : stamp res } + +classify :: Testable a => Bool -> String -> a -> Property +classify True name = label name +classify False _ = property + +trivial :: Testable a => Bool -> a -> Property +trivial = (`classify` "trivial") + +collect :: (Show a, Testable b) => a -> b -> Property +collect v = label (show v) + +-------------------------------------------------------------------- +-- Testing + +data Config = Config + { configMaxTest :: Int + , configMaxFail :: Int + , configSize :: Int -> Int + , configEvery :: Int -> [String] -> String + } + +quick :: Config +quick = Config + { configMaxTest = 100 + , configMaxFail = 1000 + , configSize = (+ 3) . (`div` 2) + , configEvery = \n args -> let s = show n in s ++ "," + } + +verbose :: Config +verbose = quick + { configEvery = \n args -> show n ++ ":\n" ++ unlines args + } + +test, quickCheck, verboseCheck :: Testable a => a -> IO () +test = check quick +quickCheck = check quick +verboseCheck = check verbose + +check :: Testable a => Config -> a -> IO () +check config a = + do rnd <- newStdGen + tests config (evaluate a) rnd 0 0 [] + +tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +tests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK, passed" ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = + do putStr (configEvery config ntest (arguments result)) + case ok result of + Nothing -> + tests config gen rnd1 ntest (nfail+1) stamps + Just True -> + tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + putStr ( "Falsifiable, after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = + do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +-------------------------------------------------------------------- +-- the end. + +{- +instance Observable StdGen where { observer = observeBase } + +instance Observable a => Observable (Gen a) where + observer (Gen a) = send "Gen" (return (Gen) << a) + +-}
\ No newline at end of file diff --git a/testsuite/tests/array/should_run/arr016.stdout b/testsuite/tests/array/should_run/arr016.stdout new file mode 100644 index 0000000000..1e7413dfb1 --- /dev/null +++ b/testsuite/tests/array/should_run/arr016.stdout @@ -0,0 +1,8 @@ +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,OK, passed 100 tests. diff --git a/testsuite/tests/array/should_run/arr017.hs b/testsuite/tests/array/should_run/arr017.hs new file mode 100644 index 0000000000..18314b8e28 --- /dev/null +++ b/testsuite/tests/array/should_run/arr017.hs @@ -0,0 +1,30 @@ +-- Caused a crash in GHC 6.4 when optimising, due to inlining of runST too early. + +-- Spectral Norm benchmark + +import Data.Array +import System.Environment (getArgs) + +main = do + --[arg] <- getArgs + --let n = (read arg) - 1 + let n = 80 + let init = listArray (0,n) (repeat 1.0) + let (v:u:rest) = drop 19 $ iterate (eval_AtA_times_u n) init + let vBv = sum [(u!i)*(v!i) |i<-[0..n]] + let vv = sum [(v!i)*(v!i) |i<-[0..n]] + print $ sqrt (vBv/vv) + +eval_AtA_times_u n u = eval_At_times_u n v + where v = eval_A_times_u n u + +eval_A x y = 1.0/((i+j)*(i+j+1)/2+i+1) + where i = fromIntegral x + j = fromIntegral y + +eval_A_times_u n u = accumArray (+) 0 (0,n) + [(i,(eval_A i j) * u!j)|i<-[0..n], j<-[0..n]] + +eval_At_times_u n u = accumArray (+) 0 (0,n) + [(i,(eval_A j i) * u!j)|i<-[0..n], j<-[0..n]] + diff --git a/testsuite/tests/array/should_run/arr017.stdout b/testsuite/tests/array/should_run/arr017.stdout new file mode 100644 index 0000000000..12e7cb0720 --- /dev/null +++ b/testsuite/tests/array/should_run/arr017.stdout @@ -0,0 +1 @@ +1.2742165080678525 diff --git a/testsuite/tests/array/should_run/arr018.hs b/testsuite/tests/array/should_run/arr018.hs new file mode 100644 index 0000000000..27896aae39 --- /dev/null +++ b/testsuite/tests/array/should_run/arr018.hs @@ -0,0 +1,16 @@ +-- test for #1131 +import Control.Monad.ST +import Data.Array.ST +import Data.Array +import System.Mem + +tickle :: Int +tickle = runST (do { + x <- newArray_ (0,100) ; + (readArray :: STUArray s Int Int -> Int -> ST s Int) x 3 + }) + +main :: IO () +main = do print $ length (replicate 100000 'a') + performGC + print tickle diff --git a/testsuite/tests/array/should_run/arr018.stdout b/testsuite/tests/array/should_run/arr018.stdout new file mode 100644 index 0000000000..08ca4fc84f --- /dev/null +++ b/testsuite/tests/array/should_run/arr018.stdout @@ -0,0 +1,2 @@ +100000 +0 diff --git a/testsuite/tests/array/should_run/arr019.hs b/testsuite/tests/array/should_run/arr019.hs new file mode 100644 index 0000000000..9992dd2315 --- /dev/null +++ b/testsuite/tests/array/should_run/arr019.hs @@ -0,0 +1,27 @@ + +-- Test for trac #2158 + +import Data.Array + +data Pos = Pos Integer Integer + deriving (Show, Eq, Ord, Ix) + +myBounds :: (Pos, Pos) +myBounds = (Pos 0 0, Pos 2 3) + +main :: IO () +main = do print $ range myBounds + print $ index myBounds (Pos 0 0) + print $ index myBounds (Pos 0 1) + print $ index myBounds (Pos 0 2) + print $ index myBounds (Pos 0 3) + print $ index myBounds (Pos 1 0) + print $ index myBounds (Pos 1 1) + print $ index myBounds (Pos 1 2) + print $ index myBounds (Pos 1 3) + print $ index myBounds (Pos 2 0) + print $ index myBounds (Pos 2 1) + print $ index myBounds (Pos 2 2) + print $ index myBounds (Pos 2 3) + print $ listArray myBounds [(123 :: Integer) ..] + diff --git a/testsuite/tests/array/should_run/arr019.stdout b/testsuite/tests/array/should_run/arr019.stdout new file mode 100644 index 0000000000..f99db4ec8d --- /dev/null +++ b/testsuite/tests/array/should_run/arr019.stdout @@ -0,0 +1,14 @@ +[Pos 0 0,Pos 0 1,Pos 0 2,Pos 0 3,Pos 1 0,Pos 1 1,Pos 1 2,Pos 1 3,Pos 2 0,Pos 2 1,Pos 2 2,Pos 2 3] +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +array (Pos 0 0,Pos 2 3) [(Pos 0 0,123),(Pos 0 1,124),(Pos 0 2,125),(Pos 0 3,126),(Pos 1 0,127),(Pos 1 1,128),(Pos 1 2,129),(Pos 1 3,130),(Pos 2 0,131),(Pos 2 1,132),(Pos 2 2,133),(Pos 2 3,134)] |