From 05368fd3e9523ab647897a427e99db1b02dfeb67 Mon Sep 17 00:00:00 2001 From: simonm Date: Wed, 3 Sep 1997 15:33:21 +0000 Subject: [PATCH] [project @ 1997-09-03 15:33:15 by simonm] Add David Barton's example which shows up a couple of bugs: -> not parsed correctly in interface files mangler bug when compiling with -monly-n-regs --- ghc/tests/programs/barton-mangler-bug/Basic.hs | 269 +++++++++++++++++ ghc/tests/programs/barton-mangler-bug/Bug.hs | 6 + ghc/tests/programs/barton-mangler-bug/Main.hs | 27 ++ ghc/tests/programs/barton-mangler-bug/Makefile | 7 + ghc/tests/programs/barton-mangler-bug/Physical.hs | 302 ++++++++++++++++++++ ghc/tests/programs/barton-mangler-bug/Plot.lhs | 86 ++++++ .../programs/barton-mangler-bug/PlotExample.lhs | 21 ++ .../barton-mangler-bug/TypesettingTricks.hs | 21 ++ 8 files changed, 739 insertions(+) create mode 100644 ghc/tests/programs/barton-mangler-bug/Basic.hs create mode 100644 ghc/tests/programs/barton-mangler-bug/Bug.hs create mode 100644 ghc/tests/programs/barton-mangler-bug/Main.hs create mode 100644 ghc/tests/programs/barton-mangler-bug/Makefile create mode 100644 ghc/tests/programs/barton-mangler-bug/Physical.hs create mode 100644 ghc/tests/programs/barton-mangler-bug/Plot.lhs create mode 100644 ghc/tests/programs/barton-mangler-bug/PlotExample.lhs create mode 100644 ghc/tests/programs/barton-mangler-bug/TypesettingTricks.hs diff --git a/ghc/tests/programs/barton-mangler-bug/Basic.hs b/ghc/tests/programs/barton-mangler-bug/Basic.hs new file mode 100644 index 0000000..e975f74 --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/Basic.hs @@ -0,0 +1,269 @@ +{-# OPTIONS -H12m #-} + +module Basic where +import TypesettingTricks +import Physical +--import GHC( (->) ) +infixr 7 |> +class Signal s where + mapSignal:: (Physical a, Physical b) => (s a b) -> a -> b + mapSigList:: (Physical a, Physical b) => (s a b) -> [a] -> [b] + toSig:: (Physical a, Physical b) => (s a b) -> SignalRep a b + mapSignal = mapSignal . toSig + mapSigList = map . mapSignal + toSig = FunctionRep . mapSignal +instance Signal (->) where + mapSignal f = f + toSig = FunctionRep +data {- (Physical a, Physical b) => -} SignalRep a b = + FunctionRep (a -> b) | + PieceContRep (PieceCont a b) + deriving (Eq, Show) +instance Signal SignalRep where + mapSignal (FunctionRep f) = mapSignal f + mapSignal (PieceContRep f) = mapSignal f + mapSigList (FunctionRep f) = mapSigList f + mapSigList (PieceContRep f) = mapSigList f + 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) -> + (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) -> + (a -> b) -> a -> b +unop op f t = toPhysical (op (fromPhysical (f t))) +instance (Physical a, Physical b) => Num (SignalRep a b) where + f + g = FunctionRep (binop (+) (mapSignal f) (mapSignal g)) + f * g = FunctionRep (binop (*) (mapSignal f) (mapSignal g)) + negate f = FunctionRep (unop negate (mapSignal f)) + abs f = FunctionRep (unop abs (mapSignal f)) + 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) => + 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) => + Floating (SignalRep a b) where + pi = FunctionRep (\t -> (toPhysical pi)) + exp f = FunctionRep (unop exp (mapSignal f)) + log f = FunctionRep (unop log (mapSignal f)) + sin f = FunctionRep (unop sin (mapSignal f)) + cos f = FunctionRep (unop cos (mapSignal f)) + asin f = FunctionRep (unop asin (mapSignal f)) + acos f = FunctionRep (unop acos (mapSignal f)) + atan f = FunctionRep (unop atan (mapSignal f)) + sinh f = FunctionRep (unop sinh (mapSignal f)) + cosh f = FunctionRep (unop cosh (mapSignal f)) + asinh f = FunctionRep (unop asinh (mapSignal f)) + acosh f = FunctionRep (unop acosh (mapSignal f)) + atanh f = FunctionRep (unop atanh (mapSignal f)) +data Event = + TimeEvent Float | + FunctionEvent (Float -> Bool) | + BurstEvent Int Event + deriving (Show) +instance Eq Event where + (TimeEvent x) == (TimeEvent y) = x == y + (BurstEvent i e) == (BurstEvent i' e') = (i' == i) && (e' == e) +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 = + if i == 1 then + eventOccurs e x + else + eventOccurs (BurstEvent (i-1) e) ((eventOccurs e x) + eventEps 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 = + Window ZeroIndicator Event (SignalRep a b) + deriving (Eq, Show) +data PieceCont a b = Windows [FunctionWindow a b] + deriving (Eq, Show) +instance Signal PieceCont where + mapSignal (Windows []) t = toPhysical 0.0 + 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 ] -> + (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) + 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 -> + PieceCont a b -> PieceCont a b +w |> (Windows wl) = Windows (w:wl) +nullWindow = Windows [] +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) => + 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)) + (linear (stepSlope v v') v) + points = cycle ampls + in PieceContRep (Windows (map makeWin (zip points (tail points)))) +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 = + 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 +triangle per v = + let sl = realmul 2.0 (realdiv (fromPhysical v) (fromPhysical per)) + qper = realdiv (fromPhysical v) 4.0 + wins = (Window LocalZero (TimeEvent qper) (linear sl (toPhysical 0.0))) |> + (Window LocalZero (TimeEvent (realmul 2.0 qper)) (linear (- sl) v)) |> + (Window LocalZero (TimeEvent qper) (linear sl (toPhysical (- (fromPhysical v))))) |> + nullWindow + in PieceContRep (cycleWindows wins) +step:: (Physical a, Physical b) => a -> b -> SignalRep a b +step tr lvl = FunctionRep (\t -> if (fromPhysical t) < (fromPhysical tr) then (toPhysical 0.0) else lvl) +square:: (Physical a, Physical b) => a -> b -> SignalRep a b +square per lvl = + let trans = realdiv (fromPhysical per) 2.0 + nlvl = asTypeOf (toPhysical (- (fromPhysical lvl))) lvl + f t = if (fromPhysical t) < trans then lvl else nlvl + wins = Windows [Window LocalZero (TimeEvent (fromPhysical per)) (FunctionRep f)] + in PieceContRep (cycleWindows wins) +pulse:: (Physical a, Physical b) => a -> a -> b -> SignalRep a b +pulse st wid lvl = + let tr = (fromPhysical st) + (fromPhysical wid) + 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 -> + SignalRep a b +trap st r wid f lvl = + let stepSlope y y' t = realdiv (y' - y) (fromPhysical t) + bigwin = realmul 10000000 ((fromPhysical st) + (fromPhysical wid)) + wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |> + Window LocalZero (TimeEvent (fromPhysical r)) (linear (stepSlope 0.0 (fromPhysical lvl) r) (toPhysical 0.0)) |> + Window LocalZero (TimeEvent (fromPhysical wid)) (constant lvl) |> + Window LocalZero (TimeEvent (fromPhysical f)) (linear (stepSlope (fromPhysical lvl) 0.0 f) lvl) |> + Window LocalZero (TimeEvent bigwin) (constant (toPhysical 0.0)) |> + nullWindow + in PieceContRep wins +expc:: (Physical a, Physical b) => Float -> SignalRep a b +expc damp = FunctionRep (\t -> toPhysical (exp (- (realmul (fromPhysical t) damp)))) +data {- (Physical indep, Physical dep) => -} BasicSignal indep dep = + Overshoot {start_delay::indep, + pulse_width::indep, + ringing::dep, + oscillation::Frequency, + damp_fac::Float} + | Pulse_dc {start_delay::indep, + pulse_width::indep, + rise_time::indep, + fall_time::indep, + period::indep, + dc_offset::dep, + amplitude::dep, + over::BasicSignal indep dep, + under::BasicSignal indep dep} + | Pulse_ac {start_delay::indep, + pulse_width::indep, + period::indep, + dc_offset::dep, + amplitude::dep, + frequency::Frequency, + phase::Float} + deriving (Eq, Show) + +data {- (Eq a, Eq b) => -} Foo a b = Foo { x :: a, y :: b} + +foo :: (Eq a, Eq b) => Foo a b +foo = Foo{} + +{- +overshoot:: (Physical a, Physical b) => BasicSignal a b +overshoot = Overshoot{} +pulse_dc:: (Physical a, Physical b) => BasicSignal a b +pulse_dc = Pulse_dc {over = Overshoot{start_delay=toPhysical 0.0, + ringing=(toPhysical 0.0), + oscillation=toPhysical 1.0, + damp_fac=1.0}, + under = Overshoot{start_delay=toPhysical 0.0, + ringing=(toPhysical 0.0), + oscillation=toPhysical 1.0, + damp_fac=1.0}, + start_delay = toPhysical 0.0, + dc_offset = toPhysical 0.0} + +pulse_ac:: (Physical a, Physical b) => BasicSignal a b +pulse_ac = Pulse_ac {dc_offset = toPhysical 0.0, + amplitude = toPhysical 0.0} +-} + +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)) |> + Window LocalZero (TimeEvent (fromPhysical wid)) sig |> + nullWindow + in PieceContRep wins +instance Signal BasicSignal where + toSig Overshoot{start_delay,pulse_width, + ringing,oscillation,damp_fac} = + 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 -> + SignalRep a b -> SignalRep a b + temp f g = FunctionRep (binop (*) (mapSignal f) (mapSignal g)) +-- temp f g = f * g +-- temp f g = asTypeOf (f * g) ring + wins = Window LocalZero (TimeEvent (fromPhysical start_delay)) (constant (toPhysical 0.0)) |> + Window LocalZero (TimeEvent (fromPhysical pulse_width)) sig |> + nullWindow + in PieceContRep wins + toSig Pulse_dc{start_delay,rise_time,pulse_width,fall_time, + dc_offset,period,amplitude,over,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 -> + SignalRep a b -> SignalRep a b + temp f g = FunctionRep (binop (+) (mapSignal f) (mapSignal g)) + sig = temp (temp (temp pul oversh) undersh) off + wins = (Window LocalZero (TimeEvent (fromPhysical period)) sig) |> + nullWindow + 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' = + 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' = + let f1 t = fromPhysical (mapSignal f t) + f2 t = fromPhysical (mapSignal f' t) + in FunctionRep (\t -> toPhysical ((f1 t) * (f2 t))) + +eventEps:: Float -> Float +eventEps x = let eps = realdiv x 1000 in if 0.01 < eps then 0.01 else eps diff --git a/ghc/tests/programs/barton-mangler-bug/Bug.hs b/ghc/tests/programs/barton-mangler-bug/Bug.hs new file mode 100644 index 0000000..0f75dff --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/Bug.hs @@ -0,0 +1,6 @@ +module Bug where + +data Eq a => Foo a = Foo { x :: a } + +foo :: Foo Int +foo = Foo{} diff --git a/ghc/tests/programs/barton-mangler-bug/Main.hs b/ghc/tests/programs/barton-mangler-bug/Main.hs new file mode 100644 index 0000000..a97f289 --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/Main.hs @@ -0,0 +1,27 @@ +module Main where +import Physical +import Basic +import TypesettingTricks +import PlotExample +sinExample:: SignalRep Time Voltage +sinExample = sine (V 2.0) (Hz 10) 0.0 +sinPlot = plotExample "sine" sinExample 0.0 1.0 +pieceExample = toSig Pulse_dc + { start_delay=(Sec 1.0), + rise_time=(Sec 0.2), + pulse_width=(Sec 3.0), + fall_time=(Sec 0.3), + dc_offset=(V (- 1.0)), + period=(Sec 10.0), + amplitude=(V 5.0), + over=Overshoot{ringing=(V 0.2), + pulse_width=(Sec 3.0), + oscillation=(Hz 2.0), + damp_fac=1.0}, + under=Overshoot{ringing=(V (- 0.25)), + pulse_width=(Sec 3.0), + oscillation=(Hz 2.10), + damp_fac=1.10} } +piecePlot = plotExample "piece" pieceExample 0.0 20.0 +main = sinPlot >> + piecePlot diff --git a/ghc/tests/programs/barton-mangler-bug/Makefile b/ghc/tests/programs/barton-mangler-bug/Makefile new file mode 100644 index 0000000..de6e7e0 --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/Makefile @@ -0,0 +1,7 @@ +TOP = ../.. +include $(TOP)/mk/boilerplate.mk + +all :: runtest + +include $(TOP)/mk/target.mk + diff --git a/ghc/tests/programs/barton-mangler-bug/Physical.hs b/ghc/tests/programs/barton-mangler-bug/Physical.hs new file mode 100644 index 0000000..91981e0 --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/Physical.hs @@ -0,0 +1,302 @@ +module Physical where +import TypesettingTricks +class (Eq a, Show a) => Physical a where + fromPhysical:: a -> Float + toPhysical:: Float -> a +instance Physical Float where + fromPhysical x = x + toPhysical x = x +data PlaneAngle = + Rad Float | + Mrad Float | + Urad Float | + Deg Float | + Rev Float + deriving (Eq, Show) +instance Physical PlaneAngle where + fromPhysical (Rad x) = x + fromPhysical (Mrad x) = realdiv x 1000 + fromPhysical (Urad x) = realdiv x 1000000 + fromPhysical (Deg x) = realdiv (realmul x pi) 180 + fromPhysical (Rev x) = realdiv x (realmul 2.0 pi) + toPhysical x = Rad x +data SolidAngle = + Sr Float | + Msr Float + deriving (Eq, Show) +instance Physical SolidAngle where + fromPhysical (Sr x) = x + fromPhysical (Msr x) = realdiv x 1000 + toPhysical x = Sr x +data BurstLength = + Cycle Float | + Pulse Float + deriving (Eq, Show) +instance Physical BurstLength where + fromPhysical (Cycle x) = x + fromPhysical (Pulse x) = x + toPhysical x = Cycle x +data Capacitance = + Fd Float | + Ufd Float | + Nfd Float | + Pfd Float + deriving (Eq, Show) +instance Physical Capacitance where + fromPhysical (Fd x) = x + fromPhysical (Ufd x) = realdiv x 1000000 + fromPhysical (Nfd x) = realdiv x 1000000000 + fromPhysical (Pfd x) = realdiv x 1000000000000 + toPhysical x = Fd x +data Charge = + C Float | + Kc Float | + Uc Float | + Nc Float + deriving (Eq, Show) +instance Physical Charge where + fromPhysical (C x) = x + fromPhysical (Kc x) = realmul 1000 x + fromPhysical (Uc x) = realdiv x 1000000 + fromPhysical (Nc x) = realdiv x 1000000000 + toPhysical x = C x +data Current = + A Float | + Ka Float | + Ma Float | + Ua Float | + Na Float + deriving (Eq, Show) +instance Physical Current where + fromPhysical (A x) = x + fromPhysical (Ka x) = realmul 1000 x + fromPhysical (Ma x) = realdiv x 1000 + fromPhysical (Ua x) = realdiv x 1000000 + fromPhysical (Na x) = realdiv x 1000000000 + toPhysical x = A x +data Distance = + M Float | + Km Float | + Mm Float | + Um Float | + Nm Float | + In Float | + Ft Float | + SMi Float | + NMi Float + deriving (Eq, Show) +instance Physical Distance where + fromPhysical (M x) = x + fromPhysical (Km x) = realmul 1000 x + fromPhysical (Mm x) = realdiv x 1000 + fromPhysical (Um x) = realdiv x 1000000 + fromPhysical (Nm x) = realdiv x 1000000000 + fromPhysical (In x) = realmul 25.4 x + fromPhysical (Ft x) = realmul 2.12 x + fromPhysical (SMi x) = realdiv x 2490.57 + fromPhysical (NMi x) = realdiv x 1825 + toPhysical x = M x +data Energy = + J Float | + Kj Float | + Mj Float | + Ev Float | + Kev Float | + Mev Float + deriving (Eq, Show) +instance Physical Energy where + fromPhysical (J x) = x + fromPhysical (Kj x) = realmul 1000 x + fromPhysical (Mj x) = realdiv x 1000 + fromPhysical (Ev x) = realmul 1.6E-19 x + fromPhysical (Kev x) = realmul 1.6E-16 x + fromPhysical (Mev x) = realmul 1.6E-13 x + toPhysical x = J x +data MagFlux = + Wb Float | + Mwb Float + deriving (Eq, Show) +instance Physical MagFlux where + fromPhysical (Wb x) = x + fromPhysical (Mwb x) = realdiv x 1000 + toPhysical x = Wb x +data FluxDensity = + T Float | + Mt Float | + Ut Float | + Gam Float + deriving (Eq, Show) +instance Physical FluxDensity where + fromPhysical (T x) = x + fromPhysical (Mt x) = realdiv x 1000 + fromPhysical (Ut x) = realdiv x 1000000 + fromPhysical (Gam x) = realdiv x 1000000000 + toPhysical x = T x +data Force = + N Float | + Kn Float | + Mn Float | + Un Float + deriving (Eq, Show) +instance Physical Force where + fromPhysical (N x) = x + fromPhysical (Kn x) = realmul 1000 x + fromPhysical (Mn x) = realdiv x 1000 + fromPhysical (Un x) = realdiv x 1000000 + toPhysical x = N x +data Frequency = + Hz Float | + Khz Float | + Mhz Float | + Ghz Float + deriving (Eq, Show) +instance Physical Frequency where + fromPhysical (Hz x) = x + fromPhysical (Khz x) = realmul 1000 x + fromPhysical (Mhz x) = realmul 1000000 x + fromPhysical (Ghz x) = realmul 1000000000 x + toPhysical x = Hz x +data Illuminance = + Lx Float + deriving (Eq, Show) +instance Physical Illuminance where + fromPhysical (Lx x) = x + toPhysical x = Lx x +data Inductance = + H Float | + Mh Float | + Uh Float | + Nh Float | + Ph Float + deriving (Eq, Show) +instance Physical Inductance where + fromPhysical (H x) = x + fromPhysical (Mh x) = realdiv x 1000 + fromPhysical (Uh x) = realdiv x 1000000 + fromPhysical (Nh x) = realdiv x 1000000000 + fromPhysical (Ph x) = realdiv x 1000000000000 + toPhysical x = H x +data Luminance = + Nt Float + deriving (Eq, Show) +instance Physical Luminance where + fromPhysical (Nt x) = x + toPhysical x = Nt x +data LuminFlux = + Lm Float + deriving (Eq, Read, Show) +instance Physical LuminFlux where + fromPhysical (Lm x) = x + toPhysical x = Lm x +data LuminInten = + Cd Float + deriving (Eq, Read, Show) +instance Physical LuminInten where + fromPhysical (Cd x) = x + toPhysical x = Cd x +data Mass = + Kg Float | + G Float | + Mg Float | + Ug Float + deriving (Eq, Show) +instance Physical Mass where + fromPhysical (Kg x) = x + fromPhysical (G x) = realdiv x 1000 + fromPhysical (Mg x) = realdiv x 1000000 + fromPhysical (Ug x) = realdiv x 1000000000 + toPhysical x = Kg x +data Power = + W Float | + Kw Float | + Mw Float | + Uw Float + deriving (Eq, Show) +instance Physical Power where + fromPhysical (W x) = x + fromPhysical (Kw x) = realmul 1000 x + fromPhysical (Mw x) = realdiv x 1000 + fromPhysical (Uw x) = realdiv x 1000000 + toPhysical x = W x +data Pressure = + Pa Float | + Kpa Float | + Mpa Float | + Upa Float | + Mb Float + deriving (Eq, Show) +instance Physical Pressure where + fromPhysical (Pa x) = x + fromPhysical (Kpa x) = realmul 1000 x + fromPhysical (Mpa x) = realdiv x 1000 + fromPhysical (Upa x) = realdiv x 1000000 + fromPhysical (Mb x) = realmul 100 x + toPhysical x = Pa x +data Pulse = + Pulses Float + deriving (Eq, Show) +instance Physical Pulse where + fromPhysical (Pulses x) = x + toPhysical x = Pulses x +data RatioInOut = + Db Float + deriving (Eq, Show) +instance Physical RatioInOut where + fromPhysical (Db x) = x + toPhysical x = Db x +data Resistance = + Ohm Float | + Kohm Float | + Mohm Float + deriving (Eq, Show) +instance Physical Resistance where + fromPhysical (Ohm x) = x + fromPhysical (Kohm x) = realmul 1000 x + fromPhysical (Mohm x) = realmul 1000000 x + toPhysical x = Ohm x +data Temperature = + Degk Float | + Degc Float | + Degf Float + deriving (Eq, Show) +instance Physical Temperature where + fromPhysical (Degk x) = x + fromPhysical (Degc x) = x + 273 + fromPhysical (Degf x) = (realdiv (realmul 5 (x-32)) 9) + 273 + toPhysical x = Degk x +data Time = + Sec Float | + Msec Float | + Usec Float | + Nsec Float | + Min Float | + Hr Float + deriving (Eq, Show) +instance Physical Time where + fromPhysical (Sec x) = x + fromPhysical (Msec x) = realdiv x 1000 + fromPhysical (Usec x) = realdiv x 1000000 + fromPhysical (Nsec x) = realdiv x 1000000000 + fromPhysical (Min x) = realmul 60 x + fromPhysical (Hr x) = realmul 3600 x + toPhysical x = Sec x +data Voltage = + V Float | + Kv Float | + Mv Float | + Uv Float + deriving (Eq, Show) +instance Physical Voltage where + fromPhysical (V x) = x + fromPhysical (Kv x) = realmul 1000 x + fromPhysical (Mv x) = realdiv x 1000 + fromPhysical (Uv x) = realdiv x 1000000 + toPhysical x = V x +data Volume = + L Float | + Ml Float + deriving (Eq, Show) +instance Physical Volume where + fromPhysical (L x) = x + fromPhysical (Ml x) = realdiv x 1000 + toPhysical x = L x diff --git a/ghc/tests/programs/barton-mangler-bug/Plot.lhs b/ghc/tests/programs/barton-mangler-bug/Plot.lhs new file mode 100644 index 0000000..f197eeb --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/Plot.lhs @@ -0,0 +1,86 @@ +The functions in this file (well, the single function) will allow the +user to plot different functions using the Gnuplot program. In fact, +all it really does is output a number of points on the list and allow +the user to activate Gnuplot and use the plotting program to get the +appropriate output. + +The first line just gives the module name. For the moment, I don't +anticipate using any modules (although this may change). + +> module Plot where +> import IO + +Now we give the type of the function. This consists of a file name, a +list of values, and a function that goes from the appropriate types. + +> plot2d:: (Show a, Show b) => String -> [a] -> (a -> b) -> IO() +> plot2d fl inp f = openFile fl WriteMode >>= \flh -> +> plot2d' flh inp f >> +> hClose flh + +> plot2d':: (Show a, Show b) => Handle -> [a] -> (a -> b) -> IO() +> plot2d' fl [] f = return () +> plot2d' fl (x:xs) f = hPutStr fl (show x) >> +> hPutStr fl " " >> +> hPutStr fl (show (f x)) >> +> hPutStr fl "\n" >> +> plot2d' fl xs f + +> plot3d:: (Show a, Show b, Show c) => String -> [a] -> [b] -> +> (a -> b -> c) -> IO() +> plot3d fl inp1 inp2 f = openFile fl WriteMode >>= \flh -> +> plot3d' flh inp1 inp2 f >> +> hClose flh + +> plot3d':: (Show a, Show b, Show c) => Handle -> [a] -> [b] -> +> (a -> b -> c) -> IO() +> plot3d' fl [] inp f = return () +> plot3d' fl (x:xs) inp f = plot3d'' fl x inp f >> +> hPutStr fl "\n" >> +> plot3d' fl xs inp f + +> plot3d'':: (Show a, Show b, Show c) => Handle -> a -> [b] -> +> (a -> b -> c) -> IO() +> plot3d'' fl inp [] f = return () +> plot3d'' fl x (y:ys) f = hPutStr fl (show x) >> +> hPutStr fl " " >> +> hPutStr fl (show y) >> +> hPutStr fl " " >> +> hPutStr fl (show (f x y)) >> +> hPutStr fl "\n" >> +> plot3d'' fl x ys f + + +And now, let's create a function to make a range out of a triple of a +start point, an end point, and an increment. + +> createRange:: (Num a, Ord a) => a -> a -> a -> [a] +> createRange s e i = if s > e then [] +> else s : createRange (s+i) e i + +We now settle down to a couple of more specific functions that do +things that are more unique to gnuplot. First, we have something that +creates the appropriate gnuplot command file. + +> createGnuPlot:: Show a => String -> a -> a -> IO() +> createGnuPlot fl s e = openFile (fl ++ ".gnp") WriteMode >>= \flh -> +> hPutStr flh "set terminal latex\n" >> +> hPutStr flh "set output \"" >> +> hPutStr flh (fl ++ ".tex\"\n") >> +> hPutStr flh "set nokey\n" >> +> hPutStr flh "plot [" >> +> hPutStr flh (show s) >> +> hPutStr flh ":" >> +> hPutStr flh (show e) >> +> hPutStr flh "] \"" >> +> hPutStr flh (fl ++ ".plt\"") >> +> hPutStr flh " with lines\n" >> +> hClose flh + +And now we create a fairly specific plotExam function that takes a +string, a function, and two floats and produces the correct files + +> plotExam:: String -> Float -> Float -> (Float -> Float) -> IO() +> plotExam fl s e f = plot2d (fl++".plt") r f >> +> createGnuPlot fl s e +> where r = createRange s e ((e - s) / 2500) diff --git a/ghc/tests/programs/barton-mangler-bug/PlotExample.lhs b/ghc/tests/programs/barton-mangler-bug/PlotExample.lhs new file mode 100644 index 0000000..cc7a993 --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/PlotExample.lhs @@ -0,0 +1,21 @@ +This file contains code that is explicitly designed to plot examples +from the signal modeling language. + +> module PlotExample where + +> import Plot +> import Physical +> import Basic + +Our main task is to take a signal and a begin and start point (both +reals) and convert it into something that plotExam can take in the +Plot module. + +> plotExample:: (Signal s, Physical a, Physical b) => +> String -> s a b -> Float -> Float -> IO() +> plotExample fl sig s e = plotExam fl s e f +> where f = toFloatFunc f' +> f' = mapSignal sig + +> toFloatFunc:: (Physical a, Physical b) => (a -> b) -> Float -> Float +> toFloatFunc f x = fromPhysical (f (toPhysical x)) diff --git a/ghc/tests/programs/barton-mangler-bug/TypesettingTricks.hs b/ghc/tests/programs/barton-mangler-bug/TypesettingTricks.hs new file mode 100644 index 0000000..446e4e8 --- /dev/null +++ b/ghc/tests/programs/barton-mangler-bug/TypesettingTricks.hs @@ -0,0 +1,21 @@ +-- The functions in this file are expressly for the purpose of aiding +-- the typesetting of some functions with Smugweb. To this end, in +-- some cases I will use named, prefix functions rather than operators +-- (since under Smugweb operators cannot accept arguments). This file +-- will define those infix functions. + +module TypesettingTricks where + +realdiv:: Floating a => a -> a -> a +realdiv = (/) + +realmul:: Num a => a -> a -> a +realmul = (*) + +dotmul:: Num a => a -> a -> a +dotmul = (*) + +rand:: Integer -> [ Float ] +rand i = r : rand i' + where i' = ( (3146757 * i) + 1731) `mod` 4194304 + r = (fromInteger i') / 4194304.0 -- 1.7.10.4