ghc/tests/programs/jeff-bug/Signal.hs

   1 module Signal where
   2 import Monad
   3 import LazyST
   4 import List
   5 import Random
   6 import IOExts
   7 import Int
   8
   9 -- infixl 9 *!
  10
  11 -- Begin Signature -------------------------------------------------------
  12 {-
  13   In essence Hawk is Haskell with built-in Lustre-like signals.  The
  14   rest are libraries built upon this structure.  In the event of
  15   circuit synthesis, the Signal type and its operators represent
  16   the residule of elaboration (partial-evaluation).
  17 -}
  18
  19 {-data Signal a-}
  20
  21 infix  4 *==, */=, *<, *<=, *>=, *>
  22 infixr 3 *&&
  23 infixr 2 *||
  24 infixr 5  *:, *++
  25 infixl 9 `at`
  26 infixr 0 `delay`
  27 infixr 0 `before`
  28
  29 at     :: Signal a -> Int -> a
  30
  31 -- [1,3,2] `before` <10 .. > = <1,3,2,10 .. >
  32 before :: [a] -> Signal a -> Signal a
  33
  34 -- loop s f, apply f to s at each cycle, saving the state....
  35 loop   :: Signal a -> (a -> ST st c)-> ST st (Signal c)
  36
  37 view   :: Signal a -> [a]
  38
  39 -- delay x <x1,x2 .. >  = <x,x1,x2 .. >
  40 delay  :: a -> Signal a -> Signal a
  41
  42 -- if,then,else lifted on signals...
  43 cond   :: Signal Bool -> Signal a -> Signal a -> Signal a
  44
  45 -- apply a function pointwise to a signal
  46 lift0  :: a -> Signal a
  47 lift1  :: (a -> b) -> Signal a -> Signal b
  48 lift2  :: (a->b->c)          -> Signal a -> Signal b -> Signal c
  49 lift3  :: (a->b->c->d)       -> Signal a -> Signal b -> Signal c -> Signal d
  50 lift4  :: (a->b->c->d->e)    -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
  51 lift5  :: (a->b->c->d->e->f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
  52
  53 -- make a single signal of tuples out of tuple of signals
  54 bundle2 :: (Signal a,Signal b) -> Signal (a,b)
  55 bundle3 :: (Signal a,Signal b,Signal c) -> Signal (a,b,c)
  56 bundle4 :: (Signal a,Signal b,Signal c,Signal d) -> Signal (a,b,c,d)
  57 bundle5 :: (Signal a,Signal b,Signal c,Signal d,Signal e) -> Signal (a,b,c,d,e)
  58 bundle6 :: (Signal a,Signal b,Signal c,Signal d,Signal e,Signal f) ->
  59            Signal (a,b,c,d,e,f)
  60 bundleList :: [Signal a] -> Signal [a]
  61
  62 -- make a tuple of signals from a signal of tuples
  63 unbundle2 :: Signal (a,b)       -> (Signal a,Signal b)
  64 unbundle3 :: Signal (a,b,c)     -> (Signal a,Signal b,Signal c)
  65 unbundle4 :: Signal (a,b,c,e)   -> (Signal a,Signal b,Signal c,Signal e)
  66 unbundle5 :: Signal (a,b,c,e,d) ->
  67              (Signal a,Signal b,Signal c,Signal e,Signal d)
  68
  69 -- careful using this function.  the size of the list of the input
  70 -- must be the same at each cycle.
  71 unbundleList :: Signal [a] -> [Signal a]
  72
  73
  74 -- corresponding functions lifted on signals.
  75 (*==)           :: Eq a => Signal a -> Signal a -> Signal Bool
  76 (*/=)           :: Eq a => Signal a -> Signal a -> Signal Bool
  77 (*<)            :: Ord a => Signal a -> Signal a -> Signal Bool
  78 (*<=)           :: Ord a => Signal a -> Signal a -> Signal Bool
  79 (*>)            :: Ord a => Signal a -> Signal a -> Signal Bool
  80 (*>=)           :: Ord a => Signal a -> Signal a -> Signal Bool
  81 (*&&)           :: Signal Bool -> Signal Bool -> Signal Bool
  82 (*||)           :: Signal Bool -> Signal Bool -> Signal Bool
  83 (*++)           :: MonadPlus m => Signal (m a) -> Signal (m a) -> Signal (m a)
  84 (*:)            :: Signal a -> Signal [a] -> Signal [a]
  85
  86
  87 {-instance Eq a => Eq (Signal a)-}
  88 {-instance Ord a => Ord (Signal a)-}
  89 {-instance Enum a => Enum (Signal a)-}
  90 {-instance Bounded a => Bounded (Signal a)-}
  91 {-instance Num a => Num (Signal a)-}
  92 {-instance Real a => Real (Signal a)-}
  93 {-instance Integral a => Integral (Signal a)-}
  94 {-instance Functor Signal where-}
  95
  96 -- make the trivial superscalar circuit from a scalar circuit by
  97 -- applying it sequentially (left to right)
  98 superscalar :: (Signal a -> Signal b) -> Signal [a] -> Signal [b]
  99
 100 {-
 101    The following functions will give different streams for every use ----
 102    giving a form of non-determinism.
 103
 104    NOTE that these functions should be used carefully.  They
 105    break referential transparency
 106
 107 -}
 108
 109 ints :: (Int,Int) -> Signal Int
 110 integers :: (Integer,Integer) -> Signal Integer
 111 -- End Signature ------------------------------------------------------
 112
 113
 114
 115 -- End Signature -------------------------------------------------------
 116
 117
 118 delay i s = [i] `before` s
 119 cond x y z = lift3 (\x y z -> if x then y else z) x y z
 120
 121
 122
 123
 124 bundle2 (a,b)       = lift2 (,) a b
 125 bundle3 (a,b,c)     = lift3 (,,) a b c
 126 bundle4 (a,b,c,d)   = lift4 (,,,) a b c d
 127 bundle5 (a,b,c,d,e) = lift5 (,,,,) a b c d e
 128 bundle6 (a,b,c,d,e,f) = lift6 (,,,,,) a b c d e f
 129
 130 bundleList []     = lift0 []
 131 bundleList (s:ss) = lift2 (:) s (bundleList ss)
 132
 133 unbundle2 s = (a,b)
 134         where a = lift1 (\(x,_) -> x) s
 135               b = lift1 (\(_,x) -> x) s
 136 unbundle3 s = (a,b,c)
 137         where a = lift1 (\(x,_,_) -> x) s
 138               b = lift1 (\(_,x,_) -> x) s
 139               c = lift1 (\(_,_,x) -> x) s
 140 unbundle4 s = (a,b,c,d)
 141         where a = lift1 (\(x,_,_,_) -> x) s
 142               b = lift1 (\(_,x,_,_) -> x) s
 143               c = lift1 (\(_,_,x,_) -> x) s
 144               d = lift1 (\(_,_,_,x) -> x) s
 145 unbundle5 s = (a,b,c,d,e)
 146         where a = lift1 (\(x,_,_,_,_) -> x) s
 147               b = lift1 (\(_,x,_,_,_) -> x) s
 148               c = lift1 (\(_,_,x,_,_) -> x) s
 149               d = lift1 (\(_,_,_,x,_) -> x) s
 150               e = lift1 (\(_,_,_,_,x) -> x) s
 151
 152     -- not particularily safe....
 153 unbundleList s = map (nth s) szs
 154         where sz =  length $ head $ view s
 155               szs = [0 .. sz-1]
 156               nth s n = lift1 (!!n) s
 157
 158
 159
 160 instance Eq a => Eq (Signal a) where
 161     (==) = error "Cannot compare two signals for equality in general"
 162
 163 instance Ord a => Ord (Signal a) where
 164     compare = error "Cannot compare two signals in general"
 165     min     = lift2 min
 166     max     = lift2 max
 167
 168 instance Enum a => Enum (Signal a) where
 169     toEnum                = lift0 . toEnum
 170     fromEnum              = error "Trying to convert a Signal to an Enum"
 171     enumFrom              = unbundleList . lift1 enumFrom
 172     enumFromThen n m      = unbundleList $ lift2 enumFromThen n m
 173     enumFromTo n m        = unbundleList $ lift2 enumFromTo n m
 174     enumFromThenTo n n' m = unbundleList $ lift3 enumFromThenTo n n' m
 175
 176 instance Bounded a => Bounded (Signal a) where
 177     minBound = lift0 minBound
 178     maxBound = lift0 maxBound
 179
 180 instance Num a => Num (Signal a) where
 181     (+)         = lift2 (+)
 182     (-)         = lift2 (-)
 183     (*)         = lift2 (*)
 184     negate      = lift1 negate
 185     fromInteger = lift0 . fromInteger
 186     fromInt     = lift0 . fromInt
 187     abs         = lift1 abs
 188     signum      = lift1 signum
 189
 190 instance Real a => Real (Signal a) where
 191     toRational  = error "Trying to convert a signal to a Rational"
 192
 193 instance Integral a => Integral (Signal a) where
 194     quot        = lift2 quot
 195     rem         = lift2 rem
 196     div         = lift2 div
 197     mod         = lift2 mod
 198     x `quotRem` y       = unbundle2 (lift2 quotRem x y)
 199     x `divMod` y        = unbundle2 (lift2 divMod x y)
 200     toInteger   = error "Trying to convert a Signal to an Integer"
 201     toInt               = error "Trying to convert a Signal to an Int"
 202
 203
 204 ------------------------------------------------------------------
 205 -- definitons
 206
 207
 208
 209 (*==) = lift2 (==)
 210 (*/=) = lift2 (/=)
 211 (*<)  = lift2 (<)
 212 (*<=) = lift2 (<=)
 213 (*>)  = lift2 (>)
 214 (*>=) = lift2 (>=)
 215 (*&&) = lift2 (&&)
 216 (*||) = lift2 (||)
 217 (*++) = lift2 mplus
 218 (*:)  = lift2 (:)
 219
 220 data Then = Then
 221 data Else = Else
 222
 223 if' x Then y Else z = cond x y z
 224
 225 {-
 226 if' ~(Sig x) Then ~(Sig y) Else ~(Sig z) = Sig (cond x y z)
 227   where
 228    cond  ~(x:xs) ~(y:ys) ~(z:zs) =
 229           let v = if x then y else z
 230               vs = cond  xs ys zs
 231           in (v:vs)
 232 -}
 233
 234
 235 then' = Then
 236 else' = Else
 237
 238 ------------------------------------------------------------------------
 239 -- Specific to List implementation:
 240
 241
 242 newtype Signal a = List [a]
 243         deriving Show
 244
 245 instance Functor Signal where
 246   fmap f ~(List as) = List (map f as)
 247
 248
 249 at ~(List l) n = l!!n
 250 before l ~(List l') = List (l ++ l')
 251 loop ~(List l) f = do {l' <- mapM f l; return $ List l'}
 252
 253 lift0 x = List (repeat x)
 254
 255
 256 ----------------------------
 257 -- UGH!!  the lazy pattern matching found in lazyMap  is pretty important when
 258 -- using signals to communicate with closely timed mutually dependant
 259 -- signal transducers.  Probably, lazy versions of zipWith should be
 260 -- used too.
 261 ---  Byron , Sun Dec  6 16:46:09 PST 1998
 262
 263 lift1 f (List xs) = List $ lazyMap f xs
 264      where
 265      lazyMap f ~(x:xs) = f x :  lazyMap f xs
 266
 267 lift2 f ~(List as) ~(List bs)
 268      = List (zipWith f as bs)
 269
 270 lift3 f ~(List as) ~(List bs) ~(List cs)
 271      = List (zipWith3 f as bs cs)
 272
 273 lift4 f ~(List as) ~(List bs) ~(List cs) ~(List ds)
 274      = List (zipWith4 f as bs cs ds)
 275
 276 lift5 f ~(List as) ~(List bs) ~(List cs) ~(List ds) ~(List es)
 277      = List (zipWith5 f as bs cs ds es)
 278
 279 lift6 f ~(List as) ~(List bs) ~(List cs) ~(List ds) ~(List es) ~(List fs)
 280      = List (zipWith6 f as bs cs ds es fs)
 281
 282 view ~(List s) = s
 283
 284 superscalar f (List input) = List (chop lens output)
 285   where
 286   lens = map length input
 287   List output = f (List $ concat input)
 288   chop (n:ns) l = let (l',l'') = splitAt n l
 289                   in l' : chop ns l''
 290
 291
 292 ------------------------------------------------------------------------
 293 -- Non-determinism
 294
 295 -- integers :: (Integer,Integer) -> Signal Integer
 296 integers rng = List (unsafePerformIO (do { g <- newStdGen ;
 297                                            return (randomRs rng g) }))
 298
 299 ints = fmap toInt . integers . toIntegers
 300     where
 301     toIntegers (x,y) = (toInteger x,toInteger y)
 302
 303
 304