Changeset 22990 for src

Timestamp:

11/12/08 10:01:29 (8 weeks ago)

Author:

audreyt

Message:

* GHC 6.10 support, part 3 of 3: Adjust for GADT's "rigid types" restriction.

Location:

src/Pugs

Files:

• AST.hs (modified) (1 diff)
• Compile.hs (modified) (2 diffs)
• Embed/Haskell.hs (modified) (1 diff)
• Eval.hs (modified) (4 diffs)
• Parser/Operator.hs (modified) (1 diff)

src/Pugs/AST.hs

@@ -194 +194 @@
                 , mc_variants   = Set.singleton var
                 }
-            merge _ old = case old of
-                PEConstant{ pe_proto = MkRef (ICode oldCV) }
-                    | Just (mc :: VMultiCode) <- fromTypeable oldCV -> protoEntry
-                        { pe_proto = MkRef . ICode $ protoCode
-                            { mc_assoc      = code_assoc c `mappend` code_assoc mc
-                            , mc_variants   = Set.insert var (mc_variants mc)
-                            , mc_signature  = if length (mc_signature mc) == length (code_params c)
-                                then code_params c
-                                else [defaultArrayParam]
-                            }
+            merge :: PadEntry -> PadEntry -> PadEntry
+            merge _ PEConstant{ pe_proto = MkRef (ICode oldCV) }
+                | Just (mc :: VMultiCode) <- fromTypeable oldCV
+                = protoEntry
+                    { pe_proto = MkRef . ICode $ protoCode
+                        { mc_assoc      = code_assoc c `mappend` code_assoc mc
+                        , mc_variants   = Set.insert var (mc_variants mc)
+                        , mc_signature  = if length (mc_signature mc) == length (code_params c)
+                            then code_params c
+                            else [defaultArrayParam]
                         }
-                _ -> old -- sub overrides multi -- XXX - error?
+                    }
+            merge _ old = old -- sub overrides multi -- XXX - error?
        in MkPad (Map.insertWith' merge var' protoEntry (Map.insert var entry map))
     | otherwise = MkPad (Map.insert var entry map)

src/Pugs/Compile.hs

@@ -77 +77 @@
         canCompile (name@('&':_) :: String, sym) = do
             (ref :: VRef) <- sym
-            case ref of
+            (case ref of
                 MkRef ICode{} -> do
                     codes <- readCodesFromRef ref
@@ -83 +83 @@
                 MkRef (IScalar sv) | scalar_iType sv == mkType "Scalar::Const"
                     -> doCode name =<< fromVal =<< scalar_fetch sv
-                _ -> return []
+                _ -> return []) :: Comp [PIL_Decl]
         canCompile ("@*END", sym) = do
             ref     <- sym

src/Pugs/Embed/Haskell.hs

@@ -1 @@
-{-# OPTIONS_GHC -fglasgow-exts -cpp -package plugins #-}
+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}
 
 module Pugs.Embed.Haskell where

src/Pugs/Eval.hs

@@ -196 +196 @@
                 -- auto-enreference
                 esc $ VRef ref
-            case ref of
+            (case ref of
                 MkRef IPair{}   -> esc (VRef ref)
-                _               -> esc =<< readRef ref
+                _               -> esc =<< readRef ref) :: Eval ()
         -- LValue here
         when isCollectionRef $ esc (castV ref)
@@ -508 +508 @@
     sub   <- fromCodeExp body
     -- XXX this is wrong -- should use Array.next
-    elms  <- case av of
+    elms  <- (case av of
         VRef (MkRef sv@IScalar{})   -> return [sv]
-        VList xs                    -> return . (`map` xs) $ \x -> case x of
+        VList xs                    -> return . (`map` xs) $ \x -> ((case x of
             VRef (MkRef sv@IScalar{})   -> sv
-            _                           -> (IScalar x)
-        _                           -> join $ doArray av array_fetchElemAll
+            _                           -> (IScalar x)) :: IVar VScalar)
+        _                           -> join $ doArray av array_fetchElemAll) :: Eval [IVar VScalar]
     -- This makes "for @x { ... }" into "for @x -> $_ is rw {...}"
     let arity = length (subParams sub)
@@ -1151 +1151 @@
         | v     <- vals
         ]
+    forceThunk :: Val -> Eval Val
     forceThunk (VRef (MkRef (IThunk tv)))   = thunk_force tv
     forceThunk x                            = return x
@@ -1491 +1492 @@
                     --- not scalarRef! -- use the new "transparent IType" thing!
                     case showType (typeOfSigilVar var) of
-                        "Hash"  -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> case x of
+                        "Hash"  -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> (case x of
                             VRef (MkRef (IHash h)) -> return (VRef $ hashRef h) 
                             VRef ref@(MkRef IScalar{}) -> redo =<< readRef ref
-                            _ -> fmap (VRef . hashRef) (fromVal v :: Eval VHash)
-                        "Array" -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> case x of
+                            _ -> fmap (VRef . hashRef) (fromVal v :: Eval VHash)) :: Eval Val
+                        "Array" -> ($ v) . fix $ \(redo :: Val -> Eval Val) x -> (case x of
                             VRef (MkRef (IArray a)) -> return (VRef $ arrayRef a) 
                             VRef ref@(MkRef IScalar{}) -> redo =<< readRef ref
-                            _ -> fmap (VRef . arrayRef) (fromVal v :: Eval VArray)
-                        _       -> case v of
+                            _ -> fmap (VRef . arrayRef) (fromVal v :: Eval VArray)) :: Eval Val
+                        _       -> (case v of
                             VRef (MkRef IScalar{}) -> return (VRef $ scalarRef v) 
                             VRef _ -> return v -- XXX - preserving ref
-                            _ -> return (VRef $ scalarRef v) 
+                            _ -> return (VRef $ scalarRef v)) :: Eval Val
                 (False, False)  -> return v -- XXX reduce to val?
                 (False, True)   -> do

src/Pugs/Parser/Operator.hs

@@ -204 +204 @@
         Nothing -> do
             ref <- readPadEntry entry
-            case ref of
-                MkRef (ICode cv)
-                    | relevantToParsing (code_type cv) (code_assoc cv) -> do
-                        let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)
-                            res = seq rv (Just rv)
-                        unsafeIOToSTM (H.insert _RefToFunction entry res)
-                        return res
-                MkRef (IScalar sv)
-                    | Just (VCode cv) <- scalar_const sv
-                    , relevantToParsing (code_type cv) (code_assoc cv) -> do
-                        let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)
-                            res = seq rv (Just rv)
-                        unsafeIOToSTM (H.insert _RefToFunction entry res)
-                        return res
-                _ -> do
-                    unsafeIOToSTM (H.insert _RefToFunction entry Nothing)
-                    return Nothing
+            filterRef ref
+    where
+    filterRef :: VRef -> STM (Maybe CurrentFunction)
+    filterRef (MkRef (ICode cv))
+        | relevantToParsing (code_type cv) (code_assoc cv) = do
+            let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)
+                res = seq rv (Just rv)
+            unsafeIOToSTM (H.insert _RefToFunction entry res)
+            return res
+    filterRef (MkRef (IScalar sv))
+        | Just (VCode cv) <- scalar_const sv
+        , relevantToParsing (code_type cv) (code_assoc cv) = do
+            let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)
+                res = seq rv (Just rv)
+            unsafeIOToSTM (H.insert _RefToFunction entry res)
+            return res
+    filterRef _ = do
+        unsafeIOToSTM (H.insert _RefToFunction entry Nothing)
+        return Nothing
 
 inScope :: Pkg -> Var -> Bool