module HatTrace ( HatTrace, -- type, representing a redex trail file HatNode, -- type, representing a node within the redex trail -- structure of HatTrace and HatNode not revealed HatNodeType( -- type: information about what a node within the Redex -- Trail contains HatApplNode,HatConstantNode, HatSAT_ANode,HatSAT_BNode,HatSAT_CNode, HatHiddenNode, HatProjNode,HatConstrNode,HatIdentNode,HatCaseNode, HatLambdaNode,HatDummyNode, HatIntNode,HatCharNode,HatIntegerNode,HatRationalNode, HatFloatNode, HatDoubleNode,HatCStringNode, HatIfNode,HatGuardNode,HatContainerNode,HatModuleNode, HatInvalidNode), HatApplType( -- type: type of application node HatApplied,HatBlackholed,HatComplete,HatValue), HatInfixType( -- type: infixtype of an application node. HatInfix,HatInfixR,HatInfixL, -- constructors with priority HatNoInfix), -- constructor with no priority HatSourceRef(..), -- type for values returned as source reference -- (HatNoSourceRef, -- no reference given -- HatSourceRef), -- reference given: row, column, moduleName, -- moduleFile, moduletrusted are exported HatRep( -- class HatRep, for all structure representing Hat redexes toHatNode, -- convert to type HatNode toUndefined, -- return an undefined node of the same class instance hatNodeType, -- return type of redex trail node hatParent, -- return parent of redex trail node hatApplFun, -- return node for function of an -- application/constant node hatApplArgs, -- get list of arguments of an application node hatInfix, -- get infix priority of an constructor/identifier node hatResult, -- get result of an application (type complete only) hatName, -- get name of a name/identifier/constructor node hatProjValue, -- return projected value of projection/SATA/SATB/SATC -- node hatSourceRef, -- get information about source position of an -- application/identifier/constructor node hatValueInt, -- get Int value of an HatIntNode hatValueChar, -- get Char value of an HatCharNode hatValueInteger, -- get Integer value of an HatIntegerNode hatValueRational,-- get Rational value of an HatRationalNode hatValueFloat, -- get Float value of an HatFloatNode hatValueDouble, -- get Double value of an HatDoubleNode hatValueString -- get String value of an HatCStringNode ), openTrace, -- open a trace file, return a value of type HatTrace hatTraceName, -- return file name of file represented by trace hatVersionNumber, -- get current Hat version number hatMain, -- get node representing the "main" caf only hatTraceFirst, -- get first node within HatTrace file hatTraceNext, -- get node immediately after a node hatErrorRedex, -- get failed redex of an aborted evaluation hatErrorMessage, -- get error message of an aborted evaluation isValidNode, -- test if node is valid isInvalidNode, -- test if node is invalid hatInvalidNode,-- return an invalid hat node fromHatNode, -- get the raw file pointer out of a HatNode mkHatNode, -- build a hat node toRemoteRep, -- convert any HatRep to command-line represenation -- (in order to pass to another hat tool) fromRemoteRep, -- convert command-line representation to node (in order to -- accept an argument from another hat tool) -- functions for convenience hatIsCAF, -- check, whether a node represents a CAF or not hatIsTopLevel,-- check, whether an application/name/identifier is top-level hatIsTrusted, -- check, whether an application/name/identifier is trusted hatLeftmost, -- get leftmost outermost constructor/identifier of application -- other views on the redex trail edtChildren, -- return list of EDT children of a node observe, -- make observation: observe a function observeSrc, -- make observation: observe a source reference observables, -- make observation: observe all observable identifiers/modules ObserveResult(-- type: type for the result for "observe" IdentNotFound,TopIdentNotFound,Found), isIdentNotFound, -- returns true if ObserveResult is IdentNotFound isTopIdentNotFound, -- returns true if ObserveResult is TopIdentNotFound isInterrupted, -- returns true if ObserveResult is Interrupted isFound, -- returns true if ObserveResult is Found fromFound, -- get list of observations from "Found" result -- The following pretty printing functions use C for formatting. -- Pretty printing by Haskell is available in the "HatExpression" module! hatCExpressionStr, -- get pretty print for expression, -- using C's pretty printer printCExpression, -- print expression, using C's pretty printer printCReduction, -- print reduction (lhs = rhs) using C's pretty printer printCReductionList -- print list of reductions using C's pretty printer ) where #if defined(__GLASGOW_HASKELL__) import Foreign #else import FFI import GreenCard #endif import Maybe import Char (digitToInt,isDigit) import Numeric (showHex) type HatTrace = ForeignObj -- exported type RefNumber = Int -- internal only type HatNodeInternal = (HatTrace,RefNumber) -- internal only -- HatNode exported as abstract type only data HatNode = HatNode (HatTrace,RefNumber) | HatInvalid -- exported data types (exported with constructors) data HatNodeType = HatApplNode | HatConstantNode | HatSAT_ANode | HatSAT_BNode | HatSAT_CNode | HatHiddenNode | HatDummyNode | HatProjNode | HatConstrNode | HatIdentNode | HatCaseNode | HatLambdaNode | HatIntNode | HatCharNode | HatIntegerNode | HatRationalNode | HatFloatNode | HatDoubleNode | HatCStringNode | HatIfNode | HatGuardNode | HatContainerNode | HatInvalidNode | HatModuleNode deriving (Show,Eq) data HatApplType = HatApplied | HatBlackholed | HatComplete | HatValue deriving (Show,Eq) data HatInfixType = HatInfix Int | HatInfixR Int | HatInfixL Int | HatNoInfix deriving (Show,Eq) -- HatNoInfix represents default fixity data ObserveResult = IdentNotFound | TopIdentNotFound | Found [HatNode] | Interrupted data HatSourceRef = HatSourceRef {row :: Int ,column :: Int ,moduleName :: String ,moduleFile :: String ,moduletrusted :: Bool} | HatNoSourceRef -- class for all structures representing Hat redexes class Show a => HatRep a where toHatNode :: a -> HatNode toUndefined :: a -> a hatParent :: a -> a hatApplFun :: a -> a hatApplArgs :: a -> [a] hatInfix :: a -> HatInfixType hatResult :: a -> a hatName :: a -> String hatProjValue :: a -> a hatValueInt :: a -> Int hatValueChar :: a -> Char hatValueInteger :: a -> Integer hatValueRational :: a -> Rational hatValueFloat :: a -> Float hatValueDouble :: a -> Double hatValueString :: a -> String hatNodeType :: a -> HatNodeType hatSourceRef :: a -> HatSourceRef hatSourceRef node = _hatSourceRef (toHatNode node) %C #include %C #include "Expressions.h" %C #include "hatinterface.h" %C #include "nodelist.h" %C #include "hashtable.h" %C #include "FunTable.h" %C #include "observe.h" %C #include "detect.h" %C #include "hatgeneral.h" ------------------------------------------------------------------------ -- -- GREENCARD -- ------------------------------------------------------------------------ -- internal functions for conversions ------------------------------------------------------------------------ %dis addr x = declare "void*" x in (%%Addr x) %fun intForeignObjAddr :: ForeignObj -> Int %call (foreign f r) %code %result (int "(int) r") %fun lookupAddr :: Addr -> Int %call (addr a) %code %result (int "*(int*)a") %fun lookupArray :: ForeignObj -> Int -> Int %call (foreign f r) (int i) %code //printf("lookupArray %i in %u\n",i,r); % if (r==NULL) { % fprintf(stderr,"Internal ERROR: ForeignObj no longer available!\n\n"); % exit(1); % } % //printf("lookupArray, element %i, value %i\n",i,((int*) r)[i]); %result (int "((int*) r)[i]") _toHatNode :: HatNodeInternal -> HatNode _toHatNode expr@(_,nodenumber) = if (nodenumber == 0) then HatInvalid else HatNode expr _fromHatNode :: HatNode -> HatNodeInternal _fromHatNode (HatNode v) = v _fromHatNode HatInvalid = error "_fromHatNode on Invalid node!" -- should never occur -- %dis maybeHatNode x y = <_fromHatNode / _toHatNode > (int x, int y) %dis hfilepointer x = declare "filepointer" x in (%%Int x) ------------------------------------------------------------------------ ------------------------------------------------------------------------ -- internal functions: immediately interfacing C %fun c_openTrace :: String -> IO HatTrace %call (string name) %code hatfileHandle=(void*) hatOpenFile(name); % signal(SIGINT,ctrlC); %result (foreign "hatCloseFile" hatfileHandle) %fun c_isInvalidTrace :: HatTrace -> Int %call (foreign f hattrace) %code res = ((long) hattrace)<0; %result (int res) %fun c_hatMain :: HatTrace -> RefNumber %call (foreign f hattrace) %code filepointer nodenumber; % nodenumber = hatMainCAF((HatFile) hattrace); %result (int "(int) nodenumber") %fun c_hatFirst :: HatTrace -> RefNumber %call (foreign f hattrace) %code filepointer nodenumber; % nodenumber = hatSeqFirst((HatFile) hattrace); %result (int "(int) nodenumber") %fun c_hatNext :: HatNodeInternal -> RefNumber %call (foreign f hattrace, hfilepointer nodenumber) %code filepointer newnode; % newnode = hatSeqNext((HatFile) hattrace,nodenumber); %result (int "(int) newnode") %fun c_hatParent :: HatNodeInternal -> RefNumber %call (foreign f hattrace, hfilepointer nodenumber) %code % hatFollowSATCs((HatFile) hattrace,(filepointer) nodenumber); % nodenumber = getParent(); %result (hfilepointer "(int) nodenumber") %fun c_hatErrorRedex :: HatTrace -> RefNumber %call (foreign f hattrace) %code filepointer nodenumber; % nodenumber = hatErrorRedex((HatFile) hattrace); %result (hfilepointer "(int) nodenumber") %fun c_hatErrorMessage :: HatTrace -> String %call (foreign f hattrace) %code % message = hatErrorMessage((HatFile) hattrace); % if (!message) message=""; % message = newStr(message); %result (string message) ------------------------------------------------ -- interface to source reference and module names -- get node within hatfile, containing SrcRef %fun c_hatSrcRefNode :: HatNodeInternal -> RefNumber %call (foreign f hattrace, hfilepointer nodenumber) %code filepointer newnode; % newnode = hatFollowSATCs((HatFile) hattrace,(filepointer) nodenumber); % switch (getNodeType((HatFile) hattrace,newnode)) { % case HatApplication: % case HatConstant:newnode = getSrcRef();break; % case HatIdentifier: % case HatTopIdentifier: % case HatConstructor: % case HatSrcRef: % break; % default: newnode = InvalidFilePointer; % } %result (int "(int) newnode") -- get module info node %fun c_hatModInfo :: HatNodeInternal -> RefNumber %call (foreign f hattrace, hfilepointer nodenumber) %code filepointer newnode; % if (nodenumber!=0) { % getNodeType((HatFile) hattrace, (filepointer) nodenumber); // access node (known to be of correct type) % newnode = getModInfo(); % } else newnode = InvalidFilePointer; %result (int "(int) newnode") %fun c_hatPosnRow :: HatNodeInternal -> Int %call (foreign f hattrace, hfilepointer nodenumber) %code % getNodeType((HatFile) hattrace,(filepointer) nodenumber); % value = getPosnRow(); %result (int value) %fun c_hatPosnColumn :: HatNodeInternal -> Int %call (foreign f hattrace, hfilepointer nodenumber) %code % getNodeType((HatFile) hattrace,(filepointer) nodenumber); % value = getPosnColumn(); %result (int value) %fun c_hatModName :: HatNodeInternal -> String %call (foreign f hattrace, hfilepointer nodenumber) %code % getNodeType((HatFile) hattrace,nodenumber); % value = getName(); %result (string value) %fun c_hatModSrcName :: HatNodeInternal -> String %call (foreign f hattrace, hfilepointer nodenumber) %code % getNodeType((HatFile) hattrace,nodenumber); % value = getModuleSrcName(); %result (string value) %fun c_hatModSrcTrusted :: HatNodeInternal -> Int %call (foreign f hattrace, hfilepointer nodenumber) %code % getNodeType((HatFile) hattrace,nodenumber); % value = getModuleTrusted(); %result (int value) ---------------------------------------------------- %fun c_hatResult :: HatNodeInternal -> RefNumber %call (foreign f hattrace,hfilepointer nodenumber) %code filepointer fp,fp2,newnode; % char nodetype; % fp = hatFollowSATCs((HatFile) hattrace,nodenumber); % nodetype = getNodeType((HatFile) hattrace,fp); % if ((nodetype!=HatApplication)&&(nodetype!=HatConstant)) % newnode=InvalidFilePointer; else { % if ((fp2=hatOutermostSymbol((HatFile) hattrace,fp))==0) % newnode=InvalidFilePointer;else { % if (getNodeType((HatFile) hattrace,fp2)==HatConstructor) % newnode=InvalidFilePointer;else { % newnode=hatFollowSATCs((HatFile) hattrace,hatResult((HatFile) hattrace,fp)); % } % } % } %result (hfilepointer "(int) newnode") %fun c_hatLeftmost :: HatNodeInternal -> RefNumber %call (foreign f hattrace,hfilepointer nodenumber) %code filepointer newnode; % newnode = hatOutermostSymbol((HatFile) hattrace,nodenumber); %result (hfilepointer "(int) newnode") %fun c_hatName :: HatNodeInternal -> String %call (foreign f hattrace,hfilepointer nodenumber) %code % switch(getNodeType((HatFile) hattrace,nodenumber)) { % case HatConstructor: % case HatIdentifier: % case HatTopIdentifier: % case HatModule: % s = getName(); % if (s==NULL) s=newStr("");else % if (*s==0) s=newStr(" "); // empty name! % break; % default:s=newStr(""); % } %result (string s) %fun c_hatInt :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatInt) { % printf("Not an int node!\n");exit(1); % } % i = getIntValue(); %result (int i) %fun c_hatInteger :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatInteger) { % printf("Not an integer node!\n");exit(1); % } % i = getIntegerValue(); %result (int i) %fun c_hatChar :: HatNodeInternal -> Char %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatChar) { % printf("Not a char node at 0x%x!\n",(int)nodenumber);exit(1); % } % c = getCharValue(); %result (char c) %fun c_hatDouble :: HatNodeInternal -> Double %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatDouble) { % printf("Not a double node!\n");exit(1); % } % d = getDoubleValue(); %result (double d) %fun c_hatRational :: HatNodeInternal -> Double %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatRational) { % printf("Not a rational node!\n");exit(1); % } % // r = getRationalValue(); % r = 0; %result (double r) %fun c_hatFloat :: HatNodeInternal -> Float %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatFloat) { % printf("Not a float node!\n");exit(1); % } % fl = getFloatValue(); %result (float fl) %fun c_hatCString :: HatNodeInternal -> String %call (foreign f hattrace,hfilepointer nodenumber) %code % if (getNodeType((HatFile) hattrace,nodenumber)!=HatCString) { % printf("Not a cstring node!\n");exit(1); % } % s = getStringValue(); %result (string s) %fun c_hatApplFun :: HatNodeInternal -> RefNumber %call (foreign f hattrace,hfilepointer nodenumber) %code filepointer fp,newnode;char nodetype; % fp = hatFollowSATCs((HatFile) hattrace,nodenumber); % nodetype = getNodeType((HatFile) hattrace,fp); % if (nodetype==HatApplication) newnode=getAppFun(); % else % if (nodetype==HatConstant) newnode=getAtom(); % else newnode=InvalidFilePointer; %result (hfilepointer "(int) newnode") %fun c_hatProjRef :: HatNodeInternal -> RefNumber %call (foreign f hattrace,hfilepointer nodenumber) %code filepointer newnode;char nodetype; % nodetype = getNodeType((HatFile) hattrace,hatFollowSATCs((HatFile) hattrace,nodenumber)); % switch(nodetype) { % case HatProjection:case HatSATA:case HatSATB:case HatSATC: % newnode=getProjValue(); % break; % default:newnode=InvalidFilePointer; % } %result (hfilepointer "(int) newnode") %fun c_hatApplArity :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code char nodetype; % nodetype = getNodeType((HatFile) hattrace,hatFollowSATCs((HatFile) hattrace,nodenumber)); % if (nodetype==HatApplication) arity=getAppArity(); % else % arity = 0; %result (int arity) %fun gethatArgInternal :: HatNodeInternal -> Int -> Int %call (foreign f hattrace,hfilepointer nodenumber) (int argnum) %code filepointer newnode;char nodetype; % nodetype = getNodeType((HatFile) hattrace,hatFollowSATCs((HatFile) hattrace,nodenumber)); % if (nodetype!=HatApplication) newnode=InvalidFilePointer; else { % newnode = hatFollowSATCs((HatFile) hattrace,getAppArgument(argnum)); % } %result (hfilepointer "(int) newnode") -- functions accessing higher level C functions %fun c_hatIsCAF :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code % value = isCAF((HatFile) hattrace,nodenumber); %result (int value) %fun c_hatIsTopLevel :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code % value = isTopLevel((HatFile) hattrace,nodenumber); %result (int value) %fun c_hatIsTrusted :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code % value = isTrusted((HatFile) hattrace,nodenumber); %result (int value) %fun c_hatExpressionStr :: HatNodeInternal -> Int -> Int -> String %call (foreign g hattrace,hfilepointer nodenumber) (int verbose) (int precision) %code ExprNode* exp; % exp = buildExpr((HatFile) hattrace,nodenumber,verbose,precision<100?100:2*precision); % prettystring = prettyPrintExpr(exp,precision,1); % freeExpr(exp); %result (string prettystring) -- converting C ID value to Haskell type toHatNodeType :: Int -> HatNodeType toHatNodeType 0 = HatApplNode toHatNodeType 1 = HatConstantNode toHatNodeType 2 = HatProjNode toHatNodeType 3 = HatHiddenNode toHatNodeType 4 = HatSAT_ANode toHatNodeType 5 = HatSAT_BNode toHatNodeType 6 = HatSAT_CNode toHatNodeType 12 = HatSAT_ANode toHatNodeType 13 = HatSAT_BNode toHatNodeType 14 = HatSAT_CNode toHatNodeType 32 = HatModuleNode toHatNodeType 64 = HatIntNode toHatNodeType 65 = HatCharNode toHatNodeType 66 = HatIntegerNode toHatNodeType 67 = HatRationalNode toHatNodeType 68 = HatFloatNode toHatNodeType 69 = HatDoubleNode toHatNodeType 70 = HatIdentNode toHatNodeType 71 = HatConstrNode toHatNodeType 74 = HatCaseNode toHatNodeType 75 = HatLambdaNode toHatNodeType 76 = HatDummyNode toHatNodeType 77 = HatCStringNode toHatNodeType 78 = HatIfNode toHatNodeType 79 = HatGuardNode toHatNodeType 80 = HatContainerNode toHatNodeType 86 = HatIdentNode toHatNodeType _ = HatInvalidNode fromHatNodeType _ = 0 %fun c_hatNodeType :: HatNodeInternal -> HatNodeType %call (foreign f hattrace,hfilepointer nodenumber) %code //printf("in hatNodeType: %u %u\n",(int) hattrace,nodenumber); % nodetype = getNodeType((HatFile) hattrace,hatFollowSATCs((HatFile) hattrace,nodenumber)); % //printf("out hatNodeType: %u\n",nodetype); %result ( (int nodetype)) -- converting C ID values to Haskell type toHatApplType 4 = Just HatApplied toHatApplType 5 = Just HatBlackholed toHatApplType 6 = Just HatComplete toHatApplType 71 = Just HatValue toHatApplType _ = Nothing fromHatApplType _ = 0 %fun c_hatApplType :: HatNodeInternal -> Maybe HatApplType %call (foreign f hattrace,hfilepointer nodenumber) %code filepointer appl,lmo; % nodetype = getNodeType((HatFile) hattrace, % appl=hatFollowSATCs((HatFile) hattrace,nodenumber)); % if ((nodetype!=HatApplication)&&(nodetype!=HatConstant)) nodetype=0; else { % if ((lmo=hatOutermostSymbol((HatFile) hattrace,appl))==0) nodetype==0;else { % if (getNodeType((HatFile) hattrace,lmo)==HatConstructor) nodetype=HatConstructor; else { % nodetype = getNodeType((HatFile) hattrace,hatResult((HatFile) hattrace,appl)); % } % } % } %result ( (int nodetype)) %fun c_hatInfixValue :: HatNodeInternal -> Int %call (foreign f hattrace,hfilepointer nodenumber) %code % hatFollowSATCs((HatFile) hattrace,nodenumber); % infixprio = getInfixType()+(getInfixPrio()*4); %result (int infixprio) -------------------------------------------------------------------------- -- interfacing detect.c %fun getDetectInt :: HatTrace -> Int -> ForeignObj %call (foreign f hattrace) (hfilepointer nodenumber) %code % query = (void*) newEDTQuery((HatFile) hattrace,nodenumber); %result (foreign "freeEDTQuery" query) -- get one element from the c result %fun getDetectedElement :: ForeignObj -> Int -> Int %call (foreign f query) (int i) %code filepointer current; % current = nextEDTQueryNode((EDTQuery) query); %result (hfilepointer "(int) current") -- convert list of c results in haskell list foreignDetectToList :: HatTrace -> ForeignObj -> [HatNode] foreignDetectToList hattrace f = foreignDetectToList' 0 where foreignDetectToList' i = let x = (getDetectedElement f i) in if (x==0) then [] else (HatNode (hattrace,x)):(foreignDetectToList' (i+1)) -------------------------------------------------------------------------- -- Interfacing observe.c -- submit query to c (observing a function) %fun getObserveInt :: HatTrace -> String -> String -> Int -> ForeignObj %call (foreign f hattrace) (string ident) (string topIdent) (int recursive) %code % //printf("Now observing in file %u...\n",(int) hattrace); % //getObserve(hattrace,ident,topIdent,verbose,0,recursive,prec,(int**) &resultArray); % query = (void*) newObserveQueryIdent((HatFile) hattrace,ident,topIdent,recursive,1); % //printf("end of observe\n"); %result (foreign "freeObserveQuery" query) -- submit query to c (observing a source reference) %fun getObserveSrcInt :: HatTrace -> String -> Int -> Int -> ForeignObj %call (foreign f hattrace) (string moduleName) (int line) (int column) %code % query = (void*) newObserveQuerySource((HatFile) hattrace,moduleName,line,column,1); %result (foreign "freeObserveQuery" query) -- submit query to c (observing all observable) %fun getObservablesInt :: HatTrace -> ForeignObj %call (foreign f hattrace) %code % query = (void*) newObservableQuery((HatFile) hattrace,1); %result (foreign "freeObserveQuery" query) -- get one element from the c result %fun getObservedElement :: ForeignObj -> Int -> Int %call (foreign f query) (int i) %code filepointer current; % current = nextObserveQueryNode((ObserveQuery) query); %result (hfilepointer "(int) current") -- get status of query: identifier found? %fun getObserveIntStatus :: ForeignObj -> Int %call (foreign f query) %code % if (interrupted) { status=3; interrupted=0; } % else if (observeIdentifier((ObserveQuery) query)==0) status=1; % else if (observeTopIdentifier((ObserveQuery) query)==0) status=2; % else status=0; %result (int status) -- convert list of c results in haskell list foreignObserveToList :: HatTrace -> ForeignObj -> [HatNode] foreignObserveToList hattrace f = foreignObserveToList' 0 where foreignObserveToList' i = let x = getObservedElement f i in if x==0 then [] else (HatNode (hattrace,x)):(foreignObserveToList' (i+1)) -------------------------------------------------------------------------- -- -- -- Exported Functions -- -- -- -------------------------------------------------------------------------- -------------------------------------------------------------------------- -- define Eq and Show instances for HatNode instance Eq HatNode where HatInvalid == HatInvalid = True (HatNode (a,b)) == (HatNode (c,d)) = ((intForeignObjAddr a)==(intForeignObjAddr c))&&(b==d) _ == _ = False {- Use the less specific instance (here) for testing only. instance Eq HatNode where (HatNode (_,n)) == (HatNode (_,m)) = n == m HatInvalid == HatInvalid = True _ == _ = False -} instance Show HatNode where show HatInvalid = "Invalid" show (HatNode (hattrace,node)) = "0x"++showHex node "" -------------------------------------------------------------------------- -- predicates for HatNode isValidNode :: HatRep a => a -> Bool isValidNode node = (hatNodeType node)/=HatInvalidNode isInvalidNode :: HatRep a => a -> Bool isInvalidNode node = (hatNodeType node)==HatInvalidNode -- don't export structure of HatNode, just a value! hatInvalidNode = HatInvalid -- actually, this function reveals the Int inside a HatNode fromHatNode (HatNode (_,i)) = i -- mkHatNode is used to build a HatNode from a bridge file entry mkHatNode :: HatTrace -> Int -> HatNode mkHatNode tr i = HatNode (tr,i) -- convert any HatRep to external representation (in order to pass it as a -- command-line argument to another hat tool). toRemoteRep :: HatRep a => a -> String toRemoteRep exp = if (isValidNode exp) then let (_,node)=(_fromHatNode (toHatNode exp)) in show node else "INVALID" -- convert external representation to HatNode (in order to accept a command-line -- argument from another hat tool). fromRemoteRep :: HatTrace -> String -> HatNode fromRemoteRep hattrace s = let i = stoi s in if (isNothing i) then HatInvalid else (HatNode (hattrace,(fromJust i))) where stoi s = stoi' 0 s stoi' i [] = Just i stoi' i (c:r) | (isDigit c) = stoi' (i*10+(digitToInt c)) r | otherwise = Nothing -- open a trace file openTrace :: String -> IO (Maybe HatTrace) openTrace s = do h <- c_openTrace s if ((c_isInvalidTrace h)/=0) then return Nothing else return (Just h) -- get name of a trace file %fun hatTraceName :: HatTrace -> String %call (foreign f hattrace) %code % s = newStr(hatFileName((HatFile) hattrace)); %result (string s) %fun hatVersionNumber :: String %code % s = hatVersionNumber(); %result (string s) -- get the node type of a HatNode (exportet in HatRep instance for HatNode) _hatNodeType :: HatNode -> HatNodeType _hatNodeType (HatNode expr) = c_hatNodeType expr _hatNodeType _ = HatInvalidNode -- get the parent for a HatNode (exportet in HatRep instance for HatNode) _hatParent :: HatNode -> HatNode _hatParent (HatNode expr@(hattrace,nodenumber)) = _toHatNode (hattrace,c_hatParent expr) _hatParent _ = error "Call to \"hatParent\" with \"Invalid\" node." -- get the original parent of a projection node (former indirection) _hatProjRef :: HatNode -> HatNode _hatProjRef (HatNode expr@(hattrace,nodenumber)) = _toHatNode (hattrace,c_hatProjRef expr) _hatProjRef _ = error "Call to \"hatProjRef\" with \"Invalid\" node." -- get the name of an identifier/constructor/module node (exportet in HatRep) _hatName :: HatNode -> Maybe String _hatName (HatNode hatexpr) = let s = (c_hatName hatexpr) in if (s=="") then Nothing else (Just s) _hatName _ = error "Call to \"hatName\" with \"Invalid\" node." -- get the node representing the function of an application node _hatApplFun :: HatNode -> HatNode _hatApplFun (HatNode expr@(hattrace,nodenumber)) = _toHatNode (hattrace,c_hatApplFun expr) _hatApplFun _ = error "Call to \"hatApplFun\" with \"Invalid\" node." -- return arity of an application node (exportet in HatRep instance for HatNode) _hatApplArity :: HatNode -> Int _hatApplArity = c_hatApplArity . _fromHatNode -- get the list of arguments of an application node _hatApplArgs :: HatNode -> [HatNode] _hatApplArgs (HatNode expr@(hattrace,h)) = gethatArgs 0 (c_hatApplArity expr) where gethatArgs _ 0 = [] gethatArgs i j = (HatNode (hattrace,(gethatArgInternal expr i))): (gethatArgs (i+1) (j-1)) _hatApplArgs _ = error "Call to \"hatApplArgs\" with \"Invalid\" node." -- get infix priority and type of an application node _hatInfix :: HatNode -> HatInfixType _hatInfix (HatNode expr) = toInfixType' (infixP `mod` 4) (infixP `div` 4) where infixP = c_hatInfixValue expr toInfixType' 0 infixP = HatInfix infixP toInfixType' 1 infixP = HatInfixR infixP toInfixType' 2 infixP = HatInfixL infixP toInfixType' _ _ = HatNoInfix _hatInfix _ = error "Call to \"hatInfix\" with \"Invalid\" node." -- get type of application (Applied,Blackholed,Complete,Value) _hatApplType :: HatNode -> Maybe HatApplType _hatApplType = c_hatApplType . _fromHatNode -- get result of an application -- (if application of type complete, otherwise Nothing) _hatResult :: HatNode -> HatNode _hatResult (HatNode expr@(hattrace,nodenumber)) = _toHatNode (hattrace,c_hatResult expr) _hatResult _ = error "Call to \"hatResult\" with \"Invalid\" node." -- get information about source position, -- for Identifier/Constructor/Application/Constant nodes -- returns a HatSourceRef (RowPosition,ColumnPosition,ModuleName -- ,ModuleFile,Trusted) _hatSourceRef :: HatNode -> HatSourceRef _hatSourceRef (HatNode expr@(hattrace,nodenumber)) = let srcrefNode = (hattrace,c_hatSrcRefNode expr); modinfoNode = if snd srcrefNode == 0 then (hattrace,0) else (hattrace,c_hatModInfo srcrefNode) in if snd modinfoNode == 0 then HatNoSourceRef else HatSourceRef (c_hatPosnRow srcrefNode) (c_hatPosnColumn srcrefNode) (c_hatModName modinfoNode) (c_hatModSrcName modinfoNode) ((c_hatModSrcTrusted modinfoNode)==1) _hatSourceRef _ = error "Call to \"hatSourceRef\" with \"Invalid\" node." -- get node representing the "main" caf hatMain :: HatTrace -> HatNode hatMain hattrace = _toHatNode (hattrace,c_hatMain hattrace) -- get node representing the failed redex of an aborted evaluation hatErrorRedex :: HatTrace -> HatNode hatErrorRedex hattrace = _toHatNode (hattrace,c_hatErrorRedex hattrace) -- get error message of an aborted evaluation hatErrorMessage :: HatTrace -> Maybe String hatErrorMessage hattrace = let e = c_hatErrorMessage hattrace in if e=="" then Nothing else Just e -- get the first node within the HatTrace file hatTraceFirst :: HatTrace -> HatNode hatTraceFirst hattrace = _toHatNode (hattrace,c_hatFirst hattrace) -- get node immediately following a node hatTraceNext :: HatRep a => a -> HatNode hatTraceNext exp = let node = toHatNode exp; HatNode (hattrace,_) = node in if (isInvalidNode node) then HatInvalid else _toHatNode (hattrace,c_hatNext (_fromHatNode node)) -- get leftmost outermost symbol of an application -- (returns an identifier/constructor) hatLeftmost :: HatRep a => a -> HatNode hatLeftmost exp = let node = toHatNode exp in if isValidNode node then let (HatNode expr@(hattrace,nodenumber)) = node in _toHatNode (hattrace,c_hatLeftmost expr) else error "Call to \"hatLeftmost\" with \"Invalid\" node." hatIsCAF :: HatRep a => a -> Bool hatIsCAF exp = let node = toHatNode exp in if isValidNode node then c_hatIsCAF (_fromHatNode node) == 1 else error "Call to \"hatIsCAF\" with \"Invalid\" node." hatIsTopLevel :: HatRep a => a -> Bool hatIsTopLevel exp = let node = (toHatNode exp) in if (isValidNode node) then (c_hatIsTopLevel (_fromHatNode node)) == 1 else error "Call to \"hatIsTopLevel\" with \"Invalid\" node." hatIsTrusted :: HatRep a => a -> Bool hatIsTrusted exp = let node = toHatNode exp in if isValidNode node then c_hatIsTrusted (_fromHatNode node) == 1 else error "Call to \"hatIsTrusted\" with \"Invalid\" node." -------------------------------------------------------------------------- -- EDT interface -- returns a list of children for a node edtChildren :: HatRep a => a -> [HatNode] edtChildren exp = let node = toHatNode exp in if isValidNode node then let (HatNode e@(hattrace,nodenumber)) = node in -- foreignObjToList hattrace (getEDTForeignObj e) foreignDetectToList hattrace (getDetectInt hattrace nodenumber) else error "Call to \"edtChildren\" with \"Invalid\" node." -------------------------------------------------------------------------- -- observational interface -- returns observations within hattrace: all applications of "ident", within -- a function "topIdent" (leave empty otherwise). If recursive is false, -- recursive calls to the application are omitted observe :: HatTrace -> String -> String -> Bool -> ObserveResult observe hattrace ident topIdent recursive = let x = getObserveInt hattrace ident topIdent (if recursive then 0 else 1) s = getObserveIntStatus x in if s==3 then Interrupted else if s==2 && not (null topIdent) then TopIdentNotFound else if s==1 then IdentNotFound else Found (foreignObserveToList hattrace x) -- returns observations within hattrace: all applications/values at the given -- source position are returned. If moduleName is an empty string, the main -- module is considered. observeSrc :: HatTrace -> String -> Int -> Int -> ObserveResult observeSrc hattrace moduleName line column = let x = getObserveSrcInt hattrace moduleName line column in Found (foreignObserveToList hattrace x) -- returns observations within hattrace: all applications/values at the given -- source position are returned. If moduleName is an empty string, the main -- module is considered. observables :: HatTrace -> ObserveResult observables hattrace = let x = getObservablesInt hattrace in Found (foreignObserveToList hattrace x) -- predicates for result returned by observe isIdentNotFound :: ObserveResult -> Bool isIdentNotFound IdentNotFound = True isIdentNotFound _ = False isTopIdentNotFound :: ObserveResult -> Bool isTopIdentNotFound TopIdentNotFound = True isTopIdentNotFound _ = False isInterrupted :: ObserveResult -> Bool isInterrupted Interrupted = True isInterrupted _ = False isFound :: ObserveResult -> Bool isFound (Found _) = True isFound _ = False fromFound :: ObserveResult -> [HatNode] fromFound (Found r) = r fromFound _ = [] ------------------------------------------------------------------------------ -- pretty printing by C (haskell version in module "HatExpression" available hatCExpressionStr :: HatRep a => Bool -> Int -> a -> String hatCExpressionStr verbose precision node = c_hatExpressionStr (_fromHatNode (toHatNode node)) (if verbose then 1 else 0) precision printCExpression :: HatRep a => Int -> a -> IO () printCExpression precision exp = let node = (toHatNode exp) in if (isInvalidNode node) then putStr "Nothing" else putStr (hatCExpressionStr False precision node) printCReduction :: HatRep a => Int -> a -> IO () printCReduction precision exp = printCExpression precision exp >> if (isValidNode exp) then let res = (hatResult exp) in if (isValidNode res) then putStr " = " >> (printCExpression precision res) else return () else return () printCReductionList :: HatRep a => Int-> [a] -> IO () printCReductionList _ [] = return () printCReductionList precision (e:list) = do printCReduction precision e putStrLn "" printCReductionList precision list ------------------------------------------------------------------------------ instance HatRep HatNode where toHatNode node = node toUndefined _ = HatInvalid hatParent = _hatParent hatApplFun = _hatApplFun hatApplArgs = _hatApplArgs hatResult = _hatResult hatName = fromJust . _hatName hatInfix = _hatInfix hatProjValue = _hatProjRef hatValueInt = c_hatInt . _fromHatNode hatValueChar = c_hatChar . _fromHatNode hatValueInteger = toInteger . c_hatInteger . _fromHatNode hatValueRational = toRational . c_hatRational . _fromHatNode hatValueFloat = c_hatFloat . _fromHatNode hatValueDouble = c_hatDouble . _fromHatNode hatValueString = c_hatCString . _fromHatNode hatNodeType = _hatNodeType %fun trace :: String -> Int %call (string s) %code char c; % fprintf(stderr,"%s\n",s); % c=getchar(); % while ((c!=EOF)&&(c!='\n')) c=getchar(); % i=1; %result (int i)