[turn ExtType into a real abstract type
John Meacham <john@repetae.net>**20120209100704
 Ignore-this: c802a07fee0f2461cca19aa28f99ff61
] hunk ./src/C/FromGrin2.hs 1
+{-# LANGUAGE OverloadedStrings #-}
hunk ./src/C/FromGrin2.hs 204
-                    newVars <- mapM (liftM (name . show) . newVar . basicType) argTys
+                    newVars <- mapM (liftM (name . show) . newVar . basicType') argTys
hunk ./src/C/FromGrin2.hs 207
-                        as2 = zip (newVars) (map basicType argTys)
-                        fr2 = basicType retTy
+                        as2 = zip (newVars) (map basicType' argTys)
+                        fr2 = basicType' retTy
hunk ./src/C/FromGrin2.hs 687
-        return $ cast (rt) (functionCall (name $ unpackPS n) [ cast (basicType t) v | v <- vs' | t <- as ])
+        return $ cast (rt) (functionCall (name $ unpackPS n) [ cast (basicType' t) v | v <- vs' | t <- as ])
hunk ./src/C/FromGrin2.hs 691
-        let fn = cast (funPtrType (basicType r) (map basicType as)) v'
-        return $ cast (rt) (indirectFunctionCall fn [ cast (basicType t) v | v <- vs' | t <- as ])
+        let fn = cast (funPtrType (basicType' r) (map basicType' as)) v'
+        return $ cast (rt) (indirectFunctionCall fn [ cast (basicType' t) v | v <- vs' | t <- as ])
hunk ./src/C/FromGrin2.hs 980
+
+basicType' :: ExtType -> Type
+basicType' b = basicType (show b)
hunk ./src/C/Prims.hs 1
+{-# LANGUAGE OverloadedStrings #-}
hunk ./src/C/Prims.hs 14
+import GHC.Exts
hunk ./src/C/Prims.hs 28
-type ExtType = String
+newtype ExtType = ExtType PackedString
+    deriving(Binary,IsString,Eq,Ord)
+
+instance Show ExtType where
+    show (ExtType p) = unpackPS p
hunk ./src/C/Prims.hs 50
-    | CConst { primConst :: !PackedString }  -- C code which evaluates to a constant
+    | CConst {
+        primConst :: !PackedString
+        }  -- C code which evaluates to a constant
hunk ./src/C/Prims.hs 64
-    | AddrOf !PackedString          -- address of linker name
+    | AddrOf !PackedString         -- address of linker name
hunk ./src/C/Prims.hs 161
-    pprint (Func _ s xs r) = parens (text r) <> text (unpackPS s) <> tupled (map text xs)
-    pprint (IFunc _ xs r) = parens (text r) <> parens (char '*') <> tupled (map text xs)
+    pprint (Func _ s xs r) = parens (tshow r) <> text (unpackPS s) <> tupled (map tshow xs)
+    pprint (IFunc _ xs r) = parens (tshow r) <> parens (char '*') <> tupled (map tshow xs)
hunk ./src/DataConstructors.hs 1
+{-# LANGUAGE OverloadedStrings #-}
hunk ./src/DataConstructors.hs 51
+import qualified Data.Set as Set hiding(map)
hunk ./src/DataConstructors.hs 76
+import PackedString
hunk ./src/DataConstructors.hs 346
-        | t == eHash -> return (e,(show c,st))
+        | t == eHash -> return (e,(ExtType (packString $show c),st))
hunk ./src/DataConstructors.hs 353
-            return (eCase e  [Alt (litCons { litName = cn, litArgs = [tvra], litType = (getType e) }) (EVar tvra)] Unknown,(show n,st))
+            return (eCase e  [Alt (litCons { litName = cn, litArgs = [tvra],
+                litType = (getType e) }) (EVar tvra)] Unknown,(ExtType (packString $ show n),st))
hunk ./src/DataConstructors.hs 365
-        | t == eHash -> return (e,(show c,st))
+        | t == eHash -> return (e,(ExtType . packString $ show c,st))
hunk ./src/DataConstructors.hs 373
-                return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(show n,st))
+                return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(ExtType . packString $ show n,st))
hunk ./src/DataConstructors.hs 375
-                return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(show n,st))
+                return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(ExtType . packString $ show n,st))
hunk ./src/DataConstructors.hs 406
-lookupExtTypeInfo dataTable oe = f oe where
-    f :: Monad m => E -> m ExtTypeInfo
+lookupExtTypeInfo dataTable oe = f Set.empty oe where
+    f :: Monad m => Set.Set Name -> E -> m ExtTypeInfo
hunk ./src/DataConstructors.hs 409
-    f e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_State_ = return ExtTypeVoid
+    f _ e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_State_ = return ExtTypeVoid
hunk ./src/DataConstructors.hs 412
-    f e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Ptr = do
-        ExtTypeBoxed b t _ <- g e  -- we know a pointer is a boxed BitsPtr
-        case f ta of
-            Just (ExtTypeBoxed _ _ et) -> return $ ExtTypeBoxed b t (et ++ "*")
-            Just (ExtTypeRaw et) -> return $ ExtTypeBoxed b t (et ++ "*")
+    f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Ptr = do
+        ExtTypeBoxed b t _ <- g seen e  -- we know a pointer is a boxed BitsPtr
+        case f seen ta of
+            Just (ExtTypeBoxed _ _ (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*")
+            Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*")
hunk ./src/DataConstructors.hs 418
-    f e@(ELit LitCons { litName = c }) | Just et <- Map.lookup c typeTable = do
-        res <- g e
+    f seen e@(ELit LitCons { litName = c }) | Just et <- Map.lookup c typeTable = do
+        res <- g seen e
hunk ./src/DataConstructors.hs 424
-    f e = g e
+    f seen e = g seen e
hunk ./src/DataConstructors.hs 426
-    g (ELit LitCons { litName = c })
+    g _ (ELit LitCons { litName = c })
hunk ./src/DataConstructors.hs 430
-    g (ELit LitCons { litName = c, litAliasFor = Nothing })
+    g _ (ELit LitCons { litName = c, litAliasFor = Nothing })
hunk ./src/DataConstructors.hs 434
-    g e | Just e' <- followAlias dataTable e = f e'
+    g seen e@(ELit LitCons { litName = n }) | Just e' <- followAlias dataTable e,
+        n `Set.notMember` seen = f (Set.insert n seen) e'
hunk ./src/E/FromHs.hs 376
-    --marshallToC ::oducer m => E -> E -> m E
-    marshallToC e te = do
-        ffiTypeInfo Unknown te $ \eti -> do
-        case eti of
-            ExtTypeBoxed cna sta _ -> do
-                [tvra] <- newVars [sta]
-                return $ eCase e
-                               [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })
-                                    (EVar tvra)]
-                               Unknown
-            ExtTypeRaw _ -> return e
-            ExtTypeVoid -> fail "marshallToC: trying to marshall void"
-
-    --marshallFromC :: Monad m =>  E -> E -> m E
-    marshallFromC ce te = do
-        ffiTypeInfo Unknown te $ \eti -> do
-        case eti of
-            ExtTypeBoxed cna _ _ -> return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })
-            ExtTypeRaw _ -> return ce
-            ExtTypeVoid -> fail "marshallFromC: trying to marshall void"
-
hunk ./src/E/FromHs.hs 1015
+
+marshallToC e te = do
+    ffiTypeInfo Unknown te $ \eti -> do
+    case eti of
+        ExtTypeBoxed cna sta _ -> do
+            [tvra] <- newVars [sta]
+            return $ eCase e
+                           [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })
+                                (EVar tvra)]
+                           Unknown
+        ExtTypeRaw _ -> return e
+        ExtTypeVoid -> fail "marshallToC: trying to marshall void"
+marshallFromC ce te = do
+    ffiTypeInfo Unknown te $ \eti -> do
+    case eti of
+        ExtTypeBoxed cna _ _ -> return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })
+        ExtTypeRaw _ -> return ce
+        ExtTypeVoid -> fail "marshallFromC: trying to marshall void"
hunk ./src/E/PrimDecode.hs 229
-stringToOpTy :: String -> Ty
-stringToOpTy s = case readTy s of
-    Just t -> t
-    _ -> error $ printf "stringToOpTy(%s)" s
+stringToOpTy :: ExtType -> Ty
+stringToOpTy s = stringToOpTy' "" s
hunk ./src/E/PrimDecode.hs 232
-stringToOpTy' :: String -> String -> Ty
-stringToOpTy' x s = case readTy s of
+stringToOpTy' :: String -> ExtType -> Ty
+stringToOpTy' x (show -> s) = case readTy s of
hunk ./src/E/PrimDecode.hs 237
-stot :: Show a => a -> Int -> String -> Ty
+stot :: Show a => a -> Int -> ExtType -> Ty