/usr/share/doc/libghc-chasingbottoms-doc/html/src/Test-ChasingBottoms-IsBottom.html is in libghc-chasingbottoms-doc 1.3.1.3-1build1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->
<title>Test/ChasingBottoms/IsBottom.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE ScopedTypeVariables #-}</span>
<a name="line-2"></a><span class='hs-comment'>-- The following (possibly unnecessary) options are included due to</span>
<a name="line-3"></a><span class='hs-comment'>-- the use of unsafePerformIO below.</span>
<a name="line-4"></a><span class='hs-comment'>{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}</span>
<a name="line-5"></a>
<a name="line-6"></a><span class='hs-comment'>-- |</span>
<a name="line-7"></a><span class='hs-comment'>-- Module : Test.ChasingBottoms.IsBottom</span>
<a name="line-8"></a><span class='hs-comment'>-- Copyright : (c) Nils Anders Danielsson 2004-2017</span>
<a name="line-9"></a><span class='hs-comment'>-- License : See the file LICENCE.</span>
<a name="line-10"></a><span class='hs-comment'>--</span>
<a name="line-11"></a><span class='hs-comment'>-- Maintainer : <a href="http://www.cse.chalmers.se/~nad/">http://www.cse.chalmers.se/~nad/</a></span>
<a name="line-12"></a><span class='hs-comment'>-- Stability : experimental</span>
<a name="line-13"></a><span class='hs-comment'>-- Portability : non-portable (exceptions)</span>
<a name="line-14"></a><span class='hs-comment'>--</span>
<a name="line-15"></a>
<a name="line-16"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>Test</span><span class='hs-varop'>.</span><span class='hs-conid'>ChasingBottoms</span><span class='hs-varop'>.</span><span class='hs-conid'>IsBottom</span>
<a name="line-17"></a> <span class='hs-layout'>(</span> <span class='hs-varid'>isBottom</span>
<a name="line-18"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>isBottomIO</span>
<a name="line-19"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>bottom</span>
<a name="line-20"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>nonBottomError</span>
<a name="line-21"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>isBottomTimeOut</span>
<a name="line-22"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>isBottomTimeOutIO</span>
<a name="line-23"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Prelude</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>catch</span><span class='hs-layout'>)</span>
<a name="line-26"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>E</span>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>System</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Unsafe</span> <span class='hs-layout'>(</span><span class='hs-varid'>unsafePerformIO</span><span class='hs-layout'>)</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Test</span><span class='hs-varop'>.</span><span class='hs-conid'>ChasingBottoms</span><span class='hs-varop'>.</span><span class='hs-conid'>TimeOut</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>T</span>
<a name="line-29"></a>
<a name="line-30"></a><span class='hs-comment'>-- | @'isBottom' a@ returns 'False' if @a@ is distinct from bottom. If</span>
<a name="line-31"></a><span class='hs-comment'>-- @a@ equals bottom and results in an exception of a certain kind</span>
<a name="line-32"></a><span class='hs-comment'>-- (see below), then @'isBottom' a = 'True'@. If @a@ never reaches a</span>
<a name="line-33"></a><span class='hs-comment'>-- weak head normal form and never throws one of these exceptions,</span>
<a name="line-34"></a><span class='hs-comment'>-- then @'isBottom' a@ never terminates.</span>
<a name="line-35"></a><span class='hs-comment'>--</span>
<a name="line-36"></a><span class='hs-comment'>-- The exceptions that yield 'True' correspond to \"pure bottoms\",</span>
<a name="line-37"></a><span class='hs-comment'>-- i.e. bottoms that can originate in pure code:</span>
<a name="line-38"></a><span class='hs-comment'>--</span>
<a name="line-39"></a><span class='hs-comment'>-- * 'E.ArrayException'</span>
<a name="line-40"></a><span class='hs-comment'>--</span>
<a name="line-41"></a><span class='hs-comment'>-- * 'E.ErrorCall'</span>
<a name="line-42"></a><span class='hs-comment'>--</span>
<a name="line-43"></a><span class='hs-comment'>-- * 'E.NoMethodError'</span>
<a name="line-44"></a><span class='hs-comment'>--</span>
<a name="line-45"></a><span class='hs-comment'>-- * 'E.NonTermination'</span>
<a name="line-46"></a><span class='hs-comment'>--</span>
<a name="line-47"></a><span class='hs-comment'>-- * 'E.PatternMatchFail'</span>
<a name="line-48"></a><span class='hs-comment'>--</span>
<a name="line-49"></a><span class='hs-comment'>-- * 'E.RecConError'</span>
<a name="line-50"></a><span class='hs-comment'>--</span>
<a name="line-51"></a><span class='hs-comment'>-- * 'E.RecSelError'</span>
<a name="line-52"></a><span class='hs-comment'>--</span>
<a name="line-53"></a><span class='hs-comment'>-- * 'E.RecUpdError'</span>
<a name="line-54"></a><span class='hs-comment'>--</span>
<a name="line-55"></a><span class='hs-comment'>-- Assertions are excluded, because their behaviour depends on</span>
<a name="line-56"></a><span class='hs-comment'>-- compiler flags (not pure, and a failed assertion should really</span>
<a name="line-57"></a><span class='hs-comment'>-- yield an exception and nothing else). The same applies to</span>
<a name="line-58"></a><span class='hs-comment'>-- arithmetic exceptions (machine dependent, except possibly for</span>
<a name="line-59"></a><span class='hs-comment'>-- 'E.DivideByZero', but the value infinity makes that case unclear as</span>
<a name="line-60"></a><span class='hs-comment'>-- well).</span>
<a name="line-61"></a>
<a name="line-62"></a><span class='hs-comment'>-- Should we use throw or throwIO below?</span>
<a name="line-63"></a><span class='hs-comment'>-- It doesn't seem to matter, and I don't think it matters, but</span>
<a name="line-64"></a><span class='hs-comment'>-- using throw won't give us any problems.</span>
<a name="line-65"></a>
<a name="line-66"></a><span class='hs-comment'>-- Check out a discussion about evaluate around</span>
<a name="line-67"></a><span class='hs-comment'>-- <a href="http://www.haskell.org/pipermail/glasgow-haskell-users/2002-May/003393.html.">http://www.haskell.org/pipermail/glasgow-haskell-users/2002-May/003393.html.</a></span>
<a name="line-68"></a>
<a name="line-69"></a><span class='hs-comment'>-- From the docs:</span>
<a name="line-70"></a><span class='hs-comment'>-- evaluate undefined `seq` return () ==> return ()</span>
<a name="line-71"></a><span class='hs-comment'>-- catch (evaluate undefined) (\e -> return ()) ==> return ()</span>
<a name="line-72"></a>
<a name="line-73"></a><a name="isBottom"></a><span class='hs-definition'>isBottom</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-74"></a><span class='hs-definition'>isBottom</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isBottomTimeOut</span> <span class='hs-conid'>Nothing</span>
<a name="line-75"></a>
<a name="line-76"></a><a name="bottom"></a><span class='hs-comment'>-- | 'bottom' generates a bottom that is suitable for testing using</span>
<a name="line-77"></a><span class='hs-comment'>-- 'isBottom'.</span>
<a name="line-78"></a><span class='hs-definition'>bottom</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span>
<a name="line-79"></a><span class='hs-definition'>bottom</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>error</span> <span class='hs-str'>"_|_"</span>
<a name="line-80"></a>
<a name="line-81"></a><span class='hs-comment'>-- | @'nonBottomError' s@ raises an exception ('E.AssertionFailed')</span>
<a name="line-82"></a><span class='hs-comment'>-- that is not caught by 'isBottom'. Use @s@ to describe the</span>
<a name="line-83"></a><span class='hs-comment'>-- exception.</span>
<a name="line-84"></a>
<a name="line-85"></a><a name="nonBottomError"></a><span class='hs-definition'>nonBottomError</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span>
<a name="line-86"></a><span class='hs-definition'>nonBottomError</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>throw</span> <span class='hs-varop'>.</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>AssertionFailed</span>
<a name="line-87"></a>
<a name="line-88"></a><span class='hs-comment'>-- | @'isBottomTimeOut' timeOutLimit@ works like 'isBottom', but if</span>
<a name="line-89"></a><span class='hs-comment'>-- @timeOutLimit@ is @'Just' lim@, then computations taking more than</span>
<a name="line-90"></a><span class='hs-comment'>-- @lim@ seconds are also considered to be equal to bottom. Note that</span>
<a name="line-91"></a><span class='hs-comment'>-- this is a very crude approximation of what a bottom is. Also note</span>
<a name="line-92"></a><span class='hs-comment'>-- that this \"function\" may return different answers upon different</span>
<a name="line-93"></a><span class='hs-comment'>-- invocations. Take it for what it is worth.</span>
<a name="line-94"></a><span class='hs-comment'>--</span>
<a name="line-95"></a><span class='hs-comment'>-- 'isBottomTimeOut' is subject to all the same vagaries as</span>
<a name="line-96"></a><span class='hs-comment'>-- 'T.timeOut'.</span>
<a name="line-97"></a>
<a name="line-98"></a><a name="isBottomTimeOut"></a><span class='hs-comment'>-- The following pragma is included due to the use of unsafePerformIO</span>
<a name="line-99"></a><span class='hs-comment'>-- below.</span>
<a name="line-100"></a><span class='hs-comment'>{-# NOINLINE isBottomTimeOut #-}</span>
<a name="line-101"></a><span class='hs-definition'>isBottomTimeOut</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-102"></a><span class='hs-definition'>isBottomTimeOut</span> <span class='hs-varid'>timeOutLimit</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span>
<a name="line-103"></a> <span class='hs-varid'>unsafePerformIO</span> <span class='hs-varop'>$</span> <span class='hs-varid'>isBottomTimeOutIO</span> <span class='hs-varid'>timeOutLimit</span> <span class='hs-varid'>f</span>
<a name="line-104"></a>
<a name="line-105"></a><span class='hs-comment'>-- | A variant of 'isBottom' that lives in the 'IO' monad.</span>
<a name="line-106"></a>
<a name="line-107"></a><a name="isBottomIO"></a><span class='hs-definition'>isBottomIO</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Bool</span>
<a name="line-108"></a><span class='hs-definition'>isBottomIO</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isBottomTimeOutIO</span> <span class='hs-conid'>Nothing</span>
<a name="line-109"></a>
<a name="line-110"></a><span class='hs-comment'>-- | A variant of 'isBottomTimeOut' that lives in the 'IO' monad.</span>
<a name="line-111"></a>
<a name="line-112"></a><a name="isBottomTimeOutIO"></a><span class='hs-definition'>isBottomTimeOutIO</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Bool</span>
<a name="line-113"></a><span class='hs-definition'>isBottomTimeOutIO</span> <span class='hs-varid'>timeOutLimit</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span>
<a name="line-114"></a> <span class='hs-varid'>maybeTimeOut</span> <span class='hs-layout'>(</span><span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>evaluate</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span> <span class='hs-varop'>`</span><span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>catches</span><span class='hs-varop'>`</span>
<a name="line-115"></a> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>ArrayException</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-116"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>ErrorCall</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-117"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>NoMethodError</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-118"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>NonTermination</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-119"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>PatternMatchFail</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-120"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>RecConError</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-121"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>RecSelError</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-122"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>Handler</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-conid'>RecUpdError</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-123"></a> <span class='hs-keyglyph'>]</span>
<a name="line-124"></a> <span class='hs-keyword'>where</span>
<a name="line-125"></a> <span class='hs-varid'>maybeTimeOut</span> <span class='hs-varid'>io</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>timeOutLimit</span> <span class='hs-keyword'>of</span>
<a name="line-126"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-127"></a> <span class='hs-varid'>io</span>
<a name="line-128"></a> <span class='hs-varid'>return</span> <span class='hs-conid'>False</span>
<a name="line-129"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>lim</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-130"></a> <span class='hs-varid'>result</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>T</span><span class='hs-varop'>.</span><span class='hs-varid'>timeOut</span> <span class='hs-varid'>lim</span> <span class='hs-varid'>io</span>
<a name="line-131"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>result</span> <span class='hs-keyword'>of</span> <span class='hs-comment'>-- Note that evaluate bottom /= bottom.</span>
<a name="line-132"></a> <span class='hs-conid'>T</span><span class='hs-varop'>.</span><span class='hs-conid'>Value</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>False</span>
<a name="line-133"></a> <span class='hs-conid'>T</span><span class='hs-varop'>.</span><span class='hs-conid'>NonTermination</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>True</span>
<a name="line-134"></a> <span class='hs-conid'>T</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>throw</span> <span class='hs-varid'>e</span> <span class='hs-comment'>-- Catch the exception above.</span>
</pre></body>
</html>
|