Menu
▾
▴
[hoc-cvs] [hoc] r414 committed - Apply a mixture of patches contributed by pedromartins.pt and Torsten ...
|
From: <cod...@go...> - 2010-06-18 00:27:13
|
Revision: 414 Author: wol...@gm... Date: Thu Jun 17 17:23:19 2010 Log: Apply a mixture of patches contributed by pedromartins.pt and Torsten Kemps-Benedix to fix issue 23 and its duplicate, issue 25. http://code.google.com/p/hoc/source/detail?r=414 Modified: /trunk/hoc/HOC/HOC/CannedCIFs.hs /trunk/hoc/HOC/HOC/DeclareClass.hs /trunk/hoc/HOC/HOC/DeclareSelector.hs /trunk/hoc/HOC/HOC/FFICallInterface.hs /trunk/hoc/HOC/HOC/ID.hs /trunk/hoc/InterfaceGenerator2/BinaryInstances.hs /trunk/hoc/InterfaceGenerator2/ExpandSynonyms.hs /trunk/hoc/InterfaceGenerator2/THTraversal.hs ======================================= --- /trunk/hoc/HOC/HOC/CannedCIFs.hs Mon Aug 17 10:31:23 2009 +++ /trunk/hoc/HOC/HOC/CannedCIFs.hs Thu Jun 17 17:23:19 2010 @@ -14,6 +14,8 @@ import Foreign.C import Language.Haskell.TH +import Control.Arrow + -- removes all foralls (leaving in type variables) and de-sugars all type -- synonyms. expandSynonyms :: Type -> Q Type @@ -77,58 +79,14 @@ = ForallT names cxt (substTy mapping' t) where mapping' = filter (not . (`elem` names) . fst) mapping substTy mapping (VarT name) - = fromMaybe (VarT name) (lookup name mapping) + = fromMaybe (VarT name) (lookup name (map (first extractName) mapping)) substTy mapping (AppT a b) = AppT (substTy mapping a) (substTy mapping b) substTy _ other = other -expandSynonymsOrig - = flip expandSynonyms1 [] - where - -- unwrap the AppT, expand b, push b' onto the pending list - expandSynonyms1 (AppT a b) pending - = do - b' <- expandSynonyms1 b [] - expandSynonyms1 a (b' : pending) - -- grab the types, expand them, then fold up the expanded types - -- and everything that is pending (thus removing the ForallT) - expandSynonyms1 (ForallT vars ctx t) pending - = do - t' <- expandSynonyms1 t [] - return $ foldl AppT t' pending - -- n is a type synonym, removed it by substuting pending arguments - expandSynonyms1 (ConT n) pending - = do - info <- reify n - case info of - TyConI (TySynD _ args body) -> - expandSynonyms1 (substTy taken body) rest - where - taken = zip args pending - rest = drop (length taken) pending - _ -> return $ foldl AppT (ConT n) pending - -- this is the simple type termination condition. - -- return Q (AppT (AppT A B) C) - -- which is to say ((A B) C) - expandSynonyms1 other pending -- VarT, TupleT, ArrowT, ListT - = return $ foldl AppT other pending - - -- use mapping to replace all occurances of types. - -- the ForallT has to exclude names that were used as polymorphic type - -- names, since they are unrelated to the types we're intended to - -- substitute. - substTy mapping (ForallT names cxt t) - = ForallT names cxt (substTy mapping' t) - where mapping' = filter (not . (`elem` names) . fst) mapping - substTy mapping (VarT name) - = case lookup name mapping of - Just t -> t - Nothing -> VarT name - substTy mapping (AppT a b) - = AppT (substTy mapping a) (substTy mapping b) - substTy _ other - = other +extractName (PlainTV n) = n +extractName (KindedTV n _) = n toplevelConstructor (AppT a b) = toplevelConstructor a @@ -166,9 +124,6 @@ --runIO (putStrLn "Input" >> ppQ qt >> putStrLn "expandSynonyms:") t <- expandSynonyms =<< qt --runIO (ppAST t) - --t' <- expandSynonymsOrig =<< qt - --runIO (putStrLn "expandSynonymsOrig:" >> ppAST t) - --assertQ (t == t') "t and t' are not equal" -- arrowsToList -- -- converts a type of a->b->c->d-> IO e to an ======================================= --- /trunk/hoc/HOC/HOC/DeclareClass.hs Thu Aug 20 17:27:38 2009 +++ /trunk/hoc/HOC/HOC/DeclareClass.hs Thu Jun 17 17:23:19 2010 @@ -16,25 +16,25 @@ declareClass name super = sequence $ [ -- data $(phantomName) a - dataD (cxt []) (mkName phantomName) [mkName "a"] + dataD (cxt []) (mkName phantomName) [PlainTV (mkName "a")] -- the constructor is only here to work around -- GHC sourceforge bug #1244882. [return $ NormalC (mkName (phantomName ++ "dummy")) []] [], -- type $(name) a = $(super) ($(phantomName) a) - tySynD (mkName name) [mkName "a"] + tySynD (mkName name) [PlainTV (mkName "a")] (conT (mkName super) `appT` (conT (mkName phantomName) `appT` varT (mkName "a"))), -- type $(metaClassName) a = $(superMetaClassName) ($(phantomName) a) - tySynD (mkName metaClassName) [mkName "a"] + tySynD (mkName metaClassName) [PlainTV (mkName "a")] (conT (mkName superMetaClassName) `appT` (conT (mkName phantomName) `appT` varT (mkName "a"))), -- type $(metaMetaClassName) a = $(superMetaMetaClassName) ($(phantomName) a) - tySynD (mkName metaMetaClassName) [mkName "a"] + tySynD (mkName metaMetaClassName) [PlainTV (mkName "a")] (conT (mkName superMetaMetaClassName) `appT` (conT (mkName phantomName) `appT` varT (mkName "a"))), ======================================= --- /trunk/hoc/HOC/HOC/DeclareSelector.hs Mon Aug 17 10:31:23 2009 +++ /trunk/hoc/HOC/HOC/DeclareSelector.hs Thu Jun 17 17:23:19 2010 @@ -143,12 +143,12 @@ retained, liftForalls $ (if needInstance - then ForallT (map mkName ["target", "inst"]) - [ConT (mkName className) `AppT` VarT (mkName "target"), - ConT (mkName "ClassAndObject") - `AppT` VarT (mkName "target") `AppT` VarT (mkName "inst")] - else ForallT [mkName "target"] - [ConT (mkName className) `AppT` VarT (mkName "target")]) $ + then ForallT (map (PlainTV . mkName) ["target", "inst"]) + [ClassP (mkName className) [VarT (mkName "target")], + ClassP (mkName "ClassAndObject") [VarT (mkName "target"), + VarT (mkName "inst")]] + else ForallT [PlainTV $ mkName "target"] + [ClassP (mkName className) [VarT (mkName "target")]]) $ replaceResult ( (ArrowT `AppT` (fromMaybe (VarT $ mkName "target") targetType)) `AppT` covariantResult @@ -257,15 +257,15 @@ |]) [], -- type $(imptypeName) target inst = arg1 -> arg2 -> target -> IO result - tySynD (mkName imptypeName) (map mkName ["target","inst"]) + tySynD (mkName imptypeName) (map (PlainTV . mkName) ["target","inst"]) (return $ makeImpType typeSig), -- class Object a => $(className) a - classD (cxt [conT ''MessageTarget `appT` varT (mkName "a")]) - (mkName className) [mkName "a"] [] [], + classD (cxt [classP ''MessageTarget [varT (mkName "a")]]) + (mkName className) [PlainTV $ mkName "a"] [] [], -- instance $(className) a => $(className) (SuperTarget a) - instanceD (cxt [conT (mkName className) `appT` varT (mkName "a")]) + instanceD (cxt [classP (mkName className) [varT (mkName "a")]]) (conT (mkName className) `appT` (conT ''SuperTarget `appT` varT (mkName "a"))) [], ======================================= --- /trunk/hoc/HOC/HOC/FFICallInterface.hs Mon Aug 17 10:31:23 2009 +++ /trunk/hoc/HOC/HOC/FFICallInterface.hs Thu Jun 17 17:23:19 2010 @@ -133,8 +133,6 @@ makeFFIType _ = return ffi_type_float instance FFITypeable CDouble where makeFFIType _ = return ffi_type_double -instance FFITypeable CLDouble where - makeFFIType _ = return ffi_type_longdouble -- ### FIXME: this should be autoconfigured. -- The following are correct for Mac OS X ======================================= --- /trunk/hoc/HOC/HOC/ID.hs Mon Aug 17 10:31:23 2009 +++ /trunk/hoc/HOC/HOC/ID.hs Thu Jun 17 17:23:19 2010 @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface, RecursiveDo, +{-# LANGUAGE ForeignFunctionInterface, DoRec, MultiParamTypeClasses, FlexibleInstances #-} module HOC.ID where @@ -196,15 +196,17 @@ -- notice that wptr's finalizer definition requires new_sptr, which -- cannot be created till after the wptr; -- so we use 'mdo' (it's much more pratical than fixM) -makeNewHSO immortal p = mdo - haskellData <- makeNewHaskellData p - dPutWords ["got haskell data", show haskellData] - let haskellObj = HSO p (fromMaybe [] haskellData) - finalizer | immortal = Nothing - | otherwise = Just $ finalizeID p new_sptr - wptr <- mkWeakPtr haskellObj finalizer - new_sptr <- newStablePtr wptr - setHaskellPart p new_sptr (if immortal then 1 else 0) +makeNewHSO immortal p = + do + rec + haskellData <- makeNewHaskellData p + dPutWords ["got haskell data", show haskellData] + let haskellObj = HSO p (fromMaybe [] haskellData) + finalizer | immortal = Nothing + | otherwise = Just $ finalizeID p new_sptr + wptr <- mkWeakPtr haskellObj finalizer + new_sptr <- newStablePtr wptr + setHaskellPart p new_sptr (if immortal then 1 else 0) return haskellObj finalizeID :: Ptr ObjCObject -> StablePtr (Weak HSO) -> IO () ======================================= --- /trunk/hoc/InterfaceGenerator2/BinaryInstances.hs Mon Aug 17 10:31:23 2009 +++ /trunk/hoc/InterfaceGenerator2/BinaryInstances.hs Thu Jun 17 17:23:19 2010 @@ -27,7 +27,7 @@ gput0 = case constrRep (toConstr thing) of IntConstr i -> put i FloatConstr f -> put f - StringConstr s -> put s + CharConstr c -> put c AlgConstr i -> do putWord8 (fromIntegral i) gmapM (\x -> gput x >> return x) thing @@ -53,9 +53,9 @@ FloatRep -> do f <- get return $ mkFloatConstr dataType f - StringRep -> do - s <- get - return $ mkStringConstr dataType s + CharRep -> do + c <- get + return $ mkCharConstr dataType c AlgRep constrs -> do i <- getWord8 return (constrs !! (fromIntegral i - 1)) ======================================= --- /trunk/hoc/InterfaceGenerator2/ExpandSynonyms.hs Sun Dec 23 16:43:07 2007 +++ /trunk/hoc/InterfaceGenerator2/ExpandSynonyms.hs Thu Jun 17 17:23:19 2010 @@ -3,6 +3,10 @@ import Language.Haskell.TH +import Control.Arrow + +extractName (PlainTV n) = n +extractName (KindedTV n _) = n expandSynonyms typ = typ >>= flip expandSynonyms1 [] where @@ -33,7 +37,7 @@ = ForallT names cxt (substTy mapping' t) where mapping' = filter (not . (`elem` names) . fst) mapping substTy mapping (VarT name) - = case lookup name mapping of + = case lookup name (map (first extractName) mapping) of Just t -> t Nothing -> VarT name substTy mapping (AppT a b) ======================================= --- /trunk/hoc/InterfaceGenerator2/THTraversal.hs Mon Aug 17 10:31:23 2009 +++ /trunk/hoc/InterfaceGenerator2/THTraversal.hs Thu Jun 17 17:23:19 2010 @@ -5,6 +5,7 @@ import Control.Monad.State import qualified Data.Map as Map +import Data.List import ExpandSynonyms @@ -47,7 +48,7 @@ --let conNames = map conName cons - let environment' = Map.fromList (zip (map nameBaseWorkaround argNames) argTypes) + let environment' = Map.fromList (zip (map nameBaseWorkaround (map extractName argNames)) argTypes) `Map.union` environment log $ "dataD " ++ show n ++ " " ++ show environment' matches <- mapM (makeCaseForCon environment') cons @@ -143,10 +144,17 @@ loop (AppT ty arg) args = loop ty (arg : args) loop ty0 args = (ty0, args) + expandVars :: Map.Map String Type -> Type -> Type expandVars environment (ForallT names cxt ty) - = ForallT names (map (expandVars environment') cxt) $ expandVars environment' ty + = ForallT names (map (buildPred . expandVars environment') (map extractCxt cxt)) $ expandVars environment' ty where - environment' = foldr Map.delete environment $ map nameBaseWorkaround names + buildPred t = let buildPredTypes (AppT (ConT n) t) = [t] + buildPredTypes (AppT a@(AppT _ _) t) = t:(buildPredTypes a) + extractName (AppT (ConT n) _) = n + extractName (AppT a _) = extractName a + in ClassP (extractName t) (buildPredTypes t) + extractCxt (ClassP n ts) = foldl' AppT (ConT n) ts + environment' = foldr Map.delete environment $ map (nameBaseWorkaround . extractName) names expandVars environment (VarT name) = case Map.lookup (nameBaseWorkaround name) environment of Just ty -> ty |
