Make BUtil work with new-style exceptions
[darcs-mirror-sem_syn.git] / BUtil.hs
1 {-# OPTIONS -XRank2Types -XCPP -XScopedTypeVariables #-}
2 module BUtil where
3
4 import qualified Data.IntMap as IntMap 
5 import Control.Monad 
6
7 import System.IO.Unsafe
8
9 import Control.Exception
10
11 data Nat = S Nat | Z deriving (Show,Eq)
12
13 toNat x = if x == 0 then 
14               Z
15           else 
16               S (toNat $ x-1)
17
18 fromNat Z     = 0
19 fromNat (S x) = 1 + fromNat x
20
21 fromDistinctList = IntMap.fromList 
22
23 gen_put_bias :: Bias 
24                 -> (forall a. [a] -> [a]) 
25                 -> (Nat -> Nat -> Maybe Nat) 
26                 -> [a] -> [a] 
27                 -> Maybe [Maybe a]
28 gen_put_bias bias get sput s v =
29     do { let ls = length s  
30        ; let g = fromDistinctList (zip (bias ls) s)
31        ; l' <- maybe (fail "...")
32                      return
33                      (sput (toNat ls) (toNat (length v)))
34        ; let t = bias (fromNat l')
35        ; let h = fromDistinctList (zip (get t) v)
36        ; let h'= IntMap.union h g 
37        ; return (map (flip IntMap.lookup h') t) }
38
39 withDefaultBias put bias d s v =
40     do { s' <- put bias s v 
41        ; return (map (maybe d id) s') }
42
43 withDefault put d s v =
44     do { s' <- put s v 
45        ; return (map (maybe d id) s') }
46
47 gen_put_dbias :: Bias -> (forall a. [a] -> [a]) 
48                  -> (Nat -> Nat -> Maybe Nat)
49                  -> a -> [a] -> [a] -> Maybe [a]
50 gen_put_dbias bias get sput d s v =
51     do { s' <- gen_put_bias bias get sput s v
52        ; return (map (maybe d id) s') }
53
54 castError :: a -> Maybe a 
55 castError f = unsafePerformIO $ 
56     do { r <- try (evaluate f)
57        ; case r of
58 #if __GLASGOW_HASKELL__ >= 610 
59            Left (e::SomeException) -> return $ Nothing 
60 #else
61            Left  e -> return $ Nothing 
62 #endif
63            Right r -> return $ Just $ r }
64
65 type Bias = Int -> [ Int ]
66 rear l    = [ 0 .. l - 1 ]
67 front l   = reverse [ 0 .. l - 1 ]
68 middle l  = [1,3..l] + (reverse [2,4..l])
69 borders l = (reverse [1,3..l])+[2,4..l]