Menu
▾
▴
[hoc-cvs] hoc/HOC/HOC TH.hs,NONE,1.1 Arguments.hs,1.1.1.1,1.2 Base.hs,1.1.1.1,1.2 DeclareClass.hs,1.1.1.1,1.2 DeclareSelector.hs,1.4,1.5 ExportClass.hs,1.5,1.6 SelectorMarshaller.hs,1.6,1.7
|
From: Wolfgang T. <wth...@us...> - 2004-12-06 03:47:09
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28748/HOC/HOC Modified Files: Arguments.hs Base.hs DeclareClass.hs DeclareSelector.hs ExportClass.hs SelectorMarshaller.hs Added Files: TH.hs Log Message: Upgrade to GHC 6.3, recent snapshot. I'm sure there are more places in HOC.* where we can take advantage of TH 2.0's new features, and the Cabal-aware build system is still quite fragile. Index: SelectorMarshaller.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- SelectorMarshaller.hs 6 Apr 2004 12:31:18 -0000 1.6 +++ SelectorMarshaller.hs 6 Dec 2004 03:46:51 -0000 1.7 @@ -1,4 +1,9 @@ -module HOC.SelectorMarshaller where +module HOC.SelectorMarshaller( + SelectorInfo(..), + makeMarshaller, + makeMarshallers, + marshallerName + ) where import HOC.Base import HOC.Arguments @@ -9,10 +14,11 @@ import HOC.MsgSend import HOC.FFICallInterface -import Language.Haskell.THSyntax import Foreign ( withArray, Ptr, nullPtr ) import System.IO.Unsafe ( unsafePerformIO ) +import HOC.TH + data SelectorInfo = SelectorInfo { selectorInfoObjCName :: String, selectorInfoHaskellName :: String, @@ -24,20 +30,22 @@ makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained = funD haskellName [ - clause (map VarP $ infoArgument ++ arguments - ++ ["target"]) + clause (map varP $ infoArgument ++ map mkName arguments + ++ [mkName "target"]) (normalB $ marshallerBody ) [] ] where (infoVar, infoArgument) = case maybeInfoName of Just name -> (varE name, []) - Nothing -> (varE "info", ["info"]) + Nothing -> (varE (mkName "info"), [mkName "info"]) arguments = [ "arg" ++ show i | i <- [1..nArgs] ] - argumentsToMarshal = varE "target" + argumentsToMarshal = varE (mkName "target") : [| selectorInfoSel $(infoVar) |] - : map varE arguments - marshalledArguments = "target'" : "selector'" : map (++"'") arguments + : map (varE.mkName) arguments + marshalledArguments = mkName "target'" + : mkName "selector'" + : map (mkName . (++"'")) arguments marshallerBody = purify $ checkTargetNil $ @@ -54,13 +62,13 @@ where e' = marshallArgs' args args' e collectArgs e = [| withArray $(listE (map varE marshalledArguments)) - $(lamE [varP "args"] e) |] + $(lamE [varP $ mkName "args"] e) |] invoke | isUnit = [| sendMessageWithoutRetval (selectorInfoCif $(infoVar)) $(argsVar)|] | otherwise = [| sendMessageWithRetval (selectorInfoCif $(infoVar)) $(argsVar)|] - where argsVar = varE "args" + where argsVar = varE $ mkName "args" purify e | isPure = [| unsafePerformIO $(e) |] | otherwise = e @@ -68,13 +76,13 @@ releaseRetvalIfRetained e | isRetained = [| $(e) >>= releaseExtraReference |] | otherwise = e - checkTargetNil e = [| failNilMessage $(varE "target") + checkTargetNil e = [| failNilMessage $(varE $ mkName "target") (selectorInfoHaskellName $(infoVar)) >> $(e) |] makeMarshallers n = sequence $ - [ makeMarshaller Nothing (marshallerName nArgs isUnit) nArgs isUnit False False + [ makeMarshaller Nothing (mkName $ marshallerName nArgs isUnit) nArgs isUnit False False | nArgs <- [0..n], isUnit <- [False, True] ] marshallerName nArgs False = "method" ++ show nArgs Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- DeclareSelector.hs 2 Nov 2003 10:12:53 -0000 1.4 +++ DeclareSelector.hs 6 Dec 2004 03:46:51 -0000 1.5 @@ -1,5 +1,5 @@ module HOC.DeclareSelector where - + import HOC.Base import HOC.Arguments import HOC.Class @@ -9,12 +9,15 @@ import HOC.FFICallInterface import HOC.SelectorMarshaller import HOC.StdArgumentTypes +import HOC.ID +import HOC.NewlyAllocated(NewlyAllocated) -import Language.Haskell.THSyntax import Data.Char(isUpper, toLower, toUpper) import Data.Maybe(fromMaybe) import Control.Monad(MonadPlus(mplus)) +import HOC.TH + data Covariant data CovariantInstance data Allocated @@ -36,17 +39,96 @@ nArgs = countArgs typeSig (isPure, pureType) = case resultType typeSig of - ConT "GHC.IOBase:IO" `AppT` ty -> (False, ty) + (ConT con) `AppT` ty + | con == ''IO -> (False, ty) ty -> error $ haskellName ++ " --- selector type must be in the IO monad" -- ty -> (True, ty) - isUnit = case pureType of - ConT "GHC.Base:()" -> True - _ -> False - + isUnit = pureType == ConT ''() (resultRetained, doctoredTypeSig) = doctorType typeSig className + resultType (ForallT vars ctxt ty) = resultType ty + resultType ((ArrowT `AppT` _) `AppT` rest) = resultType rest + resultType other = other + + countArgs (ForallT vars ctxt ty) = countArgs ty + countArgs ((ArrowT `AppT` _) `AppT` rest) = 1 + countArgs rest + countArgs other = 0 + + replaceResult new (ForallT vars ctxt ty) = ForallT vars ctxt (replaceResult new ty) + replaceResult new ((ArrowT `AppT` arg) `AppT` rest) = + (ArrowT `AppT` arg) `AppT` replaceResult new rest + replaceResult new result = new + + doctorType ty className = + ( + retained, + (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")]) $ + replaceResult ( + (ArrowT `AppT` (fromMaybe (VarT $ mkName "target") targetType)) + `AppT` covariantResult + ) ty + ) + where + (retained, needInstance, targetType, covariantResult) = + doctorCovariant $ resultType ty + + doctorCovariant (ConT con) + | con == ''Covariant = + (False, False, Nothing, VarT $ mkName "target") + | con == ''CovariantInstance = + (False, True, Nothing, VarT $ mkName "inst") + | con == ''Allocated = + (False, True, Nothing, + ConT ''NewlyAllocated `AppT` VarT (mkName "inst")) + | con == ''Inited = + (True, False, + Just (ConT ''NewlyAllocated `AppT` VarT (mkName "target")), + VarT (mkName "target")) + + doctorCovariant (ConT con `AppT` ty) | con == ''Retained = + (True,inst', target', ty') + where (_,inst', target', ty') = doctorCovariant ty + + doctorCovariant (t1 `AppT` t2) = + (retained1 || retained2, needInst1 || needInst2, target1 `mplus` target2, t1' `AppT` t2') + where (retained1, needInst1, target1, t1') = doctorCovariant t1 + (retained2, needInst2, target2, t2') = doctorCovariant t2 + + doctorCovariant other = (False, False, Nothing, other) + + -- Reduce the type to a form that can be used for creating a libffi CIF + -- using the ObjCIMPType type class: + + simplifyType (ForallT vars ctxt ty) = simplifyType ty + simplifyType ((ArrowT `AppT` arg) `AppT` rest) = (ArrowT `AppT` replaceVarByUnit arg) + `AppT` simplifyType rest + simplifyType (ConT con `AppT` x) | con == ''IO = ConT ''IO `AppT` replaceVarByUnit x + simplifyType x = replaceVarByUnit x + + replaceVarByUnit (VarT var) = ConT ''ID `AppT` ConT ''() + replaceVarByUnit (ConT con `AppT` ty) + | con == ''NewlyAllocated = replaceVarByUnit ty + replaceVarByUnit (ConT cls `AppT` VarT var) = ConT cls `AppT` ConT ''() + replaceVarByUnit x = x + + + makeImpType ty = replaceResult ( + (ArrowT `AppT` VarT (mkName "target")) + `AppT` covariantResult + ) ty' + where + ty' = simplifyType ty + (_retained, _needInstance, _target', covariantResult) = + doctorCovariant $ resultType ty' + sequence $ [ -- $(selectorName) = getSelectorForName "name" @@ -55,7 +137,7 @@ -- $(infoName) = ... let e = [| undefined |] `sigE` (return $ simplifyType doctoredTypeSig) - in valD (VarP infoName) (normalB + in valD (varP $ mkName $ infoName) (normalB [| SelectorInfo name haskellName @@ -66,105 +148,26 @@ |]) [], -- type $(imptypeName) target inst = arg1 -> arg2 -> target -> IO result - tySynD imptypeName ["target","inst"] (return $ makeImpType typeSig), + tySynD (mkName imptypeName) (map mkName ["target","inst"]) + (return $ makeImpType typeSig), -- class Object a => $(className) a - classD (cxt [conT "Object" `appT` varT "a"]) className ["a"] [], + classD (cxt [conT (mkName "Object") `appT` varT (mkName "a")]) + (mkName className) [mkName "a"] [] [], - sigD haskellName $ return doctoredTypeSig, + sigD (mkName haskellName) $ return doctoredTypeSig, if nArgs > marshallersUpTo || resultRetained - then makeMarshaller (Just infoName) haskellName nArgs + then makeMarshaller (Just $ mkName infoName) (mkName haskellName) nArgs isUnit isPure resultRetained - else valD (VarP haskellName) (normalB [| - $(varE $ thModulePrefix "DeclareSelector" $ - marshallerName nArgs isUnit) - $(varE infoName) + else valD (varP $ mkName haskellName) (normalB [| + $(varE $ + mkNameG_v "HOC.DeclareSelector" $ + marshallerName nArgs isUnit + ) + $(varE $ mkName infoName) |]) [] ] - declareSelector name typeSig = declareRenamedSelector name (mangleSelectorName name) typeSig -resultType (ForallT vars ctxt ty) = resultType ty -resultType ((ArrowT `AppT` _) `AppT` rest) = resultType rest -resultType other = other - -countArgs (ForallT vars ctxt ty) = countArgs ty -countArgs ((ArrowT `AppT` _) `AppT` rest) = 1 + countArgs rest -countArgs other = 0 - -replaceResult new (ForallT vars ctxt ty) = ForallT vars ctxt (replaceResult new ty) -replaceResult new ((ArrowT `AppT` arg) `AppT` rest) = - (ArrowT `AppT` arg) `AppT` replaceResult new rest -replaceResult new result = new - -doctorType ty className = - ( - retained, - (if needInstance - then ForallT ["target", "inst"] [ConT className `AppT` VarT "target", - ConT "ClassAndObject" - `AppT` VarT "target" `AppT` VarT "inst"] - else ForallT ["target"] [ConT className `AppT` VarT "target"]) $ - replaceResult ( - (ArrowT `AppT` (fromMaybe (VarT "target") targetType)) - `AppT` covariantResult - ) ty - ) - where - (retained, needInstance, targetType, covariantResult) = doctorCovariant $ resultType ty - -doctorCovariant (ConT "HOC.DeclareSelector:Covariant") = (False, False, Nothing, VarT "target") - -doctorCovariant (ConT "HOC.DeclareSelector:CovariantInstance") = (False, True, Nothing, VarT "inst") - -doctorCovariant (ConT "HOC.DeclareSelector:Allocated") = - (False, True, Nothing, ConT "HOC.NewlyAllocated:NewlyAllocated" `AppT` VarT "inst") - -doctorCovariant (ConT "HOC.DeclareSelector:Inited") = - (True, False, Just (ConT "HOC.NewlyAllocated:NewlyAllocated" `AppT` VarT "target"), VarT "target") - -doctorCovariant (ConT "HOC.DeclareSelector:Retained" `AppT` ty) = - (True,inst', target', ty') - where (_,inst', target', ty') = doctorCovariant ty - -doctorCovariant (t1 `AppT` t2) = - (retained1 || retained2, needInst1 || needInst2, target1 `mplus` target2, t1' `AppT` t2') - where (retained1, needInst1, target1, t1') = doctorCovariant t1 - (retained2, needInst2, target2, t2') = doctorCovariant t2 - -doctorCovariant other = (False, False, Nothing, other) - --- Reduce the type to a form that can be used for creating a libffi CIF --- using the ObjCIMPType type class: - -simplifyType (ForallT vars ctxt ty) = simplifyType ty -simplifyType ((ArrowT `AppT` arg) `AppT` rest) = (ArrowT `AppT` replaceVarByUnit arg) - `AppT` simplifyType rest -simplifyType (ConT "GHC.IOBase:IO" `AppT` x) = ConT "GHC.IOBase:IO" `AppT` replaceVarByUnit x -simplifyType x = replaceVarByUnit x - -replaceVarByUnit (VarT var) = ConT "HOC.ID:ID" `AppT` ConT "GHC.Base:()" -replaceVarByUnit (ConT "HOC.NewlyAllocated:NewlyAllocated" `AppT` ty) = - replaceVarByUnit ty -replaceVarByUnit (ConT cls `AppT` VarT var) = ConT cls `AppT` ConT "GHC.Base:()" -replaceVarByUnit x = x - --- === - -{- -makeImpType (ForallT vars ctxt ty) = makeImpType ty -makeImpType ((ArrowT `AppT` arg) `AppT` (ConT "GHC.IOBase:IO" `AppT` ret)) = - (ArrowT `AppT` VarT "target") `AppT` (ConT "GHC.IOBase:IO" `AppT` replaceVarByUnit ret) -makeImpType ((ArrowT `AppT` arg) `AppT` rest) = (ArrowT `AppT` replaceVarByUnit arg) - `AppT` makeImpType rest --} - -makeImpType ty = replaceResult ( - (ArrowT `AppT` VarT "target") - `AppT` covariantResult - ) ty' - where - ty' = simplifyType ty - (_retained, _needInstance, _target', covariantResult) = doctorCovariant $ resultType ty' Index: DeclareClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareClass.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- DeclareClass.hs 27 Oct 2003 16:48:04 -0000 1.1.1.1 +++ DeclareClass.hs 6 Dec 2004 03:46:51 -0000 1.2 @@ -1,32 +1,40 @@ -module HOC.DeclareClass where +module HOC.DeclareClass(declareClass) where import HOC.Base import HOC.Arguments import HOC.Class -import Language.Haskell.THSyntax +import HOC.TH + import Foreign.Ptr declareClass :: String -> String -> Q [Dec] declareClass name super = sequence $ [ -- data $(phantomName) a - dataD (cxt []) phantomName ["a"] [] [], + dataD (cxt []) (mkName phantomName) [mkName "a"] [] [], -- type $(name) a = $(super) ($(phantomName) a) - tySynD name ["a"] (conT super `appT` (conT phantomName `appT` varT "a")), + tySynD (mkName name) [mkName "a"] + (conT (mkName super) `appT` (conT (mkName phantomName) + `appT` varT (mkName "a"))), -- type $(metaClassName) a = $(superMetaClassName) ($(phantomName) a) - tySynD metaClassName ["a"] (conT superMetaClassName `appT` (conT phantomName `appT` varT "a")), + tySynD (mkName metaClassName) [mkName "a"] + (conT (mkName superMetaClassName) + `appT` (conT (mkName phantomName) + `appT` varT (mkName "a"))), -- $(classObjectName) :: $(metaClassName) () - sigD classObjectName (conT metaClassName `appT` [t| () |]), + sigD (mkName classObjectName) (conT (mkName metaClassName) + `appT` [t| () |]), -- $(classObjectName) = unsafeGetClassObject "name" - valD (VarP classObjectName) (normalB [| unsafeGetClassObject $(stringE name) |]) [], - + valD (return $ VarP (mkName classObjectName)) + (normalB [| unsafeGetClassObject $(stringE name) |]) [], + -- $(superName) = "super" - valD (VarP superName) (normalB [| super |]) [] + valD (return $ VarP (mkName superName)) (normalB [| super |]) [] ] where phantomName = name ++ "_" Index: Arguments.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- Arguments.hs 27 Oct 2003 16:48:03 -0000 1.1.1.1 +++ Arguments.hs 6 Dec 2004 03:46:51 -0000 1.2 @@ -8,7 +8,7 @@ import Foreign.Ptr import System.IO.Unsafe(unsafePerformIO) -import Language.Haskell.THSyntax +import HOC.TH class (Storable b, FFITypeable b) => ObjCArgument a b | a -> b where withExportedArgument :: a -> (b -> IO c) -> IO c @@ -28,9 +28,19 @@ -} declareStorableObjCArgument :: TypeQ -> String -> Q [Dec] + +{- This is what we'd like to do. +declareStorableObjCArgument ty str = + [d| instance ObjCArgument $(ty) $(ty) where + exportArgument = return + importArgument = return + objCTypeString = str + |] +-} + declareStorableObjCArgument ty str = do - argInst <- instanceD (cxt []) (conT (thModulePrefix "Arguments" "ObjCArgument") - `appT` ty `appT` ty) + argInst <- instanceD (cxt []) (conT ''ObjCArgument + `appT` ty `appT` ty) `whereQ` [d| {- withExportedArgument = flip ($) -} exportArgument = return --- NEW FILE: TH.hs --- module HOC.TH( module Language.Haskell.TH, mkNameG_v, mkNameG_tc, mkNameG_d, ) where import Language.Haskell.TH import Language.Haskell.TH.Syntax instance Functor Q where fmap f q = q >>= return . f Index: ExportClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- ExportClass.hs 8 May 2004 16:34:56 -0000 1.5 +++ ExportClass.hs 6 Dec 2004 03:46:51 -0000 1.6 @@ -1,6 +1,5 @@ module HOC.ExportClass where -import Language.Haskell.THSyntax import Foreign import Foreign.C.String import Control.Concurrent.MVar @@ -16,6 +15,7 @@ import HOC.SelectorMarshaller import HOC.Class import HOC.NewClass +import HOC.TH data ClassMember = InstanceMethod SelectorInfo @@ -64,12 +64,12 @@ -> Q [Dec] -- ^ A Haskell declaration, which can be spliced in -- with Template Haskell's $(...) syntax exportClass name prefix members = sequence $ [ - valD (VarP exportFunName) (normalB (mkClassExportAction name prefix members)) [], - dataD (cxt []) instanceDataName [] [normalC instanceDataName strictTypes] [], - valD (VarP tyConVar) (normalB [| mkTyCon instanceDataName |]) [], - instanceD (cxt []) (conT "Data.Typeable:Typeable" `appT` instTy) `whereQ` - [d| typeOf _ = mkAppTy $(varE tyConVar) [] |], - instanceD (cxt []) (conT (thModulePrefix "ExportClass" "InstanceVariables") + valD (varP $ mkName exportFunName) + (normalB (mkClassExportAction name prefix members)) [], + dataD (cxt []) (mkName instanceDataName) [] + [normalC (mkName instanceDataName) strictTypes] [''Typeable], + valD (varP $ mkName tyConVar) (normalB [| mkTyCon instanceDataName |]) [], + instanceD (cxt []) (conT ''InstanceVariables `appT` clsTy `appT` instTy) `whereQ` [d| initializeInstanceVariables = $(initIVars) @@ -82,22 +82,24 @@ strictTypes = map (strictType (return IsStrict)) wrappedIvarTypes ivars = [ (name, ty, [| nil |]) | Outlet name ty <- members ] ++ [ (name, ty, initial) | InstanceVariable name ty initial <- members ] - wrappedIvarTypes = [ conT "GHC.IOBase:MVar" `appT` ty | (_,ty,_) <- ivars ] + wrappedIvarTypes = [ conT ''MVar `appT` ty | (_,ty,_) <- ivars ] ivarNames = [ name | (name,_,_) <- ivars ] - clsTy = conT name `appT` conT "GHC.Base:()" - instTy = conT instanceDataName + clsTy = conT (mkName name) `appT` [t| () |] + instTy = conT (mkName instanceDataName) nIVars = length ivarNames declaredIVars = zipWith declareIVar ivarNames [1..] - declareIVar ivar n = valD (VarP ('_' : ivar)) (normalB [| IVar $(getNth n) |]) [] + declareIVar ivar n = valD (varP $ mkName ('_' : ivar)) + (normalB [| IVar $(getNth n) |]) [] where - getNth n = lamE [conP instanceDataName args] (varE $ "arg" ++ show n) - args = [ varP $ "arg" ++ show i | i <- [1..nIVars] ] + getNth n = lamE [conP (mkName instanceDataName) args] + (varE $ mkName $ "arg" ++ show n) + args = [ varP $ mkName $ "arg" ++ show i | i <- [1..nIVars] ] initIVars = doE (map initIVar ivars ++ [noBindS [| return $(wrap) |]]) where - wrap = foldl appE (conE instanceDataName) (map varE ivarNames) - initIVar (ivar,ty,initial) = bindS (varP ivar) [| newMVar $(initial) |] + wrap = foldl appE (conE $ mkName instanceDataName) (map (varE.mkName) ivarNames) + initIVar (ivar,ty,initial) = bindS (varP $ mkName ivar) [| newMVar $(initial) |] data Method = ImplementedMethod SelectorInfo String | GetterMethod String @@ -106,7 +108,7 @@ mkClassExportAction name prefix members = [| do - super <- getClassByName $(varE $ "super_" ++ name) + super <- getClassByName $(varE $ mkName $ "super_" ++ name) ivars <- makeDefaultIvarList imethods <- makeMethodList (nIMethods+3) cmethods <- makeMethodList nCMethods @@ -121,7 +123,8 @@ newClass super clsname defaultIvarSize ivars imethods cmethods |] where - typedInitIvars = [|initializeInstanceVariables|] `sigE` (conT "GHC.IOBase:IO" `appT` conT (name ++ "_IVARS")) + typedInitIvars = [|initializeInstanceVariables|] + `sigE` (conT ''IO `appT` conT (mkName $ name ++ "_IVARS")) outlets = [ name | Outlet name _ <- members ] classMethods = [ ImplementedMethod info (prefix ++ selectorInfoHaskellName info) @@ -152,28 +155,28 @@ exportMethod' isClassMethod objCMethodList num methodBody nArgs isUnit impTypeName selExpr cifExpr where - methodBody = varE methodDefinition + methodBody = varE $ mkName methodDefinition selName = selectorInfoHaskellName selectorInfo nArgs = selectorInfoNArgs selectorInfo isUnit = selectorInfoIsUnit selectorInfo - impTypeName = "ImpType_" ++ selName - selExpr = [| selectorInfoSel $(varE $ "info_" ++ selName) |] - cifExpr = [| selectorInfoCif $(varE $ "info_" ++ selName) |] + impTypeName = mkName $ "ImpType_" ++ selName + selExpr = [| selectorInfoSel $(varE $ mkName $ "info_" ++ selName) |] + cifExpr = [| selectorInfoCif $(varE $ mkName $ "info_" ++ selName) |] exportMethod isClassMethod objCMethodList (GetterMethod ivarName, num) = exportMethod' isClassMethod objCMethodList num - (varE (thModulePrefix "ExportClass" "getAsID") `appE` varE ('_':ivarName)) - 0 False (thModulePrefix "ExportClass" "GetVarImpType") + ([| getAsID |] `appE` varE (mkName ('_':ivarName))) + 0 False (''GetVarImpType) [| getSelectorForName ivarName |] - (varE (thModulePrefix "ExportClass" "getVarCif")) + [| getVarCif |] exportMethod isClassMethod objCMethodList (SetterMethod ivarName, num) = exportMethod' isClassMethod objCMethodList num - (varE (thModulePrefix "ExportClass" "setAsID") `appE` varE ('_':ivarName)) - 1 True (thModulePrefix "ExportClass" "SetVarImpType") + ([| setAsID |] `appE` varE (mkName ('_':ivarName))) + 1 True (''SetVarImpType) [| getSelectorForName setterName |] - (varE (thModulePrefix "ExportClass" "setVarCif")) + [| setVarCif |] where setterName = setterNameFor ivarName @@ -188,7 +191,7 @@ $(selExpr) (objCMethodType $(typed [|undefined|])) $(cifExpr) - ($(lamE [varP "cif", varP "ret", varP "args"] marshal)) + ($(lamE (map (varP.mkName) ["cif","ret","args"]) marshal)) |] where marshal = [| exceptionHaskellToObjC $(marshal') |] @@ -204,29 +207,30 @@ [noBindS typedBodyWithArgs] | otherwise = [ - bindS (VarP "result") typedBodyWithArgs, + bindS (varP $ mkName "result") typedBodyWithArgs, noBindS [| setMarshalledRetval - $(varE "ret") $(varE "result") |] + $(varE $ mkName "ret") + $(varE $ mkName "result") |] ] typedBodyWithArgs = foldl1 appE (typed methodBody - : map varE (arguments ++ ["self"])) + : map (varE.mkName)(arguments ++ ["self"])) where arguments = ["arg" ++ show i | i <- [1..nArgs]] typed thing = thing `sigE` (conT impTypeName `appT` (targetType - `appT` conT "GHC.Base:()") + `appT` [t| () |]) `appT` (instanceType - `appT` conT "GHC.Base:()") + `appT` [t| () |]) ) - targetType | isClassMethod = conT $ name ++ "Class" + targetType | isClassMethod = conT $ mkName $ name ++ "Class" | otherwise = instanceType - instanceType = conT name + instanceType = conT $ mkName name getArg (argname, argnum) = - bindS (VarP argname) - [| getMarshalledArgument $(varE "args") argnum |] + bindS (varP (mkName argname)) + [| getMarshalledArgument $(varE $ mkName "args") argnum |] Index: Base.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Base.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- Base.hs 27 Oct 2003 16:48:04 -0000 1.1.1.1 +++ Base.hs 6 Dec 2004 03:46:51 -0000 1.2 @@ -58,5 +58,3 @@ -- - -thModulePrefix mod id = "HOC." ++ mod ++ ":" ++ id |
