diff options
28 files changed, 779 insertions, 779 deletions
diff --git a/testsuite/tests/boxy/PList1.hs b/testsuite/tests/boxy/PList1.hs index 80fac96d9f..6869d904cc 100644 --- a/testsuite/tests/boxy/PList1.hs +++ b/testsuite/tests/boxy/PList1.hs @@ -1,26 +1,26 @@ {-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags #-} -module PList1 where --- Polymorphic lists 1: requires smart-app-res +module PList1 where +-- Polymorphic lists 1: requires smart-app-res type Sid = forall a . a -> a -ids :: [Sid] -ids = [] +ids :: [Sid] +ids = [] --- requires smart-app-res -test0 :: [Sid] -test0 = (\x->x) : ids +-- requires smart-app-res +test0 :: [Sid] +test0 = (\x->x) : ids -test1 :: [Sid] -- SLPJ added -test1 = ids ++ test0 +test1 :: [Sid] -- SLPJ added +test1 = ids ++ test0 -test2 :: [Sid] -test2 = tail test1 +test2 :: [Sid] +test2 = tail test1 -test3 :: [Sid] -- SLPJ added -test3 = reverse test2 -test4 = (tail::([Sid]->[Sid])) test2 +test3 :: [Sid] -- SLPJ added +test3 = reverse test2 +test4 = (tail::([Sid]->[Sid])) test2 -test5 = (head::([Sid]->Sid)) test2
\ No newline at end of file +test5 = (head::([Sid]->Sid)) test2 diff --git a/testsuite/tests/boxy/PList2.hs b/testsuite/tests/boxy/PList2.hs index 581ce086a9..316e8792ae 100644 --- a/testsuite/tests/boxy/PList2.hs +++ b/testsuite/tests/boxy/PList2.hs @@ -1,27 +1,27 @@ {-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags #-} -module PList2 where +module PList2 where -- Polymorphic lists 2: require smart-app-arg & smart-app-res: Should fail w/o smart-app-arg -type Sid = forall a. a -> a +type Sid = forall a. a -> a -ids :: [Sid] -ids = [] +ids :: [Sid] +ids = [] -test0 :: [Sid] +test0 :: [Sid] test0 = (\x -> x):ids -- requires smart-app-res -test1 :: [Sid] -- Added SLPJ -test1 = ids ++ test0 +test1 :: [Sid] -- Added SLPJ +test1 = ids ++ test0 test2 :: [Sid] -test2 = tail test1 -- requires smart-app-arg +test2 = tail test1 -- requires smart-app-arg -test3 :: [Sid] -- Added SLPJ -test3 = reverse test2 +test3 :: [Sid] -- Added SLPJ +test3 = reverse test2 test4 :: Sid test4 = head ids --requires smart-app-arg test5 :: Sid -test5 = head ids -- still requires smart-app-arg +test5 = head ids -- still requires smart-app-arg diff --git a/testsuite/tests/boxy/boxy.hs b/testsuite/tests/boxy/boxy.hs index 4d2bd029b1..c4835b1c62 100644 --- a/testsuite/tests/boxy/boxy.hs +++ b/testsuite/tests/boxy/boxy.hs @@ -12,14 +12,14 @@ g :: Maybe (forall a. [a] -> a) -> (Int, Char) g Nothing = (0, '0') g (Just get) = (get [1,2], get ['a','b','c']) -sing x = [x] +sing x = [x] id1 :: forall a. a -> a id1 = id {- -ids :: [forall a. a -> a] -ids = [id1,id1] +ids :: [forall a. a -> a] +ids = [id1,id1] t1 :: [forall a. a -> a] t1 = tail ids @@ -41,7 +41,7 @@ qG choose id = choose id qH :: (forall a. a -> a -> a) -> (forall a. a -> a) -> (forall b. b -> b) -> (forall b. b -> b) qH choose id = choose id - + choose :: forall a. a -> a -> a choose x y = x @@ -58,10 +58,10 @@ impred2 = id qF --- all of these currently work in GHC with higher-rank types self1 :: (forall a. a -> a) -> (forall a. a -> a) -self1 f = f f +self1 f = f f self2 :: (forall a. a -> a) -> b -> b -self2 f = f f +self2 f = f f gr1 = self1 id @@ -109,8 +109,8 @@ fixMT :: (MapTree -> MapTree) -> MapTree fixMT f = f (fixMT f) mapTree' = fixMT (\ (mapTree :: MapTree) -> \f tree -> case tree of - Branch a t -> Branch (f a) (mapTree (cross f) t) - Leaf -> Leaf) + Branch a t -> Branch (f a) (mapTree (cross f) t) + Leaf -> Leaf) -- polymorphic fix fix :: (a -> a) -> a @@ -119,6 +119,6 @@ fix f = f (fix f) -- mapTree'' :: MapTree mapTree'' = (fix :: (MapTree -> MapTree) -> MapTree) - (\ mapTree -> \f tree -> case tree of - Branch a t -> Branch (f a) (mapTree (cross f) t) - Leaf -> Leaf) + (\ mapTree -> \f tree -> case tree of + Branch a t -> Branch (f a) (mapTree (cross f) t) + Leaf -> Leaf) diff --git a/testsuite/tests/programs/Queens/queens.hs b/testsuite/tests/programs/Queens/queens.hs index 548e20cb8d..249f37131e 100644 --- a/testsuite/tests/programs/Queens/queens.hs +++ b/testsuite/tests/programs/Queens/queens.hs @@ -8,25 +8,25 @@ main = solutions = queens 8 queens :: Int -> [[Int]] -queens n = valid n n +queens n = valid n n valid :: Int -> Int -> [[Int]] valid 0 n = [[]] -valid m n = filter safe (extend n (valid (m-1) n)) +valid m n = filter safe (extend n (valid (m-1) n)) -extend n b = cp (fromTo 1 n) b +extend n b = cp (fromTo 1 n) b cp :: [a] -> [[a]] -> [[a]] cp [] y = [] -cp (a:x) y = map (a:) y ++ cp x y +cp (a:x) y = map (a:) y ++ cp x y safe (a:b) = no_threat a b 1 no_threat a [] m = True no_threat a (b:y) m = - a /= b && a+m /= b && a-m /= b && no_threat a y (m+1) + a /= b && a+m /= b && a-m /= b && no_threat a y (m+1) -board :: [Int] -> String +board :: [Int] -> String board b = unlines (concat (zipWith rank (from 1) b)) where @@ -34,12 +34,12 @@ board b = map line ["o o o", " \\|/ ", " === "] where line crown_slice = - concat (zipWith square (from 1) b) + concat (zipWith square (from 1) b) where - square scol _ = - if scol == qcol then crown_slice - else if (scol `rem` (2::Int)) == (r `rem` (2::Int)) then "....." - else " " + square scol _ = + if scol == qcol then crown_slice + else if (scol `rem` (2::Int)) == (r `rem` (2::Int)) then "....." + else " " -- in place of .. diff --git a/testsuite/tests/programs/andre_monad/Main.hs b/testsuite/tests/programs/andre_monad/Main.hs index 7e3dda6362..5df32d77b5 100644 --- a/testsuite/tests/programs/andre_monad/Main.hs +++ b/testsuite/tests/programs/andre_monad/Main.hs @@ -6,57 +6,57 @@ -- The count monad -type M a = (a, Int) +type M a = (a, Int) -unit :: a -> M a -unit a = (a, 0) +unit :: a -> M a +unit a = (a, 0) -bind :: M a -> (a -> M b) -> M b -m `bind` k = case m of - (a,i) -> case k a of +bind :: M a -> (a -> M b) -> M b +m `bind` k = case m of + (a,i) -> case k a of (b,j) -> (b,i+j) --- disp :: Text a => M a -> String -disp (a,i) = show a ++ "\nCount: " ++ show i +-- disp :: Text a => M a -> String +disp (a,i) = show a ++ "\nCount: " ++ show i -tick :: M () -tick = ((), 1) +tick :: M () +tick = ((), 1) -- The evaluator -- Lines with * are only change from evalIdent -data Op = Add | Sub | Mul | Quo -data Term = Con Int | Bin Op Term Term +data Op = Add | Sub | Mul | Quo +data Term = Con Int | Bin Op Term Term -eval :: Term -> M Int -eval (Con i) = unit i -eval (Bin op u v) = eval u `bind` (\a -> - eval v `bind` (\b -> - go op a b `bind` (\c -> -- * - tick `bind` (\ () -> -- * - unit c)))) -- * +eval :: Term -> M Int +eval (Con i) = unit i +eval (Bin op u v) = eval u `bind` (\a -> + eval v `bind` (\b -> + go op a b `bind` (\c -> -- * + tick `bind` (\ () -> -- * + unit c)))) -- * -go :: Op -> Int -> Int -> M Int -go Add a b = unit (a+b) -go Sub a b = unit (a-b) -go Mul a b = unit (a*b) -go Quo a b = unit (a `quot` b) -- WDP: was "div" +go :: Op -> Int -> Int -> M Int +go Add a b = unit (a+b) +go Sub a b = unit (a-b) +go Mul a b = unit (a*b) +go Quo a b = unit (a `quot` b) -- WDP: was "div" -test :: Term -> String -test t = disp (eval t) +test :: Term -> String +test t = disp (eval t) -- Test data -add, sub, mul, quo :: Term -> Term -> Term -u `add` v = Bin Add u v -u `sub` v = Bin Sub u v -u `mul` v = Bin Mul u v -u `quo` v = Bin Quo u v +add, sub, mul, quo :: Term -> Term -> Term +u `add` v = Bin Add u v +u `sub` v = Bin Sub u v +u `mul` v = Bin Mul u v +u `quo` v = Bin Quo u v -term0,term1,term2 :: Term -term0 = Con 6 `mul` Con 9 -term1 = (Con 4 `mul` Con 13) `add` Con 2 -term2 = (Con 1 `quo` Con 2) `add` Con 2 +term0,term1,term2 :: Term +term0 = Con 6 `mul` Con 9 +term1 = (Con 4 `mul` Con 13) `add` Con 2 +term2 = (Con 1 `quo` Con 2) `add` Con 2 term3 = (((((((((((((((((((((((((((((((( (((((((((((((((((((((((((((((( Con 7777 `mul` Con 13) `quo` Con 13) diff --git a/testsuite/tests/programs/barton-mangler-bug/Basic.hs b/testsuite/tests/programs/barton-mangler-bug/Basic.hs index 1597a86d2f..f446ff2283 100644 --- a/testsuite/tests/programs/barton-mangler-bug/Basic.hs +++ b/testsuite/tests/programs/barton-mangler-bug/Basic.hs @@ -33,10 +33,10 @@ instance Signal SignalRep where toSig = id instance (Physical a, Physical b) => Eq (a -> b) where a == b = error "Attempt to apply equality to functions" -binop:: (Physical a, Physical b) => (Float -> Float -> Float) -> +binop:: (Physical a, Physical b) => (Float -> Float -> Float) -> (a -> b) -> (a -> b) -> a -> b binop op f g t = toPhysical ((fromPhysical (f t)) `op` (fromPhysical (g t))) -unop:: (Physical a, Physical b ) => (Float -> Float) -> +unop:: (Physical a, Physical b ) => (Float -> Float) -> (a -> b) -> a -> b unop op f t = toPhysical (op (fromPhysical (f t))) instance (Physical a, Physical b) => Num (SignalRep a b) where @@ -47,11 +47,11 @@ instance (Physical a, Physical b) => Num (SignalRep a b) where signum f = FunctionRep (unop abs (mapSignal f)) fromInteger i = FunctionRep (\t -> toPhysical (fromInteger i)) --fromInt i = FunctionRep (\t -> toPhysical (fromInt i)) -instance (Physical a, Physical b) => +instance (Physical a, Physical b) => Fractional (SignalRep a b) where f / g = FunctionRep (binop (/) (mapSignal f) (mapSignal g)) fromRational r = FunctionRep (\t -> (toPhysical (fromRational r))) -instance (Physical a, Physical b) => +instance (Physical a, Physical b) => Floating (SignalRep a b) where pi = FunctionRep (\t -> (toPhysical pi)) exp f = FunctionRep (unop exp (mapSignal f)) @@ -67,7 +67,7 @@ instance (Physical a, Physical b) => acosh f = FunctionRep (unop acosh (mapSignal f)) atanh f = FunctionRep (unop atanh (mapSignal f)) data Event = - TimeEvent Float | + TimeEvent Float | FunctionEvent (Float -> Bool) | BurstEvent Int Event @@ -82,7 +82,7 @@ instance Eq Event where eventOccurs:: Event -> Float -> Float eventOccurs (TimeEvent t) x = if x < t then x else t eventOccurs (FunctionEvent f) x = stepEval f x -eventOccurs (BurstEvent i e) x = +eventOccurs (BurstEvent i e) x = if i == 1 then eventOccurs e x else @@ -90,7 +90,7 @@ eventOccurs (BurstEvent i e) x = stepEval:: (Float -> Bool) -> Float -> Float stepEval f x = if f x then x else stepEval f (x + eventEps x) data ZeroIndicator = LocalZero | GlobalZero deriving (Eq, Show) -data {- (Physical a, Physical b) => -} FunctionWindow a b = +data {- (Physical a, Physical b) => -} FunctionWindow a b = Window ZeroIndicator Event (SignalRep a b) deriving (Eq, Show) data PieceCont a b = Windows [FunctionWindow a b] @@ -100,43 +100,43 @@ instance Signal PieceCont where mapSignal (Windows wl) t = (mapSignal s) (toPhysical t') where (t', (Window z e s), wl') = getWindow 0.0 (fromPhysical t) wl toSig = PieceContRep -getWindow:: (Physical a, Physical b) => - Float -> Float -> [ FunctionWindow a b ] -> +getWindow:: (Physical a, Physical b) => + Float -> Float -> [ FunctionWindow a b ] -> (Float, FunctionWindow a b, [ FunctionWindow a b ]) getWindow st t [] = (t, Window LocalZero e f, []) where e = TimeEvent (realmul 2 t) f = FunctionRep (\t -> toPhysical 0.0) -getWindow st t (w:wl) = if t' <= wt then (t',w,w:wl) +getWindow st t (w:wl) = if t' <= wt then (t',w,w:wl) else getWindow (st+wt) t wl where wt = eventOccurs e t' (Window z e s) = w t' = if z == LocalZero then t-st else t -(|>) :: (Physical a, Physical b) => FunctionWindow a b -> +(|>) :: (Physical a, Physical b) => FunctionWindow a b -> PieceCont a b -> PieceCont a b w |> (Windows wl) = Windows (w:wl) nullWindow = Windows [] -cycleWindows:: (Physical a, Physical b) => +cycleWindows:: (Physical a, Physical b) => PieceCont a b -> PieceCont a b cycleWindows (Windows wl) = Windows (cycle wl) constant:: (Physical a, Physical b) => b -> SignalRep a b constant x = FunctionRep (\t -> x) linear:: (Physical a, Physical b) => Float -> b -> SignalRep a b linear m b = FunctionRep (\x -> toPhysical (realmul m (fromPhysical x) + (fromPhysical b))) -sine:: (Physical a, Physical b) => +sine:: (Physical a, Physical b) => b -> Frequency -> Float -> SignalRep a b sine mag omeg phase = FunctionRep (\x -> toPhysical (realmul (fromPhysical mag) (sin (realmul (realmul (realmul 2 pi) (fromPhysical omeg)) (fromPhysical x) + phase)))) waveform:: (Physical a, Physical b) => a -> [b] -> SignalRep a b waveform samp ampls = let stepSlope y y' = realdiv ((fromPhysical y') - (fromPhysical y)) (fromPhysical samp) - makeWin (v,v') = Window LocalZero (TimeEvent (fromPhysical samp)) + makeWin (v,v') = Window LocalZero (TimeEvent (fromPhysical samp)) (linear (stepSlope v v') v) points = cycle ampls in PieceContRep (Windows (map makeWin (zip points (tail points)))) -random:: (Physical a, Physical b) => +random:: (Physical a, Physical b) => Integer -> a -> SignalRep a b random i s = waveform s (map toPhysical (rand i)) ramp:: (Physical a, Physical b) => a -> b -> SignalRep a b -ramp per v = +ramp per v = let sig = linear (realdiv (fromPhysical v) (fromPhysical per)) (toPhysical 0.0) in PieceContRep (Windows (cycle ([Window LocalZero (TimeEvent (fromPhysical per)) sig ]))) triangle:: (Physical a, Physical b) => a -> b -> SignalRep a b @@ -163,7 +163,7 @@ pulse st wid lvl = f t = if (fromPhysical t) < (fromPhysical st) then (toPhysical 0.0) else if (fromPhysical t) < tr then lvl else (toPhysical 0.0) in FunctionRep f -trap:: (Physical a, Physical b) => a -> a -> a -> a -> b -> +trap:: (Physical a, Physical b) => a -> a -> a -> a -> b -> SignalRep a b trap st r wid f lvl = let stepSlope y y' t = realdiv (y' - y) (fromPhysical t) @@ -226,7 +226,7 @@ pulse_ac = Pulse_ac {dc_offset = toPhysical 0.0, amplitude = toPhysical 0.0} -} -makeWin:: (Physical a, Physical b) => a -> a -> +makeWin:: (Physical a, Physical b) => a -> a -> SignalRep a b -> SignalRep a b makeWin st wid sig = let wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |> @@ -238,7 +238,7 @@ instance Signal BasicSignal where let ring = sine ringing oscillation 0.0 cond = asTypeOf (expc damp_fac) ring sig = temp ring cond - temp:: (Physical a, Physical b) => SignalRep a b -> + temp:: (Physical a, Physical b) => SignalRep a b -> SignalRep a b -> SignalRep a b temp f g = FunctionRep (binop (*) (mapSignal f) (mapSignal g)) -- temp f g = f * g @@ -249,21 +249,21 @@ instance Signal BasicSignal where in PieceContRep wins toSig Pulse_dc{ start_delay = start_delay , rise_time = rise_time - , pulse_width = pulse_width - , fall_time = fall_time - , dc_offset = dc_offset - , period = period - , amplitude = amplitude - , over = over - , under = under - } = + , pulse_width = pulse_width + , fall_time = fall_time + , dc_offset = dc_offset + , period = period + , amplitude = amplitude + , over = over + , under = under + } = let pul = trap start_delay rise_time pulse_width fall_time amplitude so = toPhysical ((fromPhysical start_delay) + (fromPhysical rise_time)) su = toPhysical ((fromPhysical so) + (fromPhysical pulse_width) + (fromPhysical fall_time)) oversh = toSig over{start_delay=so} undersh = toSig under{start_delay=su} off = constant dc_offset - temp:: (Physical a, Physical b) => SignalRep a b -> + temp:: (Physical a, Physical b) => SignalRep a b -> SignalRep a b -> SignalRep a b temp f g = FunctionRep (binop (+) (mapSignal f) (mapSignal g)) sig = temp (temp (temp pul oversh) undersh) off @@ -272,13 +272,13 @@ instance Signal BasicSignal where in PieceContRep (cycleWindows wins) sumSig:: (Physical a, Physical b, Signal s, Signal s') => (s a b) -> (s' a b) -> SignalRep a b -sumSig f f' = +sumSig f f' = let s1 t = fromPhysical (mapSignal f t) s2 t = fromPhysical (mapSignal f' t) in FunctionRep (\t -> toPhysical ((s1 t) + (s2 t))) mulSig:: (Physical a, Physical b, Signal s, Signal s') => (s a b) -> (s' a b) -> SignalRep a b -mulSig f f' = +mulSig f f' = let f1 t = fromPhysical (mapSignal f t) f2 t = fromPhysical (mapSignal f' t) in FunctionRep (\t -> toPhysical ((f1 t) * (f2 t))) diff --git a/testsuite/tests/programs/fast2haskell/Fast2haskell.hs b/testsuite/tests/programs/fast2haskell/Fast2haskell.hs index da8789eca4..9bcd4de989 100644 --- a/testsuite/tests/programs/fast2haskell/Fast2haskell.hs +++ b/testsuite/tests/programs/fast2haskell/Fast2haskell.hs @@ -6,12 +6,12 @@ land_i, lnot_i, lor_i, lshift_i, rshift_i, descr, destr_update, indassoc, lowbound, tabulate, upbound, update, valassoc) where { - import Data.Bits; + import Data.Bits; -- import Word2; import Data.Word; - import Data.Complex; -- 1.3 - import Data.Array; -- 1.3 --- import Data.Int ( Num(fromInt) ); + import Data.Complex; -- 1.3 + import Data.Array; -- 1.3 +-- import Data.Int ( Num(fromInt) ); type Complex_type = Complex Double; type Array_type b = Array Int b; type Assoc_type a = (Int, a); diff --git a/testsuite/tests/programs/galois_raytrace/CSG.hs b/testsuite/tests/programs/galois_raytrace/CSG.hs index ba37a17b25..f5680d575f 100644 --- a/testsuite/tests/programs/galois_raytrace/CSG.hs +++ b/testsuite/tests/programs/galois_raytrace/CSG.hs @@ -4,10 +4,10 @@ -- which is included in the distribution. module CSG(module Construct, - module Geometry, - module Intersections, - module Interval, - module Misc) where + module Geometry, + module Intersections, + module Interval, + module Misc) where import Construct import Geometry diff --git a/testsuite/tests/programs/galois_raytrace/Construct.hs b/testsuite/tests/programs/galois_raytrace/Construct.hs index 90dbc60f9e..c0702ad9b3 100644 --- a/testsuite/tests/programs/galois_raytrace/Construct.hs +++ b/testsuite/tests/programs/galois_raytrace/Construct.hs @@ -69,7 +69,7 @@ data CSG a -- the a is application-specific texture information type Texture a = (Face, Point, a) -union, intersect, difference :: CSG a -> CSG a -> CSG a +union, intersect, difference :: CSG a -> CSG a -> CSG a union p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Union p q) union p q = Union p q @@ -85,25 +85,25 @@ difference p q = Difference p q mkBox b p = Box b p -plane, sphere, cube, cylinder, cone :: a -> CSG a +plane, sphere, cube, cylinder, cone :: a -> CSG a plane = Plane sphere s = mkBox (B (-1 - epsilon) (1 + epsilon) - (-1 - epsilon) (1 + epsilon) - (-1 - epsilon) (1 + epsilon)) (Sphere s) + (-1 - epsilon) (1 + epsilon) + (-1 - epsilon) (1 + epsilon)) (Sphere s) cone s = mkBox (B (-1 - epsilon) (1 + epsilon) - ( - epsilon) (1 + epsilon) - (-1 - epsilon) (1 + epsilon)) (Cone s) + ( - epsilon) (1 + epsilon) + (-1 - epsilon) (1 + epsilon)) (Cone s) cube s = mkBox (B (- epsilon) (1 + epsilon) - (- epsilon) (1 + epsilon) - (- epsilon) (1 + epsilon)) (Cube s) + (- epsilon) (1 + epsilon) + (- epsilon) (1 + epsilon)) (Cube s) cylinder s = mkBox (B (-1 - epsilon) (1 + epsilon) - ( - epsilon) (1 + epsilon) - (-1 - epsilon) (1 + epsilon)) (Cylinder s) + ( - epsilon) (1 + epsilon) + (-1 - epsilon) (1 + epsilon)) (Cylinder s) ---------------------------- -- Object transformations @@ -120,16 +120,16 @@ transform mm' (Difference p q) = Difference (transform mm' p) (trans transform mm'@(m,_) (Box box p) = Box (transformBox m box) (transform mm' p) transform (m, m') prim = Transform m m' prim -translate :: Coords -> CSG a -> CSG a -translateX, translateY, translateZ :: Double -> CSG a -> CSG a +translate :: Coords -> CSG a -> CSG a +translateX, translateY, translateZ :: Double -> CSG a -> CSG a translate xyz = transform $ transM xyz translateX x = translate (x, 0, 0) translateY y = translate (0, y, 0) translateZ z = translate (0, 0, z) -scale :: Coords -> CSG a -> CSG a -scaleX, scaleY, scaleZ, uscale :: Double -> CSG a -> CSG a +scale :: Coords -> CSG a -> CSG a +scaleX, scaleY, scaleZ, uscale :: Double -> CSG a -> CSG a scale xyz = transform $ scaleM xyz scaleX x = scale (x, 1, 1) @@ -137,7 +137,7 @@ scaleY y = scale (1, y, 1) scaleZ z = scale (1, 1, z) uscale u = scale (u,u,u) -rotateX, rotateY, rotateZ :: Radian -> CSG a -> CSG a +rotateX, rotateY, rotateZ :: Radian -> CSG a -> CSG a rotateX a = transform $ rotxM a rotateY a = transform $ rotyM a @@ -145,72 +145,72 @@ rotateZ a = transform $ rotzM a unit = matrix ( ( 1.0, 0.0, 0.0, 0.0 ), - ( 0.0, 1.0, 0.0, 0.0 ), - ( 0.0, 0.0, 1.0, 0.0 ), - ( 0.0, 0.0, 0.0, 1.0 ) ) + ( 0.0, 1.0, 0.0, 0.0 ), + ( 0.0, 0.0, 1.0, 0.0 ), + ( 0.0, 0.0, 0.0, 1.0 ) ) transM (x, y, z) = ( matrix ( ( 1, 0, 0, x ), - ( 0, 1, 0, y ), - ( 0, 0, 1, z ), - ( 0, 0, 0, 1 ) ), + ( 0, 1, 0, y ), + ( 0, 0, 1, z ), + ( 0, 0, 0, 1 ) ), matrix ( ( 1, 0, 0, -x ), - ( 0, 1, 0, -y ), - ( 0, 0, 1, -z ), - ( 0, 0, 0, 1 ) ) ) + ( 0, 1, 0, -y ), + ( 0, 0, 1, -z ), + ( 0, 0, 0, 1 ) ) ) scaleM (x, y, z) = ( matrix ( ( x', 0, 0, 0 ), - ( 0, y', 0, 0 ), - ( 0, 0, z', 0 ), - ( 0, 0, 0, 1 ) ), + ( 0, y', 0, 0 ), + ( 0, 0, z', 0 ), + ( 0, 0, 0, 1 ) ), matrix ( ( 1/x', 0, 0, 0 ), - ( 0, 1/y', 0, 0 ), - ( 0, 0, 1/z', 0 ), - ( 0, 0, 0, 1 ) ) ) + ( 0, 1/y', 0, 0 ), + ( 0, 0, 1/z', 0 ), + ( 0, 0, 0, 1 ) ) ) where x' = nonZero x - y' = nonZero y - z' = nonZero z + y' = nonZero y + z' = nonZero z rotxM t = ( matrix ( ( 1, 0, 0, 0 ), - ( 0, cos t, -sin t, 0 ), - ( 0, sin t, cos t, 0 ), - ( 0, 0, 0, 1 ) ), + ( 0, cos t, -sin t, 0 ), + ( 0, sin t, cos t, 0 ), + ( 0, 0, 0, 1 ) ), matrix ( ( 1, 0, 0, 0 ), - ( 0, cos t, sin t, 0 ), - ( 0, -sin t, cos t, 0 ), - ( 0, 0, 0, 1 ) ) ) + ( 0, cos t, sin t, 0 ), + ( 0, -sin t, cos t, 0 ), + ( 0, 0, 0, 1 ) ) ) rotyM t = ( matrix ( ( cos t, 0, sin t, 0 ), - ( 0, 1, 0, 0 ), - ( -sin t, 0, cos t, 0 ), - ( 0, 0, 0, 1 ) ), + ( 0, 1, 0, 0 ), + ( -sin t, 0, cos t, 0 ), + ( 0, 0, 0, 1 ) ), matrix ( ( cos t, 0, -sin t, 0 ), - ( 0, 1, 0, 0 ), - ( sin t, 0, cos t, 0 ), - ( 0, 0, 0, 1 ) ) ) + ( 0, 1, 0, 0 ), + ( sin t, 0, cos t, 0 ), + ( 0, 0, 0, 1 ) ) ) rotzM t = ( matrix ( ( cos t, -sin t, 0, 0 ), - ( sin t, cos t, 0, 0 ), - ( 0, 0, 1, 0 ), - ( 0, 0, 0, 1 ) ), + ( sin t, cos t, 0, 0 ), + ( 0, 0, 1, 0 ), + ( 0, 0, 0, 1 ) ), matrix ( ( cos t, sin t, 0, 0 ), - ( -sin t, cos t, 0, 0 ), - ( 0, 0, 1, 0 ), - ( 0, 0, 0, 1 ) ) ) + ( -sin t, cos t, 0, 0 ), + ( 0, 0, 1, 0 ), + ( 0, 0, 0, 1 ) ) ) ------------------- -- Eye transformations @@ -220,9 +220,9 @@ rotzM t -- These are implemented as inverse transforms of the model. ------------------- -eye :: Transform -translateEye :: Coords -> Transform -> Transform -rotateEyeX, rotateEyeY, rotateEyeZ :: Radian -> Transform -> Transform +eye :: Transform +translateEye :: Coords -> Transform -> Transform +rotateEyeX, rotateEyeY, rotateEyeZ :: Radian -> Transform -> Transform eye = (unit, unit) translateEye xyz (eye1, eye2) @@ -255,11 +255,11 @@ transformBox t (B x1 x2 y1 y2 z1 z2) (foldr1 min (map zCoord pts')) (foldr1 max (map zCoord pts'))) where pts' = map (multMP t) pts - pts = [point x1 y1 z1, - point x1 y1 z2, - point x1 y2 z1, - point x1 y2 z2, - point x2 y1 z1, - point x2 y1 z2, - point x2 y2 z1, - point x2 y2 z2] + pts = [point x1 y1 z1, + point x1 y1 z2, + point x1 y2 z1, + point x1 y2 z2, + point x2 y1 z1, + point x2 y1 z2, + point x2 y2 z1, + point x2 y2 z2] diff --git a/testsuite/tests/programs/galois_raytrace/Data.hs b/testsuite/tests/programs/galois_raytrace/Data.hs index f02aabe7bf..6cbd112eac 100644 --- a/testsuite/tests/programs/galois_raytrace/Data.hs +++ b/testsuite/tests/programs/galois_raytrace/Data.hs @@ -23,19 +23,19 @@ type Code = [GMLToken] data GMLToken -- All these can occur in parsed code - = TOp GMLOp - | TId Name - | TBind Name - | TBool Bool - | TInt Int - | TReal Double - | TString String - | TBody Code - | TArray Code - | TApply - | TIf - -- These can occur in optimized/transformed code - -- NONE (yet!) + = TOp GMLOp + | TId Name + | TBind Name + | TBool Bool + | TInt Int + | TReal Double + | TString String + | TBody Code + | TArray Code + | TApply + | TIf + -- These can occur in optimized/transformed code + -- NONE (yet!) instance Show GMLToken where @@ -63,22 +63,22 @@ instance Show GMLToken where type Stack = [GMLValue] data GMLValue - = VBool !Bool - | VInt !Int - | VReal !Double - | VString String - | VClosure Env Code - | VArray (Array Int GMLValue) -- FIXME: Haskell array + = VBool !Bool + | VInt !Int + | VReal !Double + | VString String + | VClosure Env Code + | VArray (Array Int GMLValue) -- FIXME: Haskell array -- uses the interpreter version of point - | VPoint { xPoint :: !Double + | VPoint { xPoint :: !Double , yPoint :: !Double , zPoint :: !Double } -- these are abstract to the interpreter - | VObject Object - | VLight Light - -- This is an abstract object, used by the abstract interpreter - | VAbsObj AbsObj + | VObject Object + | VLight Light + -- This is an abstract object, used by the abstract interpreter + | VAbsObj AbsObj -- There are only *3* basic abstract values, @@ -200,7 +200,7 @@ opTable = [ (kwd,op) | (kwd,op,_) <- opcodes ] opNameTable :: Array GMLOp Name opNameTable = array (minBound,maxBound) - [ (op,name) | (name,TOp op,_) <- opcodes ] + [ (op,name) | (name,TOp op,_) <- opcodes ] undef = error "undefined function" image = error "undefined function: talk to image group" @@ -210,62 +210,62 @@ image = error "undefined function: talk to image group" opcodes :: [(String,GMLToken,PrimOp)] opcodes = - [ ("apply", TApply, error "incorrect use of apply") - , ("if", TIf, error "incorrect use of if") - , ("false", TBool False, error "incorrect use of false") - , ("true", TBool True, error "incorrect use of true") + [ ("apply", TApply, error "incorrect use of apply") + , ("if", TIf, error "incorrect use of if") + , ("false", TBool False, error "incorrect use of false") + , ("true", TBool True, error "incorrect use of true") ] ++ map (\ (a,b,c) -> (a,TOp b,c)) -- These are just invocation, any coercions need to occur between here -- and before arriving at the application code (like deg -> rad). - [ ("acos", Op_acos, Real_Real (rad2deg . acos)) - , ("addi", Op_addi, Int_Int_Int (+)) - , ("addf", Op_addf, Real_Real_Real (+)) - , ("asin", Op_asin, Real_Real (rad2deg . asin)) - , ("clampf", Op_clampf, Real_Real clampf) - , ("cone", Op_cone, Surface_Obj cone) - , ("cos", Op_cos, Real_Real (cos . deg2rad)) - , ("cube", Op_cube, Surface_Obj cube) - , ("cylinder", Op_cylinder, Surface_Obj cylinder) + [ ("acos", Op_acos, Real_Real (rad2deg . acos)) + , ("addi", Op_addi, Int_Int_Int (+)) + , ("addf", Op_addf, Real_Real_Real (+)) + , ("asin", Op_asin, Real_Real (rad2deg . asin)) + , ("clampf", Op_clampf, Real_Real clampf) + , ("cone", Op_cone, Surface_Obj cone) + , ("cos", Op_cos, Real_Real (cos . deg2rad)) + , ("cube", Op_cube, Surface_Obj cube) + , ("cylinder", Op_cylinder, Surface_Obj cylinder) , ("difference", Op_difference, Obj_Obj_Obj difference) - , ("divi", Op_divi, Int_Int_Int (ourQuot)) - , ("divf", Op_divf, Real_Real_Real (/)) - , ("eqi", Op_eqi, Int_Int_Bool (==)) - , ("eqf", Op_eqf, Real_Real_Bool (==)) - , ("floor", Op_floor, Real_Int floor) - , ("frac", Op_frac, Real_Real (snd . properFraction)) - , ("get", Op_get, Arr_Int_Value ixGet) - , ("getx", Op_getx, Point_Real (\ x y z -> x)) - , ("gety", Op_gety, Point_Real (\ x y z -> y)) - , ("getz", Op_getz, Point_Real (\ x y z -> z)) + , ("divi", Op_divi, Int_Int_Int (ourQuot)) + , ("divf", Op_divf, Real_Real_Real (/)) + , ("eqi", Op_eqi, Int_Int_Bool (==)) + , ("eqf", Op_eqf, Real_Real_Bool (==)) + , ("floor", Op_floor, Real_Int floor) + , ("frac", Op_frac, Real_Real (snd . properFraction)) + , ("get", Op_get, Arr_Int_Value ixGet) + , ("getx", Op_getx, Point_Real (\ x y z -> x)) + , ("gety", Op_gety, Point_Real (\ x y z -> y)) + , ("getz", Op_getz, Point_Real (\ x y z -> z)) , ("intersect", Op_intersect, Obj_Obj_Obj intersect) - , ("length", Op_length, Arr_Int (succ . snd . bounds)) - , ("lessi", Op_lessi, Int_Int_Bool (<)) - , ("lessf", Op_lessf, Real_Real_Bool (<)) - , ("light", Op_light, Point_Color_Light light) - , ("modi", Op_modi, Int_Int_Int (ourRem)) - , ("muli", Op_muli, Int_Int_Int (*)) - , ("mulf", Op_mulf, Real_Real_Real (*)) - , ("negi", Op_negi, Int_Int negate) - , ("negf", Op_negf, Real_Real negate) - , ("plane", Op_plane, Surface_Obj plane) - , ("point", Op_point, Real_Real_Real_Point VPoint) + , ("length", Op_length, Arr_Int (succ . snd . bounds)) + , ("lessi", Op_lessi, Int_Int_Bool (<)) + , ("lessf", Op_lessf, Real_Real_Bool (<)) + , ("light", Op_light, Point_Color_Light light) + , ("modi", Op_modi, Int_Int_Int (ourRem)) + , ("muli", Op_muli, Int_Int_Int (*)) + , ("mulf", Op_mulf, Real_Real_Real (*)) + , ("negi", Op_negi, Int_Int negate) + , ("negf", Op_negf, Real_Real negate) + , ("plane", Op_plane, Surface_Obj plane) + , ("point", Op_point, Real_Real_Real_Point VPoint) , ("pointlight", Op_pointlight, Point_Color_Light pointlight) - , ("real", Op_real, Int_Real fromIntegral) - , ("render", Op_render, Render $ render eye) - , ("rotatex", Op_rotatex, Obj_Real_Obj (\ o d -> rotateX (deg2rad d) o)) - , ("rotatey", Op_rotatey, Obj_Real_Obj (\ o d -> rotateY (deg2rad d) o)) - , ("rotatez", Op_rotatez, Obj_Real_Obj (\ o d -> rotateZ (deg2rad d) o)) - , ("scale", Op_scale, Obj_Real_Real_Real_Obj (\ o x y z -> scale (x,y,z) o)) - , ("sin", Op_sin, Real_Real (sin . deg2rad)) - , ("sphere", Op_sphere, Surface_Obj sphere') -- see comment at end of file + , ("real", Op_real, Int_Real fromIntegral) + , ("render", Op_render, Render $ render eye) + , ("rotatex", Op_rotatex, Obj_Real_Obj (\ o d -> rotateX (deg2rad d) o)) + , ("rotatey", Op_rotatey, Obj_Real_Obj (\ o d -> rotateY (deg2rad d) o)) + , ("rotatez", Op_rotatez, Obj_Real_Obj (\ o d -> rotateZ (deg2rad d) o)) + , ("scale", Op_scale, Obj_Real_Real_Real_Obj (\ o x y z -> scale (x,y,z) o)) + , ("sin", Op_sin, Real_Real (sin . deg2rad)) + , ("sphere", Op_sphere, Surface_Obj sphere') -- see comment at end of file , ("spotlight", Op_spotlight, Point_Point_Color_Real_Real_Light mySpotlight) - , ("sqrt", Op_sqrt, Real_Real ourSqrt) - , ("subi", Op_subi, Int_Int_Int (-)) - , ("subf", Op_subf, Real_Real_Real (-)) + , ("sqrt", Op_sqrt, Real_Real ourSqrt) + , ("subi", Op_subi, Int_Int_Int (-)) + , ("subf", Op_subf, Real_Real_Real (-)) , ("trace", Op_trace, Value_String_Value mytrace) , ("translate", Op_translate, Obj_Real_Real_Real_Obj (\ o x y z -> translate (x,y,z) o)) - , ("union", Op_union, Obj_Obj_Obj union) - , ("uscale", Op_uscale, Obj_Real_Obj (\ o r -> uscale r o)) + , ("union", Op_union, Obj_Obj_Obj union) + , ("uscale", Op_uscale, Obj_Real_Obj (\ o r -> uscale r o)) ] -- This enumerate all possible ways of calling the fixed primitives diff --git a/testsuite/tests/programs/galois_raytrace/Eval.hs b/testsuite/tests/programs/galois_raytrace/Eval.hs index bd9d419400..bf43d10605 100644 --- a/testsuite/tests/programs/galois_raytrace/Eval.hs +++ b/testsuite/tests/programs/galois_raytrace/Eval.hs @@ -47,10 +47,10 @@ instance MonadEval IO where err s = error s data State - = State { env :: Env - , stack :: Stack - , code :: Code - } deriving Show + = State { env :: Env + , stack :: Stack + , code :: Code + } deriving Show callback :: Env -> Code -> Stack -> Stack callback env code stk @@ -151,7 +151,7 @@ step _ = err "Tripped on sidewalk while stepping." opFnTable :: Array GMLOp PrimOp opFnTable = array (minBound,maxBound) - [ (op,prim) | (_,TOp op,prim) <- opcodes ] + [ (op,prim) | (_,TOp op,prim) <- opcodes ] @@ -181,7 +181,7 @@ doPrimOp (Surface_Obj fn) _ (VClosure env code:stk) = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] -> let - res = prop (color c1 c2 c3) r1 r2 r3 + res = prop (color c1 c2 c3) r1 r2 r3 in return ((VObject (fn (SConst res))) : stk) _ -> return ((VObject (fn (SFun call))) : stk) @@ -190,7 +190,7 @@ doPrimOp (Surface_Obj fn) _ (VClosure env code:stk) call i r1 r2 = case callback env code [VReal r2,VReal r1,VInt i] of [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] - -> prop (color c1 c2 c3) r1 r2 r3 + -> prop (color c1 c2 c3) r1 r2 r3 stk -> error ("callback failed: incorrectly typed return arguments" ++ show stk) @@ -241,10 +241,10 @@ doPrimOp primOp op args = err ("\n\ntype error when attempting to execute builtin primitive \"" ++ show op ++ "\"\n\n| " ++ show op ++ " takes " ++ show (length types) ++ " argument" ++ s - ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++ + ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++ " " ++ unwords [ show ty | ty <- types ] ++ "\n|\n|" ++ " currently, the relevent argument" ++ s ++ " on the stack " ++ - are ++ "\n|\n| " ++ + are ++ "\n|\n| " ++ unwords [ "(" ++ show arg ++ ")" | arg <- reverse (take (length types) args) ] ++ "\n|\n| " ++ " (top of stack is on the right hand side)\n\n") @@ -261,7 +261,7 @@ doPrimOp primOp op args doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack doAllOp (Render render) Op_render - (VString str:VInt ht:VInt wid:VReal fov + (VString str:VInt ht:VInt wid:VReal fov :VInt dep:VObject obj:VArray arr :VPoint r g b : stk) = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str @@ -303,7 +303,7 @@ instance Applicative Abs where instance Monad Abs where (Abs fn) >>= k = Abs (\ s -> case fn s of - AbsState r s' -> runAbs (k r) s' + AbsState r s' -> runAbs (k r) s' AbsFail m -> AbsFail m) return = pure fail s = Abs (\ n -> AbsFail s) @@ -333,9 +333,9 @@ mainEval prog = do { stk <- eval (State emptyEnv [] prog) * Oops, one of the example actually has something * on the stack at the end. * Oh well... - ; if null stk + ; if null stk then return () - else do { putStrLn done + else do { putStrLn done ; print stk } -} diff --git a/testsuite/tests/programs/galois_raytrace/Geometry.hs b/testsuite/tests/programs/galois_raytrace/Geometry.hs index de9d960450..8bca3a3e89 100644 --- a/testsuite/tests/programs/galois_raytrace/Geometry.hs +++ b/testsuite/tests/programs/galois_raytrace/Geometry.hs @@ -160,7 +160,7 @@ tangents :: Vector -> (Vector, Vector) tangents v@(V x y z) = (v1, v `cross` v1) where v1 | x == 0 = normalize (vector 0 z (-y)) - | otherwise = normalize (vector (-y) x 0) + | otherwise = normalize (vector (-y) x 0) {-# INLINE dot4 #-} dot4 :: Quad -> Quad -> Double @@ -195,7 +195,7 @@ norm (V x y z) = sqrt (sq x + sq y + sq z) normalize :: Vector -> Vector normalize v@(V x y z) | norm /= 0 = multSV (1/norm) v - | otherwise = error "normalize empty!" + | otherwise = error "normalize empty!" where norm = sqrt (sq x + sq y + sq z) -- This does computes the distance *squared* diff --git a/testsuite/tests/programs/galois_raytrace/Illumination.hs b/testsuite/tests/programs/galois_raytrace/Illumination.hs index b68eea8bf2..5f780ffdff 100644 --- a/testsuite/tests/programs/galois_raytrace/Illumination.hs +++ b/testsuite/tests/programs/galois_raytrace/Illumination.hs @@ -98,14 +98,14 @@ illum cxt (pos,normV,(col,kd,ks,n)) v ambTerm = multSC kd (multCC amb col) difTerm = multSC kd (sumCC [multSC (dot normV lj) (multCC intensity col) - |(loc,intensity) <- visibleLights, - let lj = normalize ({- pos `subVV` -} loc)]) + |(loc,intensity) <- visibleLights, + let lj = normalize ({- pos `subVV` -} loc)]) -- ZZ might want to avoid the phong, when you can... spcTerm = multSC ks (sumCC [multSC ((dot normV hj) ** n ) (multCC intensity col) - |(loc,intensity) <- visibleLights, - -- ZZ note this is specific to the light at infinity - let lj = {- pos `subVV` -} normalize loc, - let hj = normalize (lj `subVV` normalize v)]) + |(loc,intensity) <- visibleLights, + -- ZZ note this is specific to the light at infinity + let lj = {- pos `subVV` -} normalize loc, + let hj = normalize (lj `subVV` normalize v)]) recTerm = if recCoeff `nearC` black then black else multCC recCoeff recRay recCoeff = multSC ks col recRay = illumination cxt (pos,newV) @@ -203,8 +203,8 @@ castRay ray p (False, (0, b, _) : _, _) -> Nothing -- eye is inside (False, (i, False, _) : _, _) -> Nothing -- eye is inside (False, (t, b, (s, p0)) : _, _) -> - let (v, prop) = surface s p0 in - Just (offsetToPoint ray t, v, prop) + let (v, prop) = surface s p0 in + Just (offsetToPoint ray t, v, prop) intersects ray p = case intersectRayWithObject ray p of diff --git a/testsuite/tests/programs/galois_raytrace/Intersections.hs b/testsuite/tests/programs/galois_raytrace/Intersections.hs index 58210c30f9..6d7f275385 100644 --- a/testsuite/tests/programs/galois_raytrace/Intersections.hs +++ b/testsuite/tests/programs/galois_raytrace/Intersections.hs @@ -41,22 +41,22 @@ clampIntervals ivals@(False, is@((i, True, p) : is'), isOpen) intersections ray (Union p q) = unionIntervals is js where is = intersections ray p - js = intersections ray q + js = intersections ray q intersections ray (Intersect p q) = intersectIntervals is js where is = intersections ray p - js = intersections ray q + js = intersections ray q intersections ray (Difference p q) = differenceIntervals is (negateSurfaces js) where is = intersections ray p - js = intersections ray q + js = intersections ray q intersections ray (Transform m m' p) = mapI (xform m) is where is = intersections (m' `multMR` ray) p - xform m (i, b, (s, p0)) = (i, b, (transformSurface m s, p0)) + xform m (i, b, (s, p0)) = (i, b, (transformSurface m s, p0)) intersections ray (Box box p) | intersectWithBox ray box = intersections ray p @@ -93,27 +93,27 @@ negateSurface (Conic p0 v0 v1) transformSurface m (Planar p0 v0 v1) = Planar p0' v0' v1' where p0' = multMP m p0 - v0' = multMV m v0 - v1' = multMV m v1 + v0' = multMV m v0 + v1' = multMV m v1 transformSurface m (Spherical p0 v0 v1) = Spherical p0' v0' v1' where p0' = multMP m p0 - v0' = multMV m v0 - v1' = multMV m v1 + v0' = multMV m v0 + v1' = multMV m v1 -- ditto as above transformSurface m (Cylindrical p0 v0 v1) = Cylindrical p0' v0' v1' where p0' = multMP m p0 - v0' = multMV m v0 - v1' = multMV m v1 + v0' = multMV m v0 + v1' = multMV m v1 transformSurface m (Conic p0 v0 v1) = Conic p0' v0' v1' where p0' = multMP m p0 - v0' = multMV m v0 - v1' = multMV m v1 + v0' = multMV m v0 + v1' = multMV m v1 -------------------------------- -- Plane @@ -133,25 +133,25 @@ intersectXZPlane n (r,v) yoffset texture -- t may be negative (the ray starts within the halfspace), -- but we'll catch that later when we clamp the intervals - | b < 0 -- the ray is pointing downwards + | b < 0 -- the ray is pointing downwards = (False, [mkEntry (t0, (Planar p0 v0 v1, (n, p0, texture)))], True) - | otherwise -- the ray is pointing upwards + | otherwise -- the ray is pointing upwards = (True, [mkExit (t0, (Planar p0 v0 v1, (n, p0, texture)))], False) where t0 = (yoffset-y) / b - x0 = x + a * t0 - z0 = z + c * t0 - p0 = point x0 0 z0 - v0 = vector 0 0 1 - v1 = vector 1 0 0 + x0 = x + a * t0 + z0 = z + c * t0 + p0 = point x0 0 z0 + v0 = vector 0 0 1 + v1 = vector 1 0 0 - x = xCoord r - y = yCoord r - z = zCoord r - a = xComponent v - b = yComponent v - c = zComponent v + x = xCoord r + y = yCoord r + z = zCoord r + a = xComponent v + b = yComponent v + c = zComponent v -------------------------------- @@ -166,26 +166,26 @@ intersectSphere ray@(r, v) texture -- This is a quadratic equation in t: -- t^2(a^2 + b^2 + c^2) + 2t(xa + yb + zc) + (x^2 + y^2 + z^2 - 1) = 0 let c1 = sq a + sq b + sq c - c2 = 2 * (x * a + y * b + z * c) - c3 = sq x + sq y + sq z - 1 + c2 = 2 * (x * a + y * b + z * c) + c3 = sq x + sq y + sq z - 1 in - case quadratic c1 c2 c3 of + case quadratic c1 c2 c3 of Nothing -> emptyIList Just (t1, t2) -> entryexit (g t1) (g t2) where x = xCoord r - y = yCoord r - z = zCoord r - a = xComponent v - b = yComponent v - c = zComponent v - g t = (t, (Spherical origin v1 v2, (SphereFace, p0, texture))) - where origin = point 0 0 0 - x0 = x + t * a - y0 = y + t * b - z0 = z + t * c - p0 = point x0 y0 z0 - v0 = vector x0 y0 z0 - (v1, v2) = tangents v0 + y = yCoord r + z = zCoord r + a = xComponent v + b = yComponent v + c = zComponent v + g t = (t, (Spherical origin v1 v2, (SphereFace, p0, texture))) + where origin = point 0 0 0 + x0 = x + t * a + y0 = y + t * b + z0 = z + t * c + p0 = point x0 y0 z0 + v0 = vector x0 y0 z0 + (v1, v2) = tangents v0 -------------------------------- @@ -200,32 +200,32 @@ intersectCube ray@(r, v) texture -- The minimum and maximum such values of t give us the two -- intersection points. case intersectSlabIval (intersectCubeSlab face2 face3 x a) - (intersectSlabIval (intersectCubeSlab face5 face4 y b) - (intersectCubeSlab face0 face1 z c)) of + (intersectSlabIval (intersectCubeSlab face5 face4 y b) + (intersectCubeSlab face0 face1 z c)) of Nothing -> emptyIList Just (t1, t2) -> entryexit (g t1) (g t2) where g ((n, v0, v1), t) - = (t, (Planar p0 v0 v1, (n, p0, texture))) - where p0 = offsetToPoint ray t - face0 = (CubeFront, vectorY, vectorX) - face1 = (CubeBack, vectorX, vectorY) - face2 = (CubeLeft, vectorZ, vectorY) - face3 = (CubeRight, vectorY, vectorZ) - face4 = (CubeTop, vectorZ, vectorX) - face5 = (CubeBottom, vectorX, vectorZ) - vectorX = vector 1 0 0 - vectorY = vector 0 1 0 - vectorZ = vector 0 0 1 - x = xCoord r - y = yCoord r - z = zCoord r - a = xComponent v - b = yComponent v - c = zComponent v + = (t, (Planar p0 v0 v1, (n, p0, texture))) + where p0 = offsetToPoint ray t + face0 = (CubeFront, vectorY, vectorX) + face1 = (CubeBack, vectorX, vectorY) + face2 = (CubeLeft, vectorZ, vectorY) + face3 = (CubeRight, vectorY, vectorZ) + face4 = (CubeTop, vectorZ, vectorX) + face5 = (CubeBottom, vectorX, vectorZ) + vectorX = vector 1 0 0 + vectorY = vector 0 1 0 + vectorZ = vector 0 0 1 + x = xCoord r + y = yCoord r + z = zCoord r + a = xComponent v + b = yComponent v + c = zComponent v intersectCubeSlab n m w d | d `near` 0 = if (0 <= w) && (w <= 1) - then Just ((n, -inf), (m, inf)) else Nothing + then Just ((n, -inf), (m, inf)) else Nothing | d > 0 = Just ((n, (-w)/d), (m, (1-w)/d)) | otherwise = Just ((m, (1-w)/d), (n, (-w)/d)) @@ -233,15 +233,15 @@ intersectSlabIval Nothing Nothing = Nothing intersectSlabIval Nothing (Just i) = Nothing intersectSlabIval (Just i) Nothing = Nothing intersectSlabIval (Just (nu1@(n1, u1), mv1@(m1, v1))) - (Just (nu2@(n2, u2), mv2@(m2, v2))) + (Just (nu2@(n2, u2), mv2@(m2, v2))) = checkInterval (nu, mv) where nu = if u1 < u2 then nu2 else nu1 - mv = if v1 < v2 then mv1 else mv2 - checkInterval numv@(nu@(_, u), (m, v)) - -- rounding error may force us to push v out a bit - | u `near` v = Just (nu, (m, u + epsilon)) - | u < v = Just numv - | otherwise = Nothing + mv = if v1 < v2 then mv1 else mv2 + checkInterval numv@(nu@(_, u), (m, v)) + -- rounding error may force us to push v out a bit + | u `near` v = Just (nu, (m, u + epsilon)) + | u < v = Just numv + | otherwise = Nothing -------------------------------- @@ -252,9 +252,9 @@ intersectCylinder :: Ray -> a -> IList (Surface, Texture a) intersectCylinder ray texture = isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom where isectSide = intersectCylSide ray texture - isectTop = intersectXZPlane CylinderTop ray 1.0 texture - isectBottom = complementIntervals $ negateSurfaces $ - intersectXZPlane CylinderBottom ray 0.0 texture + isectTop = intersectXZPlane CylinderTop ray 1.0 texture + isectBottom = complementIntervals $ negateSurfaces $ + intersectXZPlane CylinderBottom ray 0.0 texture intersectCylSide (r, v) texture = -- The ray (x + ta, y + tb, z + tc) intersects the sides of the @@ -262,34 +262,34 @@ intersectCylSide (r, v) texture -- (x + ta)^2 + (z + tc)^2 = 1 and 0 <= y + tb <= 1. if (sq a + sq c) `near` 0 then -- The ray is parallel to the Y-axis, and does not intersect - -- the cylinder sides. It's either all in, or all out - if (sqxy `near` 1.0 || sqxy < 1.0) then openIList else emptyIList + -- the cylinder sides. It's either all in, or all out + if (sqxy `near` 1.0 || sqxy < 1.0) then openIList else emptyIList else -- Find values of t that solve the quadratic equation - -- (a^2 + c^2)t^2 + 2(ax + cz)t + x^2 + z^2 - 1 = 0 + -- (a^2 + c^2)t^2 + 2(ax + cz)t + x^2 + z^2 - 1 = 0 let c1 = sq a + sq c c2 = 2 * (x * a + z * c) c3 = sq x + sq z - 1 - in - case quadratic c1 c2 c3 of + in + case quadratic c1 c2 c3 of Nothing -> emptyIList Just (t1, t2) -> entryexit (g t1) (g t2) where sqxy = sq x + sq y - g t = (t, (Cylindrical origin v1 v2, (CylinderSide, p0, texture))) - where origin = point 0 0 0 - x0 = x + t * a - y0 = y + t * b - z0 = z + t * c - p0 = point x0 y0 z0 - v0 = vector x0 0 z0 - (v1, v2) = tangents v0 - - x = xCoord r - y = yCoord r - z = zCoord r - a = xComponent v - b = yComponent v - c = zComponent v + g t = (t, (Cylindrical origin v1 v2, (CylinderSide, p0, texture))) + where origin = point 0 0 0 + x0 = x + t * a + y0 = y + t * b + z0 = z + t * c + p0 = point x0 y0 z0 + v0 = vector x0 0 z0 + (v1, v2) = tangents v0 + + x = xCoord r + y = yCoord r + z = zCoord r + a = xComponent v + b = yComponent v + c = zComponent v ------------------- @@ -300,9 +300,9 @@ intersectCone :: Ray -> a -> IList (Surface, Texture a) intersectCone ray texture = isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom where isectSide = intersectConeSide ray texture - isectTop = intersectXZPlane ConeBase ray 1.0 texture - isectBottom = complementIntervals $ negateSurfaces $ - intersectXZPlane ConeBase ray 0.0 texture + isectTop = intersectXZPlane ConeBase ray 1.0 texture + isectBottom = complementIntervals $ negateSurfaces $ + intersectXZPlane ConeBase ray 0.0 texture intersectConeSide (r, v) texture = -- Find the points where the ray intersects the cond side. At any points of @@ -311,42 +311,42 @@ intersectConeSide (r, v) texture -- which is the following quadratic equation: -- t^2(a^2-b^2+c^2) + 2t(xa-yb+cz) + (x^2-y^2+z^2) = 0 let c1 = sq a - sq b + sq c - c2 = 2 * (x * a - y * b + c * z) - c3 = sq x - sq y + sq z + c2 = 2 * (x * a - y * b + c * z) + c3 = sq x - sq y + sq z in case quadratic c1 c2 c3 of - Nothing -> emptyIList - Just (t1, t2) -> - -- If either intersection strikes the middle, then the other - -- can only be off by rounding error, so we make a tangent - -- strike using the "good" value. - -- If the intersections straddle the origin, then it's - -- an exit/entry pair, otherwise it's an entry/exit pair. - let y1 = y + t1 * b - y2 = y + t2 * b - in if y1 `near` 0 then entryexit (g t1) (g t1) - else if y2 `near` 0 then entryexit (g t2) (g t2) - else if (y1 < 0) `xor` (y2 < 0) then exitentry (g t1) (g t2) - else entryexit (g t1) (g t2) + Nothing -> emptyIList + Just (t1, t2) -> + -- If either intersection strikes the middle, then the other + -- can only be off by rounding error, so we make a tangent + -- strike using the "good" value. + -- If the intersections straddle the origin, then it's + -- an exit/entry pair, otherwise it's an entry/exit pair. + let y1 = y + t1 * b + y2 = y + t2 * b + in if y1 `near` 0 then entryexit (g t1) (g t1) + else if y2 `near` 0 then entryexit (g t2) (g t2) + else if (y1 < 0) `xor` (y2 < 0) then exitentry (g t1) (g t2) + else entryexit (g t1) (g t2) where g t = (t, (Conic origin v1 v2, (ConeSide, p0, texture))) - where origin = point 0 0 0 - x0 = x + t * a - y0 = y + t * b - z0 = z + t * c - p0 = point x0 y0 z0 - v0 = normalize $ vector x0 (-y0) z0 - (v1, v2) = tangents v0 - - x = xCoord r - y = yCoord r - z = zCoord r - a = xComponent v - b = yComponent v - c = zComponent v - - -- beyond me why this isn't defined in the prelude... - xor False b = b - xor True b = not b + where origin = point 0 0 0 + x0 = x + t * a + y0 = y + t * b + z0 = z + t * c + p0 = point x0 y0 z0 + v0 = normalize $ vector x0 (-y0) z0 + (v1, v2) = tangents v0 + + x = xCoord r + y = yCoord r + z = zCoord r + a = xComponent v + b = yComponent v + c = zComponent v + + -- beyond me why this isn't defined in the prelude... + xor False b = b + xor True b = not b ------------------- @@ -361,17 +361,17 @@ quadratic a b c = in if d' < 0 then Nothing -- There are no real roots. else - if a > 0 then Just (((-b) - sqrt d') / (2 * a), - ((-b) + sqrt d') / (2 * a)) - else Just (((-b) + sqrt d') / (2 * a), - ((-b) - sqrt d') / (2 * a)) + if a > 0 then Just (((-b) - sqrt d') / (2 * a), + ((-b) + sqrt d') / (2 * a)) + else Just (((-b) + sqrt d') / (2 * a), + ((-b) - sqrt d') / (2 * a)) ------------------- -- Bounding boxes ------------------- data MaybeInterval = Interval !Double !Double - | NoInterval + | NoInterval isInterval (Interval _ _) = True isInterval _ = False @@ -380,10 +380,10 @@ intersectWithBox :: Ray -> Box -> Bool intersectWithBox (r, v) (B x1 x2 y1 y2 z1 z2) = isInterval interval where x_interval = intersectRayWithSlab (xCoord r) (xComponent v) (x1, x2) - y_interval = intersectRayWithSlab (yCoord r) (yComponent v) (y1, y2) - z_interval = intersectRayWithSlab (zCoord r) (zComponent v) (z1, z2) - interval = intersectInterval x_interval - (intersectInterval y_interval z_interval) + y_interval = intersectRayWithSlab (yCoord r) (yComponent v) (y1, y2) + z_interval = intersectRayWithSlab (zCoord r) (zComponent v) (z1, z2) + interval = intersectInterval x_interval + (intersectInterval y_interval z_interval) intersectInterval :: MaybeInterval -> MaybeInterval -> MaybeInterval intersectInterval NoInterval _ = NoInterval @@ -399,6 +399,6 @@ intersectRayWithSlab xCoord alpha (x1, x2) | alpha > 0 = Interval a b | otherwise = Interval b a where a = (x1 - xCoord) / alpha - b = (x2 - xCoord) / alpha + b = (x2 - xCoord) / alpha infInterval = Interval (-inf) inf diff --git a/testsuite/tests/programs/galois_raytrace/Interval.hs b/testsuite/tests/programs/galois_raytrace/Interval.hs index a4d313f66e..174b3ffff5 100644 --- a/testsuite/tests/programs/galois_raytrace/Interval.hs +++ b/testsuite/tests/programs/galois_raytrace/Interval.hs @@ -29,8 +29,8 @@ import Geometry -- solid. As a convenience, we also keep an additional flag that -- indicates whether the last intersection ends inside or outside. -type IList a = (Bool, [Intersection a], Bool) -type Intersection a = (Double, Bool, a) +type IList a = (Bool, [Intersection a], Bool) +type Intersection a = (Double, Bool, a) emptyIList = (False, [], False) openIList = (True, [], True) @@ -46,7 +46,7 @@ mkExit (t, a) = (t, False, a) entryexit w1 w2 = (False, [mkEntry w1, mkExit w2], False) exitentry w1 w2 = (True, [mkExit w1, mkEntry w2], True) arrange w1@(t1, _) w2@(t2, _) | t1 < t2 = entryexit w1 w2 - | otherwise = entryexit w2 w1 + | otherwise = entryexit w2 w1 cmpI :: Intersection a -> Intersection a -> Ordering @@ -66,23 +66,23 @@ unionIntervals :: IList a -> IList a -> IList a unionIntervals (isStartOpen, is, isEndOpen) (jsStartOpen, js, jsEndOpen) = (isStartOpen || jsStartOpen, uniIntervals is js, isEndOpen || jsEndOpen) where uniIntervals is [] | jsEndOpen = [] - | otherwise = is - uniIntervals [] js | isEndOpen = [] - | otherwise = js - uniIntervals is@(i : is') js@(j : js') - = case cmpI i j of - EQ -> if isEntry i == isEntry j then i : uniIntervals is' js' - else uniIntervals is' js' - LT -> if isEntry j then i : uniIntervals is' js - else uniIntervals is' js - GT -> if isEntry i then j : uniIntervals is js' - else uniIntervals is js' + | otherwise = is + uniIntervals [] js | isEndOpen = [] + | otherwise = js + uniIntervals is@(i : is') js@(j : js') + = case cmpI i j of + EQ -> if isEntry i == isEntry j then i : uniIntervals is' js' + else uniIntervals is' js' + LT -> if isEntry j then i : uniIntervals is' js + else uniIntervals is' js + GT -> if isEntry i then j : uniIntervals is js' + else uniIntervals is js' intersectIntervals :: IList a -> IList a -> IList a intersectIntervals is js = complementIntervals (unionIntervals is' js') where is' = complementIntervals is - js' = complementIntervals js + js' = complementIntervals js differenceIntervals :: IList a -> IList a -> IList a differenceIntervals is js @@ -114,8 +114,8 @@ t7 = differenceIntervals i2 i2 sh (o1,is,o2) = do if o1 then putStr "..." else return () - putStr $ foldr1 (++) (map si is) - if o2 then putStr "..." else return () + putStr $ foldr1 (++) (map si is) + if o2 then putStr "..." else return () si (i, True, _, _) = "<" ++ show i si (i, False, _, _) = " " ++ show i ++ ">" -} diff --git a/testsuite/tests/programs/galois_raytrace/Pixmap.hs b/testsuite/tests/programs/galois_raytrace/Pixmap.hs index edb75af4fa..4aa488c229 100644 --- a/testsuite/tests/programs/galois_raytrace/Pixmap.hs +++ b/testsuite/tests/programs/galois_raytrace/Pixmap.hs @@ -11,29 +11,29 @@ import Text.ParserCombinators.Parsec readPPM f = do h <- openFile f ReadMode - s <- hGetContents h - case (parse parsePPM f s) of - Left err -> error (show err) - Right x -> return x + s <- hGetContents h + case (parse parsePPM f s) of + Left err -> error (show err) + Right x -> return x writePPM f ppm = do h <- openFile f WriteMode - let s = showPPM (length (head ppm)) (length ppm) ppm - hPutStr h s + let s = showPPM (length (head ppm)) (length ppm) ppm + hPutStr h s -- parsing parsePPM = do string "P6" - whiteSpace - width <- number - whiteSpace - height <- number - whiteSpace - colormax <- number - whiteSpace - cs <- getInput - return (chop width (chopColors cs)) + whiteSpace + width <- number + whiteSpace + height <- number + whiteSpace + colormax <- number + whiteSpace + cs <- getInput + return (chop width (chopColors cs)) chopColors [] = [] chopColors (a:b:c:ds) = (ord a, ord b, ord c) : chopColors ds @@ -44,15 +44,15 @@ chop n xs = h : chop n t number = do ds <- many1 digit - return (read ds :: Int) + return (read ds :: Int) whiteSpace = skipMany (simpleSpace <|> oneLineComment <?> "") where simpleSpace = skipMany1 (oneOf " \t\n\r\v") - oneLineComment = - do char '#' - skipMany (noneOf "\n\r\v") - return () + oneLineComment = + do char '#' + skipMany (noneOf "\n\r\v") + return () -- printing diff --git a/testsuite/tests/programs/galois_raytrace/Surface.hs b/testsuite/tests/programs/galois_raytrace/Surface.hs index 832f0fcae2..ea706eb42f 100644 --- a/testsuite/tests/programs/galois_raytrace/Surface.hs +++ b/testsuite/tests/programs/galois_raytrace/Surface.hs @@ -53,42 +53,42 @@ evalSurface (SFun f) = f surface (Planar _ v0 v1) (n, p0, fn) = (norm, evalSurface fn n' u v) where norm = normalize $ cross v0 v1 - (n', u, v) = planarUV n p0 + (n', u, v) = planarUV n p0 surface (Spherical _ v0 v1) (_, p0, fn) = (norm, evalSurface fn 0 u v) where x = xCoord p0 - y = yCoord p0 - z = zCoord p0 - k = sqrt (1 - sq y) - theta = adjustRadian (atan2 (x / k) (z / k)) - -- correct so that the image grows left-to-right - -- instead of right-to-left - u = 1.0 - clampf (theta / (2 * pi)) - v = clampf ((y + 1) / 2) - norm = normalize $ cross v0 v1 + y = yCoord p0 + z = zCoord p0 + k = sqrt (1 - sq y) + theta = adjustRadian (atan2 (x / k) (z / k)) + -- correct so that the image grows left-to-right + -- instead of right-to-left + u = 1.0 - clampf (theta / (2 * pi)) + v = clampf ((y + 1) / 2) + norm = normalize $ cross v0 v1 -- ZZ ignore the (incorrect) surface model, and estimate the normal -- from the intersection in object space surface (Cylindrical _ v0 v1) (_, p0, fn) = (norm, evalSurface fn 0 u v) where x = xCoord p0 - y = yCoord p0 - z = zCoord p0 - u = clampf $ adjustRadian (atan2 x z) / (2 * pi) - v = y - norm = normalize $ cross v0 v1 + y = yCoord p0 + z = zCoord p0 + u = clampf $ adjustRadian (atan2 x z) / (2 * pi) + v = y + norm = normalize $ cross v0 v1 -- ZZ ignore the (incorrect) surface model, and estimate the normal -- from the intersection in object space surface (Conic _ v0 v1) (_, p0, fn) = (norm, evalSurface fn 0 u v) where x = xCoord p0 - y = yCoord p0 - z = zCoord p0 - u = clampf $ adjustRadian (atan2 (x / y) (z / y)) / (2 * pi) - v = y - norm = normalize $ cross v0 v1 + y = yCoord p0 + z = zCoord p0 + u = clampf $ adjustRadian (atan2 (x / y) (z / y)) / (2 * pi) + v = y + norm = normalize $ cross v0 v1 planarUV face p0 = case face of @@ -106,8 +106,8 @@ planarUV face p0 ConeBase -> (1, (x + 1) / 2, (z + 1) / 2) where x = xCoord p0 - y = yCoord p0 - z = zCoord p0 + y = yCoord p0 + z = zCoord p0 -- misc diff --git a/testsuite/tests/programs/joao-circular/Data_Lazy.hs b/testsuite/tests/programs/joao-circular/Data_Lazy.hs index d5ab24a9ca..71c5a49483 100644 --- a/testsuite/tests/programs/joao-circular/Data_Lazy.hs +++ b/testsuite/tests/programs/joao-circular/Data_Lazy.hs @@ -7,135 +7,135 @@ import LrcPrelude -- -- data P - = C_RootProd_1 !Defs - deriving (Show , Eq , Ord) + = C_RootProd_1 !Defs + deriving (Show , Eq , Ord) data Defs - = C_Defs2_1 !Def !Defs - | C_NoDefs_1 - deriving (Show , Eq , Ord) + = C_Defs2_1 !Def !Defs + | C_NoDefs_1 + deriving (Show , Eq , Ord) data Def - = C_Arraydecl_1 !Type !Name !INT - | C_Declfunc_1 !Type !Name !FormPars !Stats - | C_Declfunc_header_1 !Type !Name !FormPars !Stats - | C_Declfunc_header_novar_1 !Type !Name !FormPars !Stats - | C_Vardecl_1 !Type !Name - deriving (Show , Eq , Ord) + = C_Arraydecl_1 !Type !Name !INT + | C_Declfunc_1 !Type !Name !FormPars !Stats + | C_Declfunc_header_1 !Type !Name !FormPars !Stats + | C_Declfunc_header_novar_1 !Type !Name !FormPars !Stats + | C_Vardecl_1 !Type !Name + deriving (Show , Eq , Ord) data Type - = C_Booltype_1 - | C_Chartype_1 - | C_Errortype_1 - | C_Inttype_1 - | C_Realtype_1 - deriving (Show , Eq , Ord) + = C_Booltype_1 + | C_Chartype_1 + | C_Errortype_1 + | C_Inttype_1 + | C_Realtype_1 + deriving (Show , Eq , Ord) data Name - = C_Ident_1 !STR - deriving (Show , Eq , Ord) + = C_Ident_1 !STR + deriving (Show , Eq , Ord) data FormPars - = C_Emptyformpars_1 - | C_Lstformpars_1 !FormPar !FormPars - deriving (Show , Eq , Ord) + = C_Emptyformpars_1 + | C_Lstformpars_1 !FormPar !FormPars + deriving (Show , Eq , Ord) data FormPar - = C_Declformpar_1 !Type !Name - deriving (Show , Eq , Ord) + = C_Declformpar_1 !Type !Name + deriving (Show , Eq , Ord) data Stats - = C_Emptystat_1 - | C_Lststats_1 !Stat !Stats - deriving (Show , Eq , Ord) + = C_Emptystat_1 + | C_Lststats_1 !Stat !Stats + deriving (Show , Eq , Ord) data Stat - = C_ArrAssign_1 !ArrayUse !Exp - | C_Assign_1 !Name !Exp - | C_Funccall_1 !Name !ActPars - | C_If_t_e_1 !Exp !Stats !Stats - | C_Input_1 !Name - | C_LocalDecl_1 !Type !Name - | C_Print_1 !Exp - | C_While_1 !Exp !Stats - deriving (Show , Eq , Ord) + = C_ArrAssign_1 !ArrayUse !Exp + | C_Assign_1 !Name !Exp + | C_Funccall_1 !Name !ActPars + | C_If_t_e_1 !Exp !Stats !Stats + | C_Input_1 !Name + | C_LocalDecl_1 !Type !Name + | C_Print_1 !Exp + | C_While_1 !Exp !Stats + deriving (Show , Eq , Ord) data ArrayUse - = C_ArrayInd_1 !Name !Exp - deriving (Show , Eq , Ord) + = C_ArrayInd_1 !Name !Exp + deriving (Show , Eq , Ord) data Exp - = C_AddExp_1 !Exp !Exp - | C_AndExp_1 !Exp !Exp - | C_DivExp_1 !Exp !Exp - | C_EqExp_1 !Exp !Exp - | C_Factor_1 !Fac - | C_GTExp_1 !Exp !Exp - | C_LTExp_1 !Exp !Exp - | C_MinExp_1 !Exp - | C_MulExp_1 !Exp !Exp - | C_NotExp_1 !Exp - | C_OrExp_1 !Exp !Exp - | C_SubExp_1 !Exp !Exp - deriving (Show , Eq , Ord) + = C_AddExp_1 !Exp !Exp + | C_AndExp_1 !Exp !Exp + | C_DivExp_1 !Exp !Exp + | C_EqExp_1 !Exp !Exp + | C_Factor_1 !Fac + | C_GTExp_1 !Exp !Exp + | C_LTExp_1 !Exp !Exp + | C_MinExp_1 !Exp + | C_MulExp_1 !Exp !Exp + | C_NotExp_1 !Exp + | C_OrExp_1 !Exp !Exp + | C_SubExp_1 !Exp !Exp + deriving (Show , Eq , Ord) data Fac - = C_ArrayConst_1 !ArrayUse - | C_BoolConst_1 !BOOL - | C_CNIdent_1 !Name - | C_Expr_1 !Exp - | C_Funcinv_1 !Name !ActPars - | C_IntConst_1 !INT - | C_RealConst_1 !REAL - deriving (Show , Eq , Ord) + = C_ArrayConst_1 !ArrayUse + | C_BoolConst_1 !BOOL + | C_CNIdent_1 !Name + | C_Expr_1 !Exp + | C_Funcinv_1 !Name !ActPars + | C_IntConst_1 !INT + | C_RealConst_1 !REAL + deriving (Show , Eq , Ord) data ActPars - = C_Emptyactpars_1 - | C_Lstactpars_1 !Exp !ActPars - deriving (Show , Eq , Ord) + = C_Emptyactpars_1 + | C_Lstactpars_1 !Exp !ActPars + deriving (Show , Eq , Ord) data PPRoot - = C_All_1 !PPS - | C_Best_1 !PPS - deriving (Show , Eq , Ord) + = C_All_1 !PPS + | C_Best_1 !PPS + deriving (Show , Eq , Ord) data PPS - = C_Above_1 !PPS !PPS - | C_Apply_1 !PPC !PPSArgs - | C_Beside_1 !PPS !PPS - | C_Dup_1 !PPS !PPS - | C_Empty_1 - | C_FillBlock_1 !INT !FillList - | C_Filla_1 !FillList - | C_Indent_1 !INT !PPS - | C_Join_1 !PPS - | C_Text_1 !STR - deriving (Show , Eq , Ord) + = C_Above_1 !PPS !PPS + | C_Apply_1 !PPC !PPSArgs + | C_Beside_1 !PPS !PPS + | C_Dup_1 !PPS !PPS + | C_Empty_1 + | C_FillBlock_1 !INT !FillList + | C_Filla_1 !FillList + | C_Indent_1 !INT !PPS + | C_Join_1 !PPS + | C_Text_1 !STR + deriving (Show , Eq , Ord) data PPC - = C_AboveC_1 !PPC !PPC - | C_ApplyC_1 !PPC !PPCArgs - | C_BesideC_1 !PPC !PPC - | C_DupC_1 !PPC !PPC - | C_IndentC_1 !INT !PPC - | C_JoinC_1 !PPC - | C_ParC_1 - deriving (Show , Eq , Ord) + = C_AboveC_1 !PPC !PPC + | C_ApplyC_1 !PPC !PPCArgs + | C_BesideC_1 !PPC !PPC + | C_DupC_1 !PPC !PPC + | C_IndentC_1 !INT !PPC + | C_JoinC_1 !PPC + | C_ParC_1 + deriving (Show , Eq , Ord) data PPCArgs - = C_ConsPPCArgs_1 !PPC !PPCArgs - | C_NilPPCArgs_1 - deriving (Show , Eq , Ord) + = C_ConsPPCArgs_1 !PPC !PPCArgs + | C_NilPPCArgs_1 + deriving (Show , Eq , Ord) data PPSArgs - = C_ConsArgs_1 !PPS !PPSArgs - | C_NilArgs_1 - deriving (Show , Eq , Ord) + = C_ConsArgs_1 !PPS !PPSArgs + | C_NilArgs_1 + deriving (Show , Eq , Ord) data FillList - = C_ConsFillList_1 !PPS !FillList - | C_NilFillList_1 - deriving (Show , Eq , Ord) + = C_ConsFillList_1 !PPS !FillList + | C_NilFillList_1 + deriving (Show , Eq , Ord) -- @@ -147,108 +147,108 @@ type Code = [Instr] type CodeParams = [Code] data Disp - = C_Displ_1 !PPS - deriving (Show , Eq , Ord) + = C_Displ_1 !PPS + deriving (Show , Eq , Ord) data ENTRY - = C_Consarray_1 !Type !INT !INT - | C_Consfunc_1 !Type !INT !LSTPARAM - | C_Consvar_1 !Type !INT - | C_EmptyEntry_1 - deriving (Show , Eq , Ord) + = C_Consarray_1 !Type !INT !INT + | C_Consfunc_1 !Type !INT !LSTPARAM + | C_Consvar_1 !Type !INT + | C_EmptyEntry_1 + deriving (Show , Eq , Ord) type ERROR = [OneError] data Format - = C_Elem_1 !INT !INT !INT !Lst_Str - deriving (Show , Eq , Ord) + = C_Elem_1 !INT !INT !INT !Lst_Str + deriving (Show , Eq , Ord) type Formats = [Format] data Instr - = C_ALabel_1 !Name - | C_Add_1 - | C_And_1 - | C_Call_1 !Name - | C_Cod_1 - | C_Data_1 - | C_Div_1 - | C_Eq_1 - | C_Gt_1 - | C_Halt_1 - | C_IIn_1 - | C_IOut_1 - | C_Jump_1 !Name - | C_Jumpf_1 !Name - | C_Load_1 - | C_Lt_1 - | C_Minus_1 - | C_Mul_1 - | C_Neq_1 - | C_Not_1 - | C_Or_1 - | C_Pusha_1 !Name !INT - | C_Pushb_1 !BOOL - | C_Pushi_1 !INT - | C_Pushr_1 !REAL - | C_Ret_1 - | C_Store_1 - | C_Sub_1 - | C_Var_1 !Name !INT !Type - deriving (Show , Eq , Ord) + = C_ALabel_1 !Name + | C_Add_1 + | C_And_1 + | C_Call_1 !Name + | C_Cod_1 + | C_Data_1 + | C_Div_1 + | C_Eq_1 + | C_Gt_1 + | C_Halt_1 + | C_IIn_1 + | C_IOut_1 + | C_Jump_1 !Name + | C_Jumpf_1 !Name + | C_Load_1 + | C_Lt_1 + | C_Minus_1 + | C_Mul_1 + | C_Neq_1 + | C_Not_1 + | C_Or_1 + | C_Pusha_1 !Name !INT + | C_Pushb_1 !BOOL + | C_Pushi_1 !INT + | C_Pushr_1 !REAL + | C_Ret_1 + | C_Store_1 + | C_Sub_1 + | C_Var_1 !Name !INT !Type + deriving (Show , Eq , Ord) type LSTPARAM = [OneParam] type Lst_Str = [STR] data OneError - = C_E_FormParam_AD_1 !Name - | C_E_Fun_ND_1 !Name - | C_E_Loc_Name_AD_1 !Name - | C_E_Name_AD_1 !Name - | C_E_Name_ND_1 !Name - deriving (Show , Eq , Ord) + = C_E_FormParam_AD_1 !Name + | C_E_Fun_ND_1 !Name + | C_E_Loc_Name_AD_1 !Name + | C_E_Name_AD_1 !Name + | C_E_Name_ND_1 !Name + deriving (Show , Eq , Ord) data OneParam - = C_AParam_1 !Type !Name - deriving (Show , Eq , Ord) + = C_AParam_1 !Type !Name + deriving (Show , Eq , Ord) data OneTypeError - = C_E_T_ActParam_1 - | C_E_T_BOP_1 - | C_E_T_DT_1 !Name - | C_E_T_IndArrNotInt_1 - | C_E_T_NC_1 !Type !Type - | C_E_T_NotArithExp_1 - | C_E_T_NotBooleanExp_1 - | C_E_T_if_t_e_1 - | C_E_T_while_1 - | C_NoTypeError_1 - deriving (Show , Eq , Ord) + = C_E_T_ActParam_1 + | C_E_T_BOP_1 + | C_E_T_DT_1 !Name + | C_E_T_IndArrNotInt_1 + | C_E_T_NC_1 !Type !Type + | C_E_T_NotArithExp_1 + | C_E_T_NotBooleanExp_1 + | C_E_T_if_t_e_1 + | C_E_T_while_1 + | C_NoTypeError_1 + deriving (Show , Eq , Ord) data Pair_Formats - = C_C_Pair_Formats_1 !Formats !BOOL - deriving (Show , Eq , Ord) + = C_C_Pair_Formats_1 !Formats !BOOL + deriving (Show , Eq , Ord) data Pair_Lst_T_Errs - = C_CPair_Lst_T_Errs_1 !T_Errs !T_Errs - deriving (Show , Eq , Ord) + = C_CPair_Lst_T_Errs_1 !T_Errs !T_Errs + deriving (Show , Eq , Ord) data Pair_Lst_T_Fmts - = C_CPair_Lst_T_Fmts_1 !T_Fmts !T_Fmts - deriving (Show , Eq , Ord) + = C_CPair_Lst_T_Fmts_1 !T_Fmts !T_Fmts + deriving (Show , Eq , Ord) data Pair_Lst_T_Mins - = C_CPair_Lst_T_Mins_1 !T_Mins !T_Mins - deriving (Show , Eq , Ord) + = C_CPair_Lst_T_Mins_1 !T_Mins !T_Mins + deriving (Show , Eq , Ord) data Pair_T_Formats - = C_C_Pair_T_Formats_1 !T_Formats !BOOL - deriving (Show , Eq , Ord) + = C_C_Pair_T_Formats_1 !T_Formats !BOOL + deriving (Show , Eq , Ord) data Sizes - = C_Triple_1 !INT !INT !INT - deriving (Show , Eq , Ord) + = C_Triple_1 !INT !INT !INT + deriving (Show , Eq , Ord) type TYPES = [Type] @@ -257,13 +257,13 @@ type T_Errs = [BOOL] type T_Fmts = [T_Formats] data T_Formats - = C_AFormat_1 !Formats - | C_TFormats_1 !Formats !Formats !BOOL !BOOL - deriving (Show , Eq , Ord) + = C_AFormat_1 !Formats + | C_TFormats_1 !Formats !Formats !BOOL !BOOL + deriving (Show , Eq , Ord) data T_Frame - = C_F_1 !INT !INT - deriving (Show , Eq , Ord) + = C_F_1 !INT !INT + deriving (Show , Eq , Ord) type T_Mins = [Sizes] diff --git a/testsuite/tests/programs/jtod_circint/Signal.hs b/testsuite/tests/programs/jtod_circint/Signal.hs index 38a1fc86f5..9e5b7835aa 100644 --- a/testsuite/tests/programs/jtod_circint/Signal.hs +++ b/testsuite/tests/programs/jtod_circint/Signal.hs @@ -91,12 +91,12 @@ stake, sdrop :: Int -> Stream a -> Stream a stake 0 xs = xs --should be: stake (i+1) (Scons x xs) = Scons x (stake i xs) stake i (Scons x xs) | i < 0 = error "Signal.stake: < 0" - | otherwise = Scons x (stake (i-1) xs) + | otherwise = Scons x (stake (i-1) xs) sdrop 0 xs = xs --should be:sdrop (i+1) (Scons x xs) = sdrop i xs -sdrop i (Scons x xs) | i < 0 = error "Signal.sdrop: < 0" - | otherwise = sdrop i xs +sdrop i (Scons x xs) | i < 0 = error "Signal.sdrop: < 0" + | otherwise = sdrop i xs smap2 :: (a->b->c) -> Stream a -> Stream b -> Stream c smap2 f as bs = diff --git a/testsuite/tests/programs/lennart_range/Main.hs b/testsuite/tests/programs/lennart_range/Main.hs index c45e4b2b36..0f9bcfb641 100644 --- a/testsuite/tests/programs/lennart_range/Main.hs +++ b/testsuite/tests/programs/lennart_range/Main.hs @@ -7,11 +7,11 @@ Subject: ghc bug Some floating constants that are within the floating range -become wrong, e.g. +become wrong, e.g. - 1.82173691287639817263897126389712638972163e-300::Double + 1.82173691287639817263897126389712638972163e-300::Double - -- Lennart + -- Lennart PS. Maybe you use fromRational as defined in the Prelude? That won't do. It is badly broken, tell me if you want diff --git a/testsuite/tests/programs/lex/Main.hs b/testsuite/tests/programs/lex/Main.hs index 4c9a44802d..9c535643ea 100644 --- a/testsuite/tests/programs/lex/Main.hs +++ b/testsuite/tests/programs/lex/Main.hs @@ -2,8 +2,8 @@ module Main where main = interact ( \ s -> shows (lex' s) "\n") where lex' "" = [] - lex' s = tok : lex' s' where -- [(tok,s')] = lex s - (tok,s') = case lex s of - [r] -> r - [] -> error ("Empty: " ++ s) - other -> error ("Multi: " ++ s) + lex' s = tok : lex' s' where -- [(tok,s')] = lex s + (tok,s') = case lex s of + [r] -> r + [] -> error ("Empty: " ++ s) + other -> error ("Multi: " ++ s) diff --git a/testsuite/tests/programs/life_space_leak/Main.hs b/testsuite/tests/programs/life_space_leak/Main.hs index b794a3779a..f044ecf483 100644 --- a/testsuite/tests/programs/life_space_leak/Main.hs +++ b/testsuite/tests/programs/life_space_leak/Main.hs @@ -1,5 +1,5 @@ -------------------------------- --- The Game of Life -- +-- The Game of Life -- -------------------------------- generations x = 30 @@ -70,20 +70,20 @@ gen1 n board = map1 row1 (shift1 (copy1 n 0) board) row1 :: Tuple3 (L Int) (L Int) (L Int) -> L Int row1 (T3 last this next) - = zipWith31 elt1 (shift2 0 last) - (shift2 0 this) + = zipWith31 elt1 (shift2 0 last) + (shift2 0 this) (shift2 0 next) -elt1 :: Tuple3 Int Int Int - -> (Tuple3 Int Int Int) +elt1 :: Tuple3 Int Int Int + -> (Tuple3 Int Int Int) -> (Tuple3 Int Int Int) -> Int -elt1 (T3 a b c) (T3 d e f) (T3 g h i) +elt1 (T3 a b c) (T3 d e f) (T3 g h i) = if (not (eq tot 2)) && (not (eq tot 3)) then 0 else if (eq tot 3) then 1 else e - where tot = a `plus` b `plus` c `plus` d + where tot = a `plus` b `plus` c `plus` d `plus` f `plus` g `plus` h `plus` i eq :: Int -> Int -> Bool @@ -98,7 +98,7 @@ shiftr1 x xs = append2 (C1 x N) (init1 xs) shiftl1 :: L Int -> L (L Int) -> L (L Int) shiftl1 x xs = append2 (tail1 xs) (C1 x N) -shift1 :: L Int -> L (L Int) +shift1 :: L Int -> L (L Int) -> L (Tuple3 (L Int) (L Int) (L Int)) shift1 x xs = zip31 (shiftr1 x xs) xs (shiftl1 x xs) @@ -128,9 +128,9 @@ copy3 n x = C1 x (copy3 (n-1) x) -- Displaying one generation disp1 :: (Tuple2 (L Char) (L (L Int))) -> L Char -disp1 (T2 gen xss) - = append1 gen - (append1 (C1 '\n' (C1 '\n' N)) +disp1 (T2 gen xss) + = append1 gen + (append1 (C1 '\n' (C1 '\n' N)) (foldr_1 (glue1 (C1 '\n' N)) N (map4 (compose2 concat1 (map2 star1)) xss))) @@ -139,13 +139,13 @@ star1 i = case i of 0 -> C1 ' ' (C1 ' ' N) 1 -> C1 ' ' (C1 'o' N) -glue1 :: L Char -> L Char -> L Char -> L Char +glue1 :: L Char -> L Char -> L Char -> L Char glue1 s xs ys = append1 xs (append1 s ys) -- Generating and displaying a sequence of generations life1 :: Int -> L (L Int) -> L Char -life1 n xss +life1 n xss = foldr_1 (glue1 (copy3 (n+2) '\VT')) N (map5 disp1 (zip1_ (map6 (string_ListChar.show) (ints 0)) @@ -165,7 +165,7 @@ initial1 n xss = take1 n (append2 (map3 (compose1 (take2 n) (`append3` (copy1 n 0))) xss) (copy2 n (copy1 n 0))) -iterate1 :: (L (L Int) -> L (L Int)) +iterate1 :: (L (L Int) -> L (L Int)) -> L (L Int) -> L (L (L Int)) iterate1 f x = C1 x (iterate1 f (f x)) @@ -177,14 +177,14 @@ take1 0 _ = N take1 _ N = N --should be:take1 (n+1) (C1 x xs) = C1 x (take1 n xs) take1 n (C1 x xs) | n < 0 = error "Main.take1" - | otherwise = C1 x (take1 (n-1) xs) + | otherwise = C1 x (take1 (n-1) xs) take2 :: Int -> L Int -> L Int take2 0 _ = N take2 _ N = N --should be:take2 (n+1) (C1 x xs) = C1 x (take2 n xs) take2 n (C1 x xs) | n < 0 = error "Main.take2" - | otherwise = C1 x (take2 (n-1) xs) + | otherwise = C1 x (take2 (n-1) xs) take3 :: Int -> L (L (L Int)) -> L (L (L Int)) @@ -216,7 +216,7 @@ tail2 N = error "tail2 got a bad list" -- maps -map1 :: (Tuple3 (L Int) (L Int) (L Int) -> L Int) -> +map1 :: (Tuple3 (L Int) (L Int) (L Int) -> L Int) -> L (Tuple3 (L Int) (L Int) (L Int)) -> L (L Int) map1 f N = N @@ -235,7 +235,7 @@ map4 :: (L Int -> L Char) map4 f N = N map4 f (C1 x xs) = C1 (f x) (map4 f xs) -map5 :: (Tuple2 (L Char) (L (L Int)) -> L Char) +map5 :: (Tuple2 (L Char) (L (L Int)) -> L Char) -> L (Tuple2 (L Char) (L (L Int))) -> L (L Char) map5 f N = N @@ -247,12 +247,12 @@ map6 f (C1 x xs) = C1 (f x) (map6 f xs) -- compose -compose2 :: (L (L Char) -> L Char) - -> (L Int -> L (L Char)) +compose2 :: (L (L Char) -> L Char) + -> (L Int -> L (L Char)) -> L Int -> L Char compose2 f g xs = f (g xs) -compose1 :: (L Int -> L Int) +compose1 :: (L Int -> L Int) -> (L Int -> L Int) -> L Int -> L Int compose1 f g xs = f (g xs) @@ -263,7 +263,7 @@ concat1 = foldr_1 append1 N -- foldr -foldr_1 :: (L Char -> L Char -> L Char) +foldr_1 :: (L Char -> L Char -> L Char) -> L Char -> L (L Char) -> L Char foldr_1 f a N = a foldr_1 f a (C1 x xs) = f x (foldr_1 f a xs) @@ -297,26 +297,26 @@ zip1_ = pzip T2 zip2_ :: L (L Int) -> L (L Int) -> L (Tuple2 (L Int) (L Int)) -zip2_ = pzip T2 +zip2_ = pzip T2 -zip3d :: L Int -> (Tuple2 (L Int) (L Int)) +zip3d :: L Int -> (Tuple2 (L Int) (L Int)) -> (Tuple3 (L Int) (L Int) (L Int)) zip3d x (T2 y z) = T3 x y z -zip3_ :: L (L Int) +zip3_ :: L (L Int) -> L (Tuple2 (L Int) (L Int)) -> L (Tuple3 (L Int) (L Int) (L Int)) zip3_ = pzip zip3d zip4_ :: L Int - -> L Int + -> L Int -> L (Tuple2 Int Int) zip4_ = pzip T2 zip5d :: Int -> (Tuple2 Int Int) -> (Tuple3 Int Int Int) zip5d x (T2 y z) = T3 x y z -zip5_ :: L Int +zip5_ :: L Int -> L (Tuple2 Int Int) -> L (Tuple3 Int Int Int) zip5_ = pzip zip5d @@ -327,30 +327,30 @@ zip6_ :: L (Tuple3 Int Int Int) (Tuple3 Int Int Int)) zip6_ = pzip T2 -zip31 :: L (L Int) -> L (L Int) - -> L (L Int) +zip31 :: L (L Int) -> L (L Int) + -> L (L Int) -> L (Tuple3 (L Int) (L Int) (L Int)) zip31 as bs cs = zip3_ as (zip2_ bs cs) -zip32 :: L Int -> L Int -> L Int +zip32 :: L Int -> L Int -> L Int -> L (Tuple3 Int Int Int) zip32 as bs cs = zip5_ as (zip4_ bs cs) -- zipWith -zipWith21 :: ((Tuple3 Int Int Int) - -> (Tuple2 (Tuple3 Int Int Int) +zipWith21 :: ((Tuple3 Int Int Int) + -> (Tuple2 (Tuple3 Int Int Int) (Tuple3 Int Int Int)) -> Int) - -> L (Tuple3 Int Int Int) - -> L (Tuple2 (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple2 (Tuple3 Int Int Int) (Tuple3 Int Int Int)) -> L Int -zipWith21 = pzip +zipWith21 = pzip -zipWith31 :: ((Tuple3 Int Int Int) - -> (Tuple3 Int Int Int) +zipWith31 :: ((Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) -> (Tuple3 Int Int Int) -> Int) -> L (Tuple3 Int Int Int) -> L (Tuple3 Int Int Int) diff --git a/testsuite/tests/programs/maessen-hashtab/Data/HashTab.hs b/testsuite/tests/programs/maessen-hashtab/Data/HashTab.hs index 8251a760c8..e96d5c5efa 100644 --- a/testsuite/tests/programs/maessen-hashtab/Data/HashTab.hs +++ b/testsuite/tests/programs/maessen-hashtab/Data/HashTab.hs @@ -16,36 +16,36 @@ ----------------------------------------------------------------------------- module Data.HashTab ( - -- * Basic hash table operations - HashTable, new, insert, delete, lookup, update, - -- * Converting to and from lists - fromList, toList, - -- * Hash functions - -- $hash_functions - hashInt, hashString, - prime, - -- * Diagnostics - longestChain + -- * Basic hash table operations + HashTable, new, insert, delete, lookup, update, + -- * Converting to and from lists + fromList, toList, + -- * Hash functions + -- $hash_functions + hashInt, hashString, + prime, + -- * Diagnostics + longestChain ) where -- This module is imported by Data.Typeable, which is pretty low down in the -- module hierarchy, so don't import "high-level" modules -- Right now we import high-level modules with gay abandon. -import Prelude hiding ( lookup ) -import Data.Tuple ( fst ) +import Prelude hiding ( lookup ) +import Data.Tuple ( fst ) import Data.Bits import Data.Maybe -import Data.List ( maximumBy, partition, concat, foldl ) -import Data.Int ( Int32 ) +import Data.List ( maximumBy, partition, concat, foldl ) +import Data.Int ( Int32 ) import Data.Array.Base import Data.Array hiding (bounds) import Data.Array.IO -import Data.Char ( ord ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Control.Monad ( mapM, sequence_ ) +import Data.Char ( ord ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Control.Monad ( mapM, sequence_ ) ----------------------------------------------------------------------- @@ -81,11 +81,11 @@ newtype HashTable key val = HashTable (IORef (HT key val)) data HT key val = HT { - kcount :: !Int32, -- Total number of keys. - buckets :: !(HTArray [(key,val)]), + kcount :: !Int32, -- Total number of keys. + buckets :: !(HTArray [(key,val)]), bmask :: !Int32, - hash_fn :: key -> Int32, - cmp :: key -> key -> Bool + hash_fn :: key -> Int32, + cmp :: key -> key -> Bool } -- ----------------------------------------------------------------------------- @@ -151,7 +151,7 @@ hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation -- new :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys - -> (key -> Int32) -- ^ @hash@: A hash function on keys + -> (key -> Int32) -- ^ @hash@: A hash function on keys -> IO (HashTable key val) -- ^ Returns: an empty hash table new cmpr hash = do @@ -190,9 +190,9 @@ insert (HashTable ref) key val = do writeMutArray bkts' indx ((key,val):bucket) freezeArray bkts' table2 <- - if tooBig k b - then expandHashTable table1 - else return table1 + if tooBig k b + then expandHashTable table1 + else return table1 writeIORef ref table2 tooBig :: Int32 -> Int32 -> Bool @@ -280,9 +280,9 @@ update (HashTable ref) key val = do writeMutArray bkts' indx ((key,val):bucket') freezeArray bkts' table2 <- - if tooBig k' b -- off by one from insert's resize heuristic. - then expandHashTable table1 - else return table1 + if tooBig k' b -- off by one from insert's resize heuristic. + then expandHashTable table1 + else return table1 writeIORef ref table2 return (deleted>0) @@ -297,8 +297,8 @@ lookup (HashTable ref) key = do let indx = bucketIndex table key bucket <- readHTArray bkts indx case [ val | (key',val) <- bucket, cmpr key key' ] of - [] -> return Nothing - (v:_) -> return (Just v) + [] -> return Nothing + (v:_) -> return (Just v) -- ----------------------------------------------------------------------------- -- Converting to/from lists diff --git a/testsuite/tests/programs/record_upd/Main.hs b/testsuite/tests/programs/record_upd/Main.hs index 3b6b3ae2f9..0fd8e80ab6 100644 --- a/testsuite/tests/programs/record_upd/Main.hs +++ b/testsuite/tests/programs/record_upd/Main.hs @@ -1,25 +1,25 @@ -{- The purpose of this is to test that record update is - sufficiently polymorphic. See comments with - tcExpr (RecordUpd) in TcExpr.lhs +{- The purpose of this is to test that record update is + sufficiently polymorphic. See comments with + tcExpr (RecordUpd) in TcExpr.lhs -} module Main where data T a b c d = MkT1 { op1 :: a, op2 :: b } - | MkT2 { op1 :: a, op3 :: c } - | MkT3 { op4 :: a, op5 :: d } + | MkT2 { op1 :: a, op3 :: c } + | MkT3 { op4 :: a, op5 :: d } update1 :: a2 -> T a b c d -> T a2 b c d2 update1 x t = t { op1 = x } - -- NB: the MkT3.op4 case doesn't constrain the result because - -- it doesn't have an op1 field + -- NB: the MkT3.op4 case doesn't constrain the result because + -- it doesn't have an op1 field update2 :: a2 -> T a b c d -> T a2 b2 c2 d update2 x t = t { op4 = x } -main = print (op4 $ - update2 True $ - MkT3 { op4 = op2 $ - update1 (1::Int) $ - MkT1 { op1 = True } - }) +main = print (op4 $ + update2 True $ + MkT3 { op4 = op2 $ + update1 (1::Int) $ + MkT1 { op1 = True } + }) diff --git a/testsuite/tests/programs/rittri/Main.hs b/testsuite/tests/programs/rittri/Main.hs index e62c8a4667..1bc0203924 100644 --- a/testsuite/tests/programs/rittri/Main.hs +++ b/testsuite/tests/programs/rittri/Main.hs @@ -1,39 +1,39 @@ -infixr ->!,=\ +infixr ->!,=\ -- auxiliary functions ----------------------------------------------------- g u v w (x:y:z) = i(v x y)(u x y (w z) z)(x:w(y:z)) -g u v w [x] = [x,512] -q u v w nil = u : 95 : z v : w +g u v w [x] = [x,512] +q u v w nil = u : 95 : z v : w long = several.length ((->!),(=\))=(map,($)) -a = g q f -y = (-)32 -z = (+)32 -several = (>)2 +a = g q f +y = (-)32 +z = (+)32 +several = (>)2 fairlySmall = (<)64 notTooSmall = (>)91 justRight = (==)95 notTooBig = (<)96 -veryBig = (>)123 +veryBig = (>)123 goodSize x =foldr(&&) otherwise =\($x)->![notTooBig,veryBig] -f y z =fairlySmall(z)&&goodSize(y)&¬TooSmall(z) +f y z =fairlySmall(z)&&goodSize(y)&¬TooSmall(z) i cond th el=if(cond)then(th)else(el) toBeIsToDoAndToDoIsToBeSaidConFuTse -- main functions ---------------------------------------------------------- - g = interact$map - toEnum.g.map - fromEnum + g = interact$map + toEnum.g.map + fromEnum main = toBeIsToDoAndToDoIsToBeSaidConFuTse(let h=a;t=x where x x=i(long x)x(h t x) - q v w x z = - y w:x - a = g q f - f x y = justRight x - && goodSize y - in t) + q v w x z = - y w:x + a = g q f + f x y = justRight x + && goodSize y + in t) -- rittri@cs.chalmers.se --------------------------------------------------- diff --git a/testsuite/tests/programs/strict_anns/Main.hs b/testsuite/tests/programs/strict_anns/Main.hs index b2ee82d4bc..d9deac65f6 100644 --- a/testsuite/tests/programs/strict_anns/Main.hs +++ b/testsuite/tests/programs/strict_anns/Main.hs @@ -2,12 +2,12 @@ -- at least parse correctly. In GHC 2.02 they didn't! module Main where - + data Foo1 = Crunch1 ! Int ! Int Int deriving( Show ) data Foo2 = Crunch2 ! Int Int Int deriving( Show ) main = do - print (Crunch1 (1+1) (2+2) (3+3)) - print (Crunch2 (1+1) (2+2) (3+3)) - + print (Crunch1 (1+1) (2+2) (3+3)) + print (Crunch2 (1+1) (2+2) (3+3)) + diff --git a/testsuite/tests/programs/thurston-modular-arith/Main.hs b/testsuite/tests/programs/thurston-modular-arith/Main.hs index 608025b1e1..024c1dd6d2 100644 --- a/testsuite/tests/programs/thurston-modular-arith/Main.hs +++ b/testsuite/tests/programs/thurston-modular-arith/Main.hs @@ -1,25 +1,25 @@ {-# LANGUAGE UndecidableInstances, ExistentialQuantification, ScopedTypeVariables, Rank2Types #-} --- Modular arithmetic, due to Dale Thurston +-- Modular arithmetic, due to Dale Thurston -- Here's a way to mimic dependent types using existential types, -- illustrated by an implementation of modular arithmetic. To try it -- out, load modulus.hs and try something like --- inModulus (mkModulus (1234567890123::Integer)) (^ 98765432198765) 2 +-- inModulus (mkModulus (1234567890123::Integer)) (^ 98765432198765) 2 -- to compute 2 to the 98765432198765'th power modulo 1234567890123. -- The key is the definitions at the top of TypeVal.hs: --- +-- -- class TypeVal a t | t -> a where -- -- typeToVal should ignore its argument. -- typeToVal :: t -> a --- +-- -- data Wrapper a = forall t . (TypeVal a t) => Wrapper t --- +-- -- class ValToType a where -- valToType :: a -> Wrapper a --- +-- -- `valToType' takes a value `x' and returns a (wrapped version of a) -- fake value in a new type; from the new type, `x' can be recovered by -- applying typeToVal. @@ -45,13 +45,13 @@ data Modulus a = forall s. TypeVal a s => Modulus (a -> Mod s a) (Mod s a -> a) mkModulus :: (ValToType a, Integral a) => a -> Modulus a mkModulus x = case valToType x of {Wrapper (y :: t) -> - Modulus normalize (value :: Mod t a -> a)} + Modulus normalize (value :: Mod t a -> a)} normalize :: forall a s. (TypeVal a s, Integral a) => a -> Mod s a normalize x = (Mod (x `mod` typeToVal (undefined::s))) inModulus :: Modulus a -> (forall s . TypeVal a s => Mod s a -> Mod s a) - -> a -> a + -> a -> a inModulus (Modulus in_ out) f x = out (f (in_ x)) instance (TypeVal a s, Integral a) => Num (Mod s a) where diff --git a/testsuite/tests/programs/thurston-modular-arith/TypeVal.hs b/testsuite/tests/programs/thurston-modular-arith/TypeVal.hs index f1608a7dfe..8562d89482 100644 --- a/testsuite/tests/programs/thurston-modular-arith/TypeVal.hs +++ b/testsuite/tests/programs/thurston-modular-arith/TypeVal.hs @@ -48,18 +48,18 @@ instance (TypeVal Integer n) => TypeVal Integer (Dbl n) instance ValToType Integer where valToType n | n == 0 = Wrapper (undefined :: Zero) - | even n = - case valToType (div n 2) of {Wrapper x -> - case x of {(_ :: t) -> - Wrapper (undefined :: Dbl t)}} - | n > 0 = - case valToType (n-1) of {Wrapper x -> - case x of {(_ :: t) -> - Wrapper (undefined :: Succ t)}} - | n < 1 = - case valToType (n+1) of {Wrapper x -> - case x of {(_ :: t) -> - Wrapper (undefined :: Pred t)}} + | even n = + case valToType (div n 2) of {Wrapper x -> + case x of {(_ :: t) -> + Wrapper (undefined :: Dbl t)}} + | n > 0 = + case valToType (n-1) of {Wrapper x -> + case x of {(_ :: t) -> + Wrapper (undefined :: Succ t)}} + | n < 1 = + case valToType (n+1) of {Wrapper x -> + case x of {(_ :: t) -> + Wrapper (undefined :: Pred t)}} --- ValToType (a,b) --- Doesn't work. Perhaps a bug in ghc? @@ -69,8 +69,8 @@ instance ValToType Integer where --instance (ValToType a, ValToType b) => ValToType (a,b) where -- valToType (a,b) = case valToType a of {x -> --- case valToType b of {y -> --- Wrapper (x,y)}} +-- case valToType b of {y -> +-- Wrapper (x,y)}} data NIL a = Dummy20 instance TypeVal [a] (NIL a) @@ -82,8 +82,8 @@ instance (TypeVal [a] r, TypeVal a t) => TypeVal [a] (CONS t r) instance (ValToType a) => ValToType [a] where valToType [] = Wrapper (undefined::NIL a) valToType (x:xs) = case valToType x of {Wrapper x' -> - case x' of {(_::xt) -> - case valToType xs of {Wrapper xs' -> - case xs' of {(_::xst) -> - Wrapper (undefined::CONS xt xst)}}}} + case x' of {(_::xt) -> + case valToType xs of {Wrapper xs' -> + case xs' of {(_::xst) -> + Wrapper (undefined::CONS xt xst)}}}} |