1 {-
    2         This module defines a Normal cless and a function normal
    3         used for forcing evaluation.  The idea is originally
    4         from Colin and has been modified to do recursive
    5         force evaluation.  To prevent repeated force, the
    6         expression to be forced should be packed with a flag
    7         indicating if a force has been done.  Functions
    8         which support this idea are provided.
    9 
   10         XZ, 19/2/92
   11 -}
   12 
   13 module Norm where
   14 
   15 {-
   16                class Normal
   17 -}
   18 
   19 infixr 3 `andAnd` -- partain
   20 andAnd a b = if a then
   21                 if b then True
   22                      else error "andAnd: 2nd argument not True"
   23              else
   24                 error "andAnd: first argument not True\n"
   25 -- end partain
   26 
   27 data (Normal a) => Norm_able a = Norm_pack Bool a deriving ()
   28 
   29 class Normal a where
   30         normal :: a -> Bool
   31 
   32 instance (Normal a) => Normal [a] where
   33         normal (x:xs) = normal x `andAnd` normal xs
   34         normal _ = True
   35 
   36 instance (Normal a, Normal b) => Normal (a,b) where
   37         normal (x,y) = normal x `andAnd` normal y
   38 
   39 instance (Normal a, Normal b, Normal c) => Normal (a,b,c) where
   40         normal (x,y,z) = normal x `andAnd` normal y `andAnd` normal z
   41 
   42 instance
   43         (Normal a, Normal b, Normal c,
   44          Normal d, Normal e, Normal f) =>
   45         Normal (a,b,c,d,e,f) where
   46         normal (x,y,z,u,v,w) =
   47                 normal x `andAnd` normal y `andAnd` normal z `andAnd`
   48                 normal u `andAnd` normal v `andAnd` normal w
   49 
   50 {- not in 1.3:
   51 instance (Normal a, Normal b) =>
   52         Normal (Assoc a b) where
   53         normal (i:=v) = normal i `andAnd` normal v
   54 -}
   55 
   56 instance Normal Bool where
   57         normal True = True
   58         normal _ = True
   59 
   60 instance Normal Int where
   61         normal 0 = True
   62         normal _ = True
   63 
   64 instance Normal Float where
   65         normal 0 = True
   66         normal _ = True
   67 
   68 instance Normal Double where
   69         normal 0 = True
   70         normal _ = True
   71 
   72 {-
   73 instance Normal ( a -> b ) where
   74         normal _ = True
   75 -}
   76 
   77 pack_obj obj = Norm_pack (normal obj) obj
   78 
   79 normalize_obj (Norm_pack b _) = b
   80 
   81 retrieve_obj (Norm_pack _ obj) = obj