{- --------------------------------------------------------------------------- Transform a module for generating a trace. Names are changed. Module names are prefixed by 'Hat.'. Variable names are prefixed to make room for new variable names refering to various traces and intermediate expressions. Details of new name scheme near the end of this module. No monad is used in the transformation, because there is nothing inherently sequential. Instead, the definitions of the transformation functions `t*' remind of an attribut grammar: the arguments are the inherited attributes, the elements of the result tuples are the synthetic attributes. ---------------------------------------------------------------------------- -} module TraceTrans (traceTrans,maybeStripOffQual) where import Syntax import SyntaxPos (HasPos(getPos)) import TokenId (TokenId(TupleId,Visible,Qualified) ,mkUnqualifiedTokenId,isTidCon,visImport ,qualify,visible,extractV,extractM,forceM,dropM ,tPrelude,t_Tuple,t_Arrow,tTrue,tFalse,t_otherwise,t_undef ,tMain,tmain,tseq,t_ColonNQ,t_ListNQ,tHatHack) import TraceDerive (derive) import SysDeps (PackedString,packString,unpackPS) import Extra (Pos,noPos,mergePos,strPos,fromPos,mapListSnd,mapSnd) import TraceId (TraceId,tokenId,arity,isLambdaBound,isTraced ,fixPriority,mkLambdaBound,mkTyCon,mkField ,getUnqualified,modLetBound,hasValueInfo,tyClsInfo,typeSynonymBody ,isExpandableTypeSynonym,TyCls(Ty,Cls,Syn) ,tTokenCons,tTokenNil,tTokenGtGt,tTokenGtGtEq,tTokenFail ,tTokenAndAnd,tTokenEqualEqual,tTokenGreaterEqual,tTokenMinus ,tTokenFun) import AuxTypes (AuxiliaryInfo,TySynBody(..),possTuple ,InitAuxInfo,defaultAuxInfo,initAuxInfo) import Data.List (isPrefixOf,union,partition,nubBy,delete) import Data.Char (isAlpha,digitToInt) import Data.Ratio (numerator,denominator) import Data.Maybe (fromJust,catMaybes,isNothing,isJust) -- import Extra (strace) infixr 6 `typeFun` -- hbc won't let me declare this later. type Arity = Int data Scope = Global | Local deriving Eq isLocal :: Scope -> Bool isLocal Local = True isLocal Global = False -- ---------------------------------------------------------------------------- -- Transform a module traceTrans :: Bool -- transform for tracing/suspect (not non-tracing/trusted) -> String -- filename of module -> String -- base filename for the trace files (without extension) -> Module TraceId -> Module TokenId traceTrans traced filename traceFilename (Module pos modId exps impDecls fixDecls decls) = Module pos modId' (if isMain modId then Just [] {- export everything -} else tExports traced exps (decls'++conNameDefs++globalVarNameDefs) modId') (tImpDecls traced modId impDecls) [] -- no fix info needed, because pretty printed output not ambiguous (DeclsParse (decls' ++ [defNameMod pos modId filename traced] ++ conNameDefs ++ globalVarNameDefs ++ map (defNameVar Global Local modTrace) mvars ++ map (defNameVar Local Local modTrace) vars ++ (if traced then map (defNamePos modTrace) poss else []) ++ if isMain modId then [defMain traced traceFilename] else [] )) where conNameDefs = map (defNameCon modTrace) cons globalVarNameDefs = map (defNameVar Global Global modTrace) tvars modId' = nameTransModule modId modTrace = ExpVar pos (nameTraceInfoModule modId) (poss,tvars,vars,mvars,cons) = getModuleConsts consts (DeclsParse decls',consts) = tDecls Global traced (mkRoot pos) decls -- ---------------------------------------------------------------------------- -- If module is part of the given module (Prelude or TPrelude), -- then strip off all of these module qualifications from identifiers. -- These qualified identifiers are introduced by desugaring in the parser -- and the fixity correction. maybeStripOffQual :: String -> Module TokenId -> Module TokenId maybeStripOffQual p mod@(Module pos modId exps impDecls fixDecls decls) = if isPreModule p modId then fmap (stripModule p) mod else mod isPreModule :: String -> TokenId -> Bool isPreModule p = (p `isPrefixOf`) . reverse . unpackPS . extractV stripModule :: String -> TokenId -> TokenId stripModule qual' (Qualified qual unqual) | qual' == qualModule qual = Visible unqual stripModule qual token = token qualModule :: PackedString -> String qualModule = reverse . unpackPS -- reverse . takeWhile (/= '.') . unpackPS -- ---------------------------------------------------------------------------- -- construct new main function definition -- main = T.traceIO "artFilename" gmain -- main = do -- T.openTrace "artFilename" -- case omain Prelude.undefined Prelude.undefined of -- T.R v _ -> v -- T.closeTrace defMain :: Bool -> String -> Decl TokenId defMain traced artFilename = DeclFun noPos tokenmain [Fun [] (Unguarded (ExpApplication noPos [ExpVar noPos tokenTraceIO ,ExpLit noPos (LitString Boxed artFilename) ,ExpApplication noPos [ExpVar noPos tokengmain,mkSRExp noPos False,mkRoot noPos]])) noDecls] where tokenmain = visible (reverse "main") tokengmain = nameTransLetVar (mkLambdaBound (initAuxInfo traced) tmain) -- ---------------------------------------------------------------------------- -- Transform imports and exports makeExport :: Decl TokenId -> [Export TokenId] makeExport (DeclType (Simple _ id _) _) = [ExportEntity noPos (EntityConClsSome noPos id [])] makeExport (DeclData _ _ (Simple _ id _) _ _) = [ExportEntity noPos (EntityConClsAll noPos id)] makeExport (DeclClass _ _ id _ _ _) = [ExportEntity noPos (EntityConClsAll noPos id)] makeExport (DeclFun _ id _) | (head (getUnqual id)) `elem` ['g','!','a','+','h','*'] = -- only these functions shall be exported [ExportEntity noPos (EntityVar noPos id)] where getUnqual = reverse . unpackPS . extractV makeExport _ = [] tExports :: Bool -> Maybe [Export TraceId] -> [Decl TokenId] -> TokenId -> Maybe [Export TokenId] tExports _ Nothing _ _ = Nothing tExports _ (Just []) decls _ = Just (concatMap makeExport decls) tExports traced (Just exports) decls thisModId = Just (concatMap tExport exports) where tExport :: Export TraceId -> [Export TokenId] tExport (ExportModid pos modId) = if modId' == thisModId then concatMap makeExport decls else [ExportModid pos modId'] where modId' = nameTransModule modId tExport (ExportEntity pos entity) = map (ExportEntity pos) (tEntity traced entity) tImpDecls :: Bool -> TraceId -> [ImpDecl TraceId] -> [ImpDecl TokenId] tImpDecls traced modId decls = ImportQ (noPos,tPrelude) (Hiding []) -- ^ import original Prelude qualified -- actually should hide Prelude as far as possible using -- ImportQ (noPos,tPrelude) (NoHiding []) -- but nhc98 needs access to original Prelude for desugaring :Import (noPos,tHatHack) (Hiding []) -- for list syntax : and [] :ImportQas (noPos,Visible tracingModule) (noPos,Visible tracingModuleShort) (Hiding []) :Import (noPos,Visible tracingModule) (NoHiding [EntityConClsSome noPos (visImport "WrapVal") [(noPos, visImport "wrapVal")]]) -- ^ hack for nhc98 <= 1.16 :map (tImpDecl traced) decls tImpDecl :: Bool -> ImpDecl TraceId -> ImpDecl TokenId tImpDecl traced (Import (pos,id) spec) = Import (pos,nameTransModule id) (tImpSpec traced spec) tImpDecl traced (ImportQ (pos,id) spec) = ImportQ (pos,nameTransModule id) (tImpSpec traced spec) tImpDecl traced (ImportQas (pos1,id1) (pos2,id2) spec) = ImportQas (pos1,nameTransModule id1) (pos2,nameTransModule id2) (tImpSpec traced spec) tImpDecl traced (Importas (pos1,id1) (pos2,id2) spec) = Importas (pos1,nameTransModule id1) (pos2,nameTransModule id2) (tImpSpec traced spec) tImpSpec :: Bool -> ImpSpec TraceId -> ImpSpec TokenId tImpSpec traced (NoHiding entities) = NoHiding (concatMap (tEntity traced) entities) tImpSpec traced (Hiding entities) = Hiding (concatMap (tEntity traced) entities) tEntity :: Bool -> Entity TraceId -> [Entity TokenId] tEntity _ (EntityVar pos id) = EntityVar pos (nameTransLetVar id) : case arity id of Just a | a > 0 -> [EntityVar pos (nameTraceInfoGlobalVar id) ,EntityVar pos (nameWorker id)] Just (-1) -> [EntityVar pos (nameShare id)] _ -> [] tEntity traced (EntityConClsAll pos id) | hasValueInfo id = [] tEntity traced (EntityConClsAll pos id) = case tyClsInfo id of Ty cons labels -> (EntityConClsSome pos (nameTransTyConCls id) (map ((,) pos . nameTransCon) consIds ++ map ((,) pos . nameTransField) labelIds)) : map (EntityVar pos . nameTraceInfoCon) consIds ++ map (EntityVar pos . nameTransLetVar) labelIds ++ map (EntityVar pos . nameWorker) labelIds ++ map (EntityVar pos . nameTraceInfoGlobalVar) labelIds where consIds = map (mkTyCon iai . possTuple) cons labelIds = map (mkField iai . visImport) labels iai = initAuxInfo traced Syn helpers _ -> [EntityConClsSome pos (nameTransTyConCls id) []] ++ map (flip (EntityConClsSome pos) [] . nameTransTySynHelper id) [1..helpers] -- Syn _ _ -> error ("tEntity: synonym with all entities: "++show (tokenId id)) Cls methods -> [EntityConClsAll pos (nameTransTyConCls id)] tEntity _ (EntityConClsSome pos id posIds) | hasValueInfo id = [] tEntity _ (EntityConClsSome pos id posIds) = case tyClsInfo id of Ty _ _ -> (EntityConClsSome pos (nameTransTyConCls id) (mapListSnd nameTransCon pCons ++ mapListSnd nameTransField pFields)) : map (\(pos,id) -> EntityVar pos (nameTransLetVar id)) pFields ++ map (\(pos,id) -> EntityVar pos (nameWorker id)) pFields ++ map (\(pos,id) -> EntityVar pos (nameTraceInfoGlobalVar id)) pFields ++ map (\(pos,id) -> EntityVar pos (nameTraceInfoCon id)) pCons Syn helpers _ -> [EntityConClsSome pos (nameTransTyConCls id) []] ++ map (flip (EntityConClsSome pos) [] . nameTransTySynHelper id) [1..helpers] Cls _ -> [EntityConClsSome pos (nameTransTyConCls id) (mapListSnd nameTransLetVar posIds ++ mapListSnd nameShare posIds)] where (pCons,pFields) = partition (isTidCon.tokenId.snd) posIds -- ---------------------------------------------------------------------------- -- New top-level definitions for generating shared trace info -- -- Trace info for positions and identifier information. They have to be -- top-level, so that they (and their side-effect) are only evaluated once. -- INCOMPLETE: an optimising compiler may need noinline pragma. -- The variables referring to variable information need to include the -- position in the name, because the same variable name may be used several -- times. defNameMod :: Pos -> TraceId -> String -> Bool -> Decl TokenId defNameMod pos id filename traced = DeclFun pos (nameTraceInfoModule id) [Fun [] (Unguarded (ExpApplication pos [ExpVar pos tokenMkModule ,ExpLit pos (LitString Boxed (fixPrelude (getUnqualified id))) ,ExpLit pos (LitString Boxed filename) ,ExpCon pos (if traced then tTrue else tFalse)])) noDecls] where fixPrelude mod | "Prelude" `isPrefixOf` mod = "Prelude" | otherwise = mod defNameCon :: Exp TokenId -> (Pos,TraceId,[TraceId]) -> Decl TokenId defNameCon modTrace (pos,id,labels) = DeclFun pos (nameTraceInfoCon id) [Fun [] (Unguarded (ExpApplication pos (ExpVar pos (tokenMkAtomConstructor withLabels) :modTrace :encodePos pos ++ ExpLit pos (LitInt Boxed (fixPriority id)) :ExpLit pos (LitInt Boxed (fromJust (arity id))) :ExpLit pos (LitString Boxed (getUnqualified id)) :if withLabels then (:[]) . mkList pos . map (ExpVar pos . nameTraceInfoVar pos Global) $ labels else [] ))) noDecls] where withLabels = not (null labels) defNameVar :: Scope -> Scope -> Exp TokenId -> (Pos,TraceId) -> Decl TokenId defNameVar defScope visScope refMod (pos,id) = DeclFun pos (nameTraceInfoVar pos visScope id) [Fun [] (Unguarded (ExpApplication pos ( ExpVar pos tokenMkAtomVariable : refMod : encodePos pos ++ [ExpLit pos (LitInt Boxed (fixPriority id)) -- all identifiers in definition position are assumed to -- be equipped with an arity; -- only those defined by pattern bindings do not; they have arity 0. ,ExpLit pos (LitInt Boxed (case (arity id) of Just a -> a Nothing -> 0)) ,ExpLit pos (LitString Boxed (getUnqualified id)) ,ExpCon pos (if isLocal defScope then tTrue else tFalse)]))) noDecls] defNamePos :: Exp TokenId -> Pos -> Decl TokenId defNamePos modTrace pos = DeclFun pos (nameTraceInfoPos pos) [Fun [] (Unguarded (ExpApplication pos ( ExpVar pos tokenMkPos : modTrace : encodePos pos))) noDecls] encodePos :: Pos -> [Exp TokenId] -- encoding of positions in trace file encodePos pos = [ExpLit pos (LitInt Boxed (10000*beginRow + beginCol)) ,ExpLit pos (LitInt Boxed (10000*endRow + endCol))] where (beginRow,beginCol,endRow,endCol) = fromPos pos -- ---------------------------------------------------------------------------- -- abstract data type -- implements sets of positions, defined this-level and local variables, -- defined methods and defined constructors (no duplicates) -- this-level means defined on the currently considered declaration level, -- local means defined in some declaration local to the current declaration. -- variables and constructors come with the position at which they are defined -- precondition: a constructor with position is only added once -- a variable with position may be added several times, because -- position may be zero -- because same position may be used for a variable, an application etc, -- a position may be added several times. -- The scope states if the variable is defined globally or locally; data ModuleConsts = MC [Pos] -- positions used in traces [(Pos,TraceId)] -- this-level variable ids for traces [(Pos,TraceId)] -- variable ids for use in traces [(Pos,TraceId)] -- ids for methods for use in trace [(Pos,TraceId,[TraceId])] -- constructor ids for use in traces -- together with field labels (global) emptyModuleConsts :: ModuleConsts emptyModuleConsts = MC [] [] [] [] [] addPos :: Pos -> ModuleConsts -> ModuleConsts addPos pos (MC poss tids ids mids cons) = MC (pos `insert` poss) tids ids mids cons addVar :: Pos -> TraceId -> ModuleConsts -> ModuleConsts addVar pos id (MC poss tids ids mids cons) = MC (pos `insert` poss) ((pos,id) `insert` tids) ids mids cons addCon :: Pos -> TraceId -> [TraceId] -> ModuleConsts -> ModuleConsts addCon pos id labels (MC poss tids ids mids cons) = MC (pos `insert` poss) tids ids mids ((pos,id,labels) : cons) -- reclassify this-level variables as methods classifyMethods :: ModuleConsts -> ModuleConsts classifyMethods (MC poss tids ids [] cons) = MC poss [] ids tids cons -- both from the same declaration level merge :: ModuleConsts -> ModuleConsts -> ModuleConsts merge (MC poss1 tids1 ids1 mids1 cons1) (MC poss2 tids2 ids2 mids2 cons2) = MC (poss1 `union` poss2) (tids1 `union` tids2) (ids1 `union` ids2) (mids1 `union` mids2) (cons1 ++ cons2) -- combine this declaration level with a local declaration level withLocal :: ModuleConsts -> ModuleConsts -> ModuleConsts withLocal (MC poss1 tids1 ids1 mids1 cons1) (MC poss2 tids2 ids2 [] []) = MC (poss1 `union` poss2) tids1 (ids1 `union` tids2 `union` ids2) mids1 cons1 withLocal _ _ = error "TraceTrans.withLocal: locally defined data constructors or method" getModuleConsts :: ModuleConsts -> ([Pos],[(Pos,TraceId)],[(Pos,TraceId)] ,[(Pos,TraceId)],[(Pos,TraceId,[TraceId])]) getModuleConsts (MC pos tids ids mids cons) = (pos,tids,ids,mids,cons) -- avoid duplicate insert :: Eq a => a -> [a] -> [a] insert p ps = p : delete p ps -- ---------------------------------------------------------------------------- -- Transformation of declarations, expressions etc. -- the input of this transformation has a DeclFun for each definition equation -- the following function combines equations for a variable into one DeclFun combineFuns :: [Decl TraceId] -> [Decl TraceId] combineFuns (decl@(DeclFun pos id [fun]) : decls) = case combineFuns decls of (DeclFun pos2 id2 fun2s : decls') | tokenId id == tokenId id2 -> DeclFun (mergePos pos pos2) id (fun:fun2s) : decls' xs -> decl : xs combineFuns (decl : decls) = decl : combineFuns decls combineFuns [] = [] tDecls :: Scope -> Bool -> Exp TokenId -> Decls TraceId -> (Decls TokenId,ModuleConsts) tDecls scope traced parent (DeclsParse decls) = (DeclsParse decls',declsConsts) where (decls',declsConsts) = foldr combine ([],emptyModuleConsts) . map (tDecl scope traced parent) . combineFuns $ decls combine :: ([Decl id],[Decl id],ModuleConsts) -> ([Decl id],ModuleConsts) -> ([Decl id],ModuleConsts) combine (ds11,ds12,c1) (ds,c2) = (ds11++ds12++ds,c1 `merge` c2) -- for declarations in class and instance definitions: -- (considered local, because they have their own scope) tDecls2 :: (TokenId -> TokenId) -> Bool -> Exp TokenId -> Decls TraceId -> (Decls TokenId,[Decl TokenId],ModuleConsts) tDecls2 qualify traced parent (DeclsParse decls) = (DeclsParse (concat declss1 ++ catMaybes (map declSharedVar decls)) ,concat declss2 ,foldr merge emptyModuleConsts declsConstss) where (declss1,declss2,declsConstss) = unzip3 (map (tDecl2 qualify traced parent) . combineFuns $ decls) -- for a method type declaration produce type declaration of sharing var declSharedVar :: Decl TraceId -> Maybe (Decl TokenId) declSharedVar (DeclVarsType vars contexts ty) = Just (DeclVarsType (tPosShares vars) (tContexts contexts) (tConstType ty)) declSharedVar _ = Nothing tDecl2 :: (TokenId -> TokenId) -> Bool -> Exp TokenId -> Decl TraceId -> ([Decl TokenId],[Decl TokenId],ModuleConsts) tDecl2 _ traced parent decl@(DeclFun pos id (Fun (x:xs) rhs localDecls : funs)) = -- patch result of tFuns: -- worker needs to be local, because it does not belong to the -- class/instance nor can it be outside of it -- (no known arity optimisation anyway) ([DeclFun pos id' [Fun args' rhs' (DeclsParse workerDecls')]] ,[] ,declConsts') where ((DeclFun _ id' [Fun args' rhs' _]:_:workerDecls'),[],declConsts') = tDecl Local traced parent decl tDecl2 qualify traced parent decl@(DeclFun pos id ([Fun [] rhs localDecls])) = -- patch result of constant transformation -- use of sharing variable needs to be qualified if class name needs to be -- qualified (still covers not all necessary cases) -- note when declaring instance the class may only be imported qualified ([DeclFun pos id' [Fun args' (Unguarded (ExpApplication pos [a1,a2,a3,ExpVar pos (qualify id'')])) noDecls] ,shared'],[],declConsts') where ([DeclFun _ id' [Fun args' (Unguarded (ExpApplication _ [a1,a2,a3,ExpVar _ id''])) _] ,shared'],_,declConsts') = tCaf Local traced parent pos id rhs localDecls tDecl2 _ traced parent decl = -- type signature only possible remaining case tDecl Local traced parent decl singleDecl :: Decl id -> ([Decl id],[a],ModuleConsts) singleDecl decl = ([decl],[],emptyModuleConsts) -- Sharing of constants in classes/instances -- may be lost if class/instance has a context, -- because then the shareId also has this context and is no longer a constant. -- Division of result declarations into two lists seems to be rather -- pointless (needed in older version); -- could just return a single list instead. tDecl :: Scope -> Bool -> Exp TokenId -> Decl TraceId -> ([Decl TokenId],[Decl TokenId],ModuleConsts) tDecl _ _ _ synDecl@(DeclType lhsTy rhsTy) = (map tTypeSynonym (splitSynonym synDecl),[],emptyModuleConsts) where tTypeSynonym :: Decl TraceId -> Decl TokenId tTypeSynonym (DeclType lhsTy rhsTy) = DeclType (tSimple lhsTy) (tType rhsTy) splitSynonym :: Decl TraceId -> [Decl TraceId] splitSynonym d@(DeclType (Simple pos tySyn tyVars) rhs) = d : zipWith mkDeclType (hrhss rhs) [1..] where mkDeclType hrhs no = DeclType (Simple pos (mkTyCon defaultAuxInfo (nameTransTySynHelper tySyn no)) tyVars) hrhs hrhss rhs = case rhs of (TypeCons _ tyCon tys) | isFunTyCon tyCon -> go rhs | isExpandableTypeSynonym tyCon -> hrhss (expandTypeSynonym tyCon tys) (TypeApp ty1 ty2) -> go rhs _ -> [] -- nothing to split off -- it is vital that this `go' agrees with the `go' in `splitSynonym' in -- AuxFile. Sadly the module structure of Hat is such that the two -- functions cannot sit next to each other (or be combined) without -- introducing a separate module for them. go :: Type TraceId -> [Type TraceId] go (TypeCons _ tyCon tys) | isFunTyCon tyCon = case tys of [] -> [] [ty] -> [ty] [ty1,ty2] -> ty1 : (go ty2) | isExpandableTypeSynonym tyCon = go (expandTypeSynonym tyCon tys) go (TypeApp ty1 ty2) = go ty1 ++ go ty2 go (TypeVar _ _) = [] go ty = [ty] -- The helper synonyms are necessary for the following reason: -- The known-arity optimisation requires that workers of functions with -- known arity are defined on the same level as their wrapper, not local -- to them. If the original function was recursive, the worker will be -- recursive instead of calling the wrapper (as without known-arity opt.). -- Hence if the original definition had a type signature, then the worker -- needs a type signature as well (the wrapper gets one anyway), -- because otherwise its inferred type might not be general enough -- (polymorphic recursion) or too general (type class ambiguities, -- problems with existential types). -- Transformation of the original type signature into the worker type -- signature is not uniform: function types are handled specially. -- So if the type includes a type synonym it may not be possible to use -- the transformed type synonym, but the original one has to be expanded -- and transformed in this non-uniform way. However, in general a type -- synonym cannot be expanded, because the rhs might not be in scope at -- the synonym use site. Hence a type synonym is split into an outer part -- consisting of function types,type applications and type variables, -- which can and may need to be expanded, and several inner type parts, -- for which new helper type synonyms are defined. These are always -- ex- and imported with the type synonym itself. -- A lot of effort, but it does work in the end. tDecl Global traced _ (DeclData sort contexts lhsTy constrs pClss) = ([DeclData sort (tContexts contexts) (tSimple lhsTy) (map tConstr constrs) []] -- "derive" should be empty, because transformed classes cannot be derived ,instDecl:fieldSelectorDecls++deriveDecls ,foldr addConInfo (fieldSelectorConsts `merge` deriveConsts) constrs) where (DeclsParse deriveDecls,deriveConsts) = tDecls Global False (mkRoot noPos) (DeclsParse (derive contexts lhsTy constrs pClss)) instDecl = wrapValInstDecl traced (getPos lhsTy) contexts lhsTy constrs (fieldSelectorDecls,fieldSelectorConsts) = mkFieldSelectors constrs addConInfo :: Constr TraceId -> ModuleConsts -> ModuleConsts addConInfo constr = addCon (getPos constr) (getConstrId constr) (map snd (getConstrLabels constr)) tDecl _ _ _ (DeclDataPrim pos id size) = error ("Cannot trace primitive data type (" ++ show (tokenId id) ++ " at position " ++ strPos pos ++ ")") tDecl _ traced parent (DeclClass pos contexts clsId tyIds fundeps decls) = ([DeclClass pos (tContexts contexts) (nameTransTyConCls clsId) (map nameTransTyVar tyIds) (map (fmap nameTransTyVar) fundeps) decls1] ,decls2 -- auxiliary definitions have to be outside the class definition ,classifyMethods declsConsts) where (decls1,decls2,declsConsts) = tDecls2 id traced parent decls tDecl _ traced parent (DeclInstance pos contexts clsId insts decls) = ([DeclInstance pos (tContexts contexts) clsId' (map tType insts) decls1] ,decls2 -- auxiliary definitions have to be outside the instance definition ,classifyMethods declsConsts) where clsId' = nameTransTyConCls clsId qualify = case clsId' of Qualified modrps _ -> forceM modrps _ -> id (decls1,decls2,declsConsts) = tDecls2 qualify traced parent decls tDecl _ _ _ (DeclDefault tys) = ([],[],emptyModuleConsts) -- defaulting does not work anyway, maybe warn about nonempty one? tDecl _ _ _ d@(DeclPrimitive pos fnId arity ty) = error "TraceTrans:tDecl _ _ _ (DeclPrimitive _ _ _ _) should not occur" tDecl _ _ _ (DeclForeignImp pos Haskell hasName fnId arity _ ty _) = tHaskellPrimitive pos (if null revHasModNameP then visible revHasUnqualName else (qualify (tail revHasModNameP) revHasUnqualName)) fnId arity ty where (revHasUnqualName,revHasModNameP) = span (/= '.') . reverse $ hasName tDecl _ _ _ (DeclForeignImp pos callConv cname fnId arity fspec ty duplicateId) = (funDecls ,DeclForeignImp pos callConv (if null cname then getUnqualified fnId else cname) (nameForeign fnId) arity fspec (typePlain ty) (nameForeign fnId) :wrapperDecls ,consts) where (funDecls,wrapperDecls,consts) = tHaskellPrimitive pos (nameForeign fnId) fnId arity ty tDecl _ _ _ (DeclForeignExp pos callConv str fnId _) = error ("Cannot trace foreign export (used at " ++ strPos pos ++ ")") tDecl _ _ _ (DeclVarsType vars contexts ty) = -- type signatures need to be preserved (i.e. transformed), -- because e.g. polymorphic recursion needs them, more general -- types may later lead to ambiguous types ([DeclVarsType (tPosExps vars) (tContexts contexts) (tFunType ty)] ++ concatMap mkWorkerVarsType nonConstVars -- shared constants need to be typed, in case they are overloaded, -- so that monomorphic restriction does not lead to type error -- (actually then sharing is unfortunately lost) ++ if null constVars then [] else [DeclVarsType (tPosShares constVars) (tContexts contexts) (tConstType ty)] ,[],emptyModuleConsts) where (constVars,nonConstVars) = partition (isNonMethodConstant . snd) vars isNonMethodConstant :: TraceId -> Bool isNonMethodConstant id = isLambdaBound id || -- variables in pattern bindings are lambda bound (case arity id of Just n -> n == 0 Nothing -> False) mkWorkerVarsType :: (Pos,TraceId) -> [Decl TokenId] mkWorkerVarsType (pos,id) = case arity id of Just n | n > 0 -> [DeclVarsType [(pos,nameWorker id)] (tContexts contexts) (tWorkerType n ty)] _ -> [] {- -- Variables of arity 0 do not take SR and Trace argument, so that -- their values are shared. Note that type signatures for class methods -- are handled differently by tDecl2 ((if null constVars then [] else [DeclVarsType (tPosExps constVars) (tContexts contexts) (tConstType ty)]) ++ (if null nonConstVars then [] else [DeclVarsType (tPosExps nonConstVars) (tContexts contexts) (tFunType ty)]) ,[],emptyModuleConsts) where (constVars,nonConstVars) = partition (isNonMethodConstant . snd) vars isNonMethodConstant :: TraceId -> Bool isNonMethodConstant id = isLambdaBound id || -- variables in pattern bindings are lambda bound (case arity id of Just n -> n == 0 Nothing -> False) -} tDecl scope traced parent (DeclPat (Alt (ExpVar pos id) rhs decls)) = -- this case may occur because of the next equation tCaf scope traced parent pos id rhs decls tDecl scope traced parent (DeclPat (Alt (PatAs pos id pat) rhs decls)) = (dFun1++dPat1,dFun2++dPat2,funConsts `merge` patConsts) where id' = modLetBound id (dFun1,dFun2,funConsts) = tCaf scope traced parent pos id' rhs decls (dPat1,dPat2,patConsts) = tDecl scope traced parent (DeclPat (Alt pat (Unguarded (ExpVar pos id')) noDecls)) tDecl scope traced parent (DeclPat (Alt pat rhs decls)) = -- unfortunately we cannot transform a pattern binding into another pattern -- binding; we have to introduce an explicit `case' to be able to terminate -- with an appropriate error message when the pattern does not match. -- first rewrite as p = e, then -- xi sr p = constUse sr p zi -- zi = constDef parent -- (\_ -> (case patId of (t,y1,..,yn) -> projection sr t yi)) -- patId = case e' of -- p' -> (t,y1,..,yn) -- _ -> fail noPos parent (map useDef patPosIds ,DeclFun noPos patId [Fun [] (Unguarded (ExpCase noPos exp' [Alt pat'' (Unguarded tuple) noDecls ,Alt (PatWildcard noPos) (Unguarded (mkFailExp noPos parent)) noDecls ])) decls'] : map projDef patPosIds ,foldr (\(pos,id) -> addVar pos id) (emptyModuleConsts `withLocal` altConsts) patPosIds) where pos = getPos pat firstId = snd . head $ patPosIds patId = nameTraceShared pos firstId resultTraceId = nameTrace2 firstId tuple = mkTupleExp noPos (ExpVar noPos resultTraceId : patVars') patPosIds = map (\(ExpVar pos id) -> (pos,id)) patVars (patVars',Nothing) = tPats patVars patVars = getPatVars pat pat'' = case pat' of ExpApplication p [r,v,_] -> ExpApplication p [r,v,ExpVar noPos resultTraceId] (Fun [pat'] (Unguarded exp') decls',altConsts) = tFun traced False parent failContinuation (Fun [pat] rhs decls) useSR = ExpVar pos (nameSR firstId) useParent = mkParentVar pos useDef :: (Pos,TraceId) -> Decl TokenId useDef (pos,id) = DeclFun pos (nameTransLetVar id) [Fun [useSR,useParent] (Unguarded (ExpApplication pos [combConstUse pos traced,useSR,useParent,ExpVar pos (nameShare id)])) noDecls] projDef :: (Pos,TraceId) -> Decl TokenId projDef (pos,id) = DeclFun pos (nameShare id) [Fun [] (Unguarded (ExpApplication pos [combConstDef pos traced ,parent ,ExpVar pos (nameTraceInfoVar pos scope id) ,ExpLambda pos [PatWildcard pos] (ExpCase pos (ExpVar pos patId) [Alt tuple (Unguarded (if isLocal scope && not traced then ExpVar pos (nameTransLambdaVar id) else ExpApplication pos [ExpVar pos tokenProjection ,mkSRExp pos traced ,ExpVar pos resultTraceId ,ExpVar pos (nameTransLambdaVar id)])) noDecls])])) noDecls] getPatVars :: Pat id -> [Pat id] getPatVars (ExpRecord pat fields) = getPatVars pat ++ concatMap getFieldVars fields where getFieldVars (FieldExp _ _ pat) = getPatVars pat getPatVars (ExpApplication _ pats) = concatMap getPatVars pats getPatVars pat@(ExpVar pos id) = [pat] getPatVars (ExpCon _ _) = [] getPatVars (ExpLit _ _) = [] getPatVars (ExpList _ pats) = concatMap getPatVars pats getPatVars (PatAs pos id pat) = ExpVar pos id : getPatVars pat getPatVars (PatWildcard _) = [] getPatVars (PatIrrefutable _ pat) = getPatVars pat tDecl scope traced parent (DeclFun pos id [Fun [] rhs localDecls]) = tCaf scope traced parent pos id rhs localDecls -- a caf has many dynamic parents and hence uses the static parent tDecl _ _ parent (DeclFun pos id (Fun [] _ _ : _)) = error ("Variable multiple defined: " ++ show (tokenId id)) tDecl scope traced parent (DeclFun pos id funs) = tFuns scope traced pos id funs -- a function does not use the static parent tDecl _ _ _ (DeclFixity _) = ([],[],emptyModuleConsts) -- fixity declarations have been processed before -- not needed in output, because pretty printer produces unambiguous output tDecl _ _ _ (DeclIgnore s) = ([DeclIgnore s],[],emptyModuleConsts) tDecl _ _ _ _ = error "tDecl: unknown sort of declaration" -- constructor definition in type definition tConstr :: Constr TraceId -> Constr TokenId tConstr (Constr pos conId tyArgs) = Constr pos (nameTransCon conId) (tTyArgs tyArgs) tConstr (ConstrCtx tyVars contexts pos conId tyArgs) = ConstrCtx (tPosTyVars tyVars) (tContexts contexts) pos (nameTransCon conId) (tTyArgs tyArgs) -- build the instance of class WrapVal for type with given data constructors -- this instance is needed for constructing and updating with labelled fields wrapValInstDecl :: Bool -> Pos -> [Context TraceId] -> Simple TraceId -> [Constr TraceId] -> Decl TokenId wrapValInstDecl traced pos contexts ty constrs = DeclInstance pos (map (fmap tokenId) contexts) tokenWrapValClass [(fmap tokenId (simpleToType ty))] (DeclsParse [DeclFun pos (dropM tokenWrapValFun) (map wrapValFun constrs)]) where traceTokenWrapValFun = mkLambdaBound (initAuxInfo traced) (dropM tokenWrapValFun) sr = ExpVar pos (nameSR traceTokenWrapValFun) parent = mkParentVar pos varId = nameTrace2 traceTokenWrapValFun -- actually not a trace var = ExpVar pos varId infiniteTraces = map (ExpVar pos) . nameArgs $ traceTokenWrapValFun wrapValFun :: Constr TraceId -> Fun TokenId wrapValFun constr = Fun [sr,PatAs pos varId consApp,parent] (Unguarded (wrapExp pos var consAppTrace)) noDecls where consAppTrace = if numOfArgs == 0 then ExpApplication pos [ExpVar pos tokenMkExpValueUse,parent,sr,funAtom] else ExpApplication pos . (ExpVar pos (tokenMkExpValueApp numOfArgs) :) . (parent :) . (sr :) . (funAtom :) $ traces funAtom = ExpVar pos (nameTraceInfoCon consId) consApp = if numOfArgs == 0 then ExpCon pos (tokenId consId) else ExpApplication pos . (ExpCon pos (tokenId consId) :) . map (wrapExp pos (PatWildcard pos)) $ traces consId = getConstrId constr traces = take numOfArgs infiniteTraces :: [Exp TokenId] numOfArgs = sum . map (repeated . fst) $ constrArgs repeated Nothing = 1 repeated (Just labels) = length labels constrArgs :: [(Maybe [(Pos,TraceId)],Type TraceId)] constrArgs = getConstrArgumentList constr tHaskellPrimitive :: Pos -> TokenId -> TraceId -> Arity -> Type TraceId -> ([Decl TokenId],[Decl TokenId],ModuleConsts) tHaskellPrimitive pos hasId fnId arity ty -- import of a Haskell function -- used for defining builtin Haskell functions -- transformation yields a wrapper to the untransformed function | arity == 0 = ( [ DeclVarsType [(pos,nameTransLetVar fnId)] [] (tFunType ty) , DeclFun pos (nameTransLetVar fnId) [ Fun [sr,parent] (Unguarded (ExpApplication pos [combConstUse pos False,sr ,parent,ExpVar pos shareId])) noDecls ] ] , [DeclFun pos shareId [Fun [] (Unguarded (ExpApplication pos [combConstDef pos False,mkRoot pos ,ExpVar pos (nameTraceInfoVar pos Global fnId) ,ExpLambda pos [parent] (ExpApplication pos [expFrom pos ty,parent, ExpVar pos hasId])])) noDecls]] , addVar pos fnId emptyModuleConsts) | otherwise = ([DeclVarsType [(pos,nameTransLetVar fnId)] [] (tFunType ty) ,DeclFun pos (nameTransLetVar fnId) [Fun [sr,parent] (Unguarded (ExpApplication pos [combFun pos False arity ,ExpVar pos (nameTraceInfoVar pos Global fnId) ,sr,parent,ExpVar pos wrappedId'])) noDecls]] ,[DeclFun pos wrappedId' [Fun (args++[hidden]) (Unguarded (ExpApplication pos [expFrom pos tyRes,hidden ,ExpApplication pos (ExpVar pos hasId : zipWith to tyArgs args)])) noDecls]] ,addVar pos fnId emptyModuleConsts) where parent = mkParentVar pos sr = ExpVar pos (nameSR fnId) hidden = ExpVar pos (nameTrace2 fnId) args = take arity . map (ExpVar pos) . nameArgs $ fnId wrappedId' = nameWorker fnId shareId = nameShare fnId to :: Type TraceId -> Exp TokenId -> Exp TokenId to ty arg = ExpApplication pos [expTo pos ty, hidden, arg] -- assert: length (tyArgs) = arity (tyArgs,tyRes) = decomposeFunType ty decomposeFunType :: Type TraceId -> ([Type TraceId],Type TraceId) decomposeFunType (TypeCons _ tyCon [ty1,ty2]) | isFunTyCon tyCon = (ty1:args,res) where (args,res) = decomposeFunType ty2 decomposeFunType ty = ([],ty) mkFieldSelectors :: [Constr TraceId] -> ([Decl TokenId],ModuleConsts) mkFieldSelectors constrs = foldr combine ([],emptyModuleConsts) . map (uncurry mkFieldSelector) $ nonDuplicatePosFields where combine :: ([Decl TokenId],ModuleConsts) -> ([Decl TokenId],ModuleConsts) -> ([Decl TokenId],ModuleConsts) combine (decls1,modConsts1) (decls2,modConsts2) = (decls1++decls2,modConsts1 `merge` modConsts2) nonDuplicatePosFields :: [(Pos,TraceId)] nonDuplicatePosFields = nubBy (\(_,id1) (_,id2) -> tokenId id1 == tokenId id2) posFields posFields = concat [pf | (Just pf,_) <- concatMap getConstrArgumentList constrs] -- construct the traced version of a field selector, using the -- normal field selector, i.e. from zname :: T -> R Int construct -- gname :: SR -> Trace -> R (Fun T Int) -- gname sr p = fun1 "name" hname sr p -- hname :: Trace -> R T -> R Int -- hname p (R v _) = projection mkNoSrcPos p (zname v) mkFieldSelector :: Pos -> TraceId -> ([Decl TokenId],ModuleConsts) mkFieldSelector pos fieldId = ([DeclFun pos (nameTransLetVar fieldId) [Fun [sr,parent] (Unguarded (ExpApplication pos [combFun pos False 1 ,ExpVar pos (nameTraceInfoVar pos Global fieldId) ,sr,parent,ExpVar pos wrappedId'])) noDecls] ,DeclFun pos wrappedId' [Fun [wrapExp pos var (PatWildcard pos),parent] (Unguarded (ExpApplication pos [ExpVar pos tokenProjection,mkSRExp pos False,parent ,ExpApplication pos [ExpVar pos (nameTransField fieldId),var] ])) noDecls]] ,addVar pos fieldId emptyModuleConsts) where sr = ExpVar pos (nameSR fieldId) parent = mkParentVar pos wrappedId' = nameWorker fieldId var = ExpVar pos varId varId:_ = nameArgs fieldId tCaf :: Scope -> Bool -> Exp TokenId -> Pos -> TraceId -> Rhs TraceId -> Decls TraceId -> ([Decl TokenId],[Decl TokenId],ModuleConsts) tCaf scope traced parent pos id rhs localDecls = -- id sr p = constUse sr p id' -- id' = constDef parent "id" (\p' -> [[rhs]]_p') ([DeclFun pos (nameTransLetVar id) [Fun [useSR,useParent] (Unguarded (ExpApplication pos [combConstUse pos traced,useSR,useParent,id'])) noDecls] ,DeclFun pos idId' [Fun [] (Unguarded (ExpApplication pos [combConstDef pos traced,parent ,ExpVar pos (nameTraceInfoVar pos scope id) ,ExpLambda pos [useParent] (smartExpLet pos localDecls' rhs')])) noDecls]] ,[] ,addVar pos id emptyModuleConsts `withLocal` (rhsConsts `merge` localDeclsConsts)) where idId' = nameShare id id' = ExpVar pos idId' useSR = ExpVar pos (nameSR id) useParent = mkParentVar pos (rhs',rhsConsts) = tRhs traced True useParent failContinuation rhs (localDecls',localDeclsConsts) = tDecls Local traced useParent localDecls smartExpLet :: Pos -> Decls a -> Exp a -> Exp a smartExpLet pos (DeclsParse []) e = e smartExpLet pos decls e = ExpLet pos decls e tFuns :: Scope -> Bool -> Pos -> TraceId -> [Fun TraceId] -> ([Decl TokenId],[Decl TokenId],ModuleConsts) tFuns scope traced pos id funs = (DeclFun pos (nameTransLetVar id) [Fun [sr,parent] (Unguarded (ExpApplication pos [combFun pos traced funArity ,ExpVar pos (nameTraceInfoVar pos scope id) ,sr,parent,ExpVar pos wrappedId'])) noDecls] : (if isLocal scope then (DeclFun pos (nameTraceInfoVar pos Global id) [Fun [] (Unguarded (ExpVar pos (nameTraceInfoVar pos Local id))) noDecls] :) else \x->x) (DeclFun pos wrappedId' (funs') : newDecls') -- The known-arity application optimisation needs a nameTraceInfoVar of -- the global kind (the name does not include the definition position) -- Hence for local definitions we need to define the nameTraceInfoVar -- in terms of the "local" nameTraceInfoVar that is defined globally. -- In same scope as type decl , [] ,addVar pos id (emptyModuleConsts `withLocal` funConsts)) where funArity = case funs of (Fun pats _ _ : _) -> length pats sr = ExpVar pos (nameSR id) parent = mkParentVar pos wrappedId' = nameWorker id (funs',newDecls',funConsts) = tFunClauses traced pos parent (nameFuns id) (map (ExpVar pos) (nameArgs id)) funArity False funs tFunClauses :: Bool -> Pos -> Exp TokenId -- variable that can be bound to parent -> [TokenId] -- ids for definitions that clauses are turned into -> [Exp TokenId] -- vars for naming arguments that are not vars -> Arity -> Bool -- preceeding fun-clause will never fail -> [Fun TraceId] -> ([Fun TokenId],[Decl TokenId],ModuleConsts) tFunClauses _ _ _ _ _ _ True [] = ([],[],emptyModuleConsts) tFunClauses _ pos parent ids pVars funArity False [] = ([Fun (replicate funArity (PatWildcard pos) ++ [parent]) (Unguarded (continuationToExp parent failContinuation)) noDecls] ,[],emptyModuleConsts) tFunClauses traced pos parent ids pVars funArity _ (fun@(Fun pats _ _) : funs) | not (null funs) && funCanFail fun = ([Fun (pats'' ++ [parent]) rhs' decls' ,Fun (vars ++ [parent]) (Unguarded (continuationToExp parent failCont)) noDecls] ,DeclFun pos contId funs' : funsDecls ,funConsts `merge` funsConsts) where contId = head ids failCont = functionContinuation contId vars (pats'',vars) = namePats pats' pVars (Fun pats' rhs' decls',funConsts) = tFun traced True parent failCont fun (funs',funsDecls,funsConsts) = tFunClauses traced pos parent (tail ids) pVars funArity (neverFailingPats pats) funs tFunClauses traced pos parent ids pVars funArity _ (fun@(Fun pats _ _): funs) = -- last clause or guards and numeric literals cannot fail (Fun (pats'++[parent]) rhs' decls' : funs' ,funsDecls ,funConsts `merge` funsConsts) where (Fun pats' rhs' decls',funConsts) = tFun traced True parent failContinuation fun (funs',funsDecls,funsConsts) = tFunClauses traced pos parent ids pVars funArity (neverFailingPats pats) funs {- -- Numeric literals need to be overloaded with respect to the new -- transformed numeric classes; hence they cannot just be left wrapped -- in patterns -- Transform such literals into equality conditions in guards. -- Need also to desugare ~, because that is the easiest way to deal with -- literals within the scope of a ~. NOT YET DONE. tFun :: Bool -- traced -> Bool -- this is reduct of parent -> Exp TokenId -- parent -> ContExp -- continuation in case of pattern match failure -> Fun TraceId -> (Fun TokenId,ModuleConsts) -- Definition similar to tGuardedExps tFun traced cr parent contExp (Fun pats rhs decls) = if null conditions -- implies null patsDecls then (Fun pats' (Unguarded rhs') decls',declsConsts `withLocal` rhsConsts) else (Fun pats' (Unguarded (ExpApplication pos (if traced then [combGuard pos True,mkSRExp pos traced,parent,cond' ,ExpLambda pos [newParent] (ExpLet pos patsDecls' rhs') ,ExpLambda pos [newParent] (continuationToExp newParent contExp)] else [combGuard pos False,cond',ExpLet pos patsDecls' rhs' ,continuationToExp parent contExp]) )) decls' ,pos `addPos` condConsts `merge` patsDeclsConsts `merge` declsConsts `withLocal` rhsConsts) -- condConsts contains positions of the boolean expressions -- patsDeclsConsts contains positions of the bound variables where (pats',conditions,patsDecls) = tPats pats (patsDecls',patsDeclsConsts) = tDecls Local traced (if traced then newParent else parent) (DeclsParse patsDecls) (cond',condConsts) = tExp traced False parent (foldr1 andExp conditions) (rhs',rhsConsts) = tRhs traced cr (if null conditions || not traced then parent else newParent) contExp rhs (decls',declsConsts) = tDecls Local traced parent decls andExp :: Exp TraceId -> Exp TraceId -> Exp TraceId andExp e1 e2 = ExpApplication pos [ExpVar pos tTokenAndAnd,e1,e2] pos = getPos pats newParent = ExpVar pos (nameFromPos pos) -} -- Numeric literals need to be overloaded with respect to the new -- transformed numeric classes; hence they cannot just be left wrapped -- in patterns -- Transform such literals and n+k patterns into conditions in guards. -- Have to be careful to preserve left-to-right pattern matching, -- e.g. f 1 True = ... -> f x True | x == 1 = ... is wrong. -- Assume that ~ has been removed before. tFun :: Bool -- traced -> Bool -- this is reduct of parent -> Exp TokenId -- parent -> ContExp -- continuation in case of pattern match failure -> Fun TraceId -> (Fun TokenId,ModuleConsts) -- Definition similar to tGuardedExps tFun traced cr parent contExp (Fun pats rhs decls) = if isNothing numericLitInfos then (Fun pats' (Unguarded rhs') decls',declsConsts `withLocal` rhsConsts) else (Fun pats' (Unguarded (ExpApplication pos (if traced then [combGuard pos True,mkSRExp pos traced,parent,cond' ,ExpLambda pos [parent] (ExpApplication pos (ExpVar pos nameFun:argvars++[parent])) ,ExpLambda pos [parent] (continuationToExp parent contExp)] else [combGuard pos False,cond' ,ExpApplication pos (ExpVar pos nameFun:argvars++[parent]) ,continuationToExp parent contExp]) )) (DeclsParse (def:decl')) ,pos `addPos` condConsts `merge` declConsts `merge` funConsts) -- condConsts contains positions of the boolean expressions -- patsDeclsConsts contains positions of the bound variables where (pats',numericLitInfos) = tPats pats (rhs',rhsConsts) = tRhs traced cr parent contExp rhs (decls',declsConsts) = tDecls Local traced parent decls Just (cond,bindings,argvars,argpats) = numericLitInfos (cond',condConsts) = tExp traced False parent cond (DeclsParse decl',declConsts) = tDecls Local traced parent (DeclsParse bindings) def = DeclFun pos nameFun [Fun (fpats'++[parent]) frhs' fdecls' ,Fun (replicate funArity (PatWildcard pos) ++ [parent]) (Unguarded (continuationToExp parent contExp)) noDecls] funArity = length argpats (Fun fpats' frhs' fdecls',funConsts) = tFun traced cr parent contExp (Fun argpats rhs decls) pos = getPos pats funCanFail :: Fun TraceId -> Bool funCanFail (Fun pats rhs _) = any numericLitIn pats || case rhs of Unguarded _ -> False Guarded gdExps -> gdExpsCanFail gdExps numericLitIn :: Pat TraceId -> Bool numericLitIn (ExpRecord pat fields) = numericLitIn pat || any numericLitInField fields where numericLitInField (FieldExp _ _ pat) = numericLitIn pat numericLitIn (ExpApplication _ pats) = any numericLitIn pats numericLitIn (ExpList _ pats) = any numericLitIn pats numericLitIn (PatAs _ _ pat) = numericLitIn pat numericLitIn (PatIrrefutable _ pat) = numericLitIn pat numericLitIn (ExpLit _ (LitInteger _ _)) = True numericLitIn (ExpLit _ (LitRational _ _)) = True numericLitIn _ = False -- Returns False only if one of the guards definitely evaluates to True. gdExpsCanFail :: [(Exp TraceId,Exp TraceId)] -> Bool gdExpsCanFail [] = True gdExpsCanFail ((ExpCon _ cid, _) : gdExps) = not (isTrue cid) && gdExpsCanFail gdExps gdExpsCanFail ((ExpVar _ cid, _) : gdExps) = not (isOtherwise cid) && gdExpsCanFail gdExps gdExpsCanFail (_ : gdExps) = gdExpsCanFail gdExps namePats :: [Pat TokenId] -> [Pat TokenId] -> ([Pat TokenId],[Pat TokenId]) namePats pats vars = unzip (zipWith namePat pats vars) -- Obtain a variable that names the given pattern; -- straightforward if pattern has variable at top-level; -- otherwise use provided variable namePat :: Pat TokenId -- pattern to name -> Pat TokenId -- default variable -> (Pat TokenId,Pat TokenId) -- named pattern, name variable namePat pat@(ExpVar _ _) _ = (pat,pat) namePat pat@(PatAs pos id pat') _ = (pat,ExpVar pos id) namePat pat var@(ExpVar pos id) = (PatAs pos id pat,var) tRhs :: Bool -- traced? -> Bool -- equal to parent? -> Exp TokenId -- parent -> ContExp -- continuation in case of pattern match failure -> Rhs TraceId -> (Exp TokenId,ModuleConsts) tRhs traced cr parent failCont (Unguarded exp) = tExp traced cr parent exp tRhs traced cr parent failCont (Guarded gdExps) = tGuardedExps traced cr parent failCont gdExps tGuardedExps :: Bool -- traced? -> Bool -- equal to parent? -> Exp TokenId -- parent -> ContExp -- continuation in case of pattern match failure -> [(Exp TraceId,Exp TraceId)] -> (Exp TokenId,ModuleConsts) tGuardedExps _ cr parent failCont [] = (continuationToExp parent failCont,emptyModuleConsts) tGuardedExps True cr parent failCont ((guard,exp):gdExps) = (ExpApplication pos [combGuard pos True,mkSRExp pos True,parent,guard' ,ExpLambda pos [parent] exp',ExpLambda pos [parent] gdExps'] ,pos `addPos` guardConsts `merge` expConsts `merge` gdExpsConsts) where (guard',guardConsts) = tExp True False parent guard (exp',expConsts) = tExp True cr parent exp (gdExps',gdExpsConsts) = tGuardedExps True cr parent failCont gdExps pos = getPos guard tGuardedExps False cr parent failCont ((guard,exp):gdExps) = (ExpApplication pos [combGuard pos False,guard',exp',gdExps'] ,guardConsts `merge` expConsts `merge` gdExpsConsts) where (guard',guardConsts) = tExp False False parent guard (exp',expConsts) = tExp False cr parent exp (gdExps',gdExpsConsts) = tGuardedExps False cr parent failCont gdExps pos = getPos guard -- ----------------------------------------- -- Abstract continuation for guards -- -- To correctly create the trace within guards, a continuation is used. -- The type ContExp should be abstract. Its implementation is only used in -- the following three functions. data ContExp = Fail | Function TokenId [Exp TokenId] failContinuation :: ContExp failContinuation = Fail functionContinuation :: TokenId -> [Exp TokenId] -> ContExp functionContinuation = Function continuationToExp :: Exp TokenId -- trace -> ContExp -> Exp TokenId continuationToExp parent Fail = mkFailExp noPos parent continuationToExp parent (Function fun args) = ExpApplication noPos (ExpVar noPos fun : args ++ [parent]) mapMerge2 :: (a -> (b,ModuleConsts)) -> [a] -> ([b],ModuleConsts) mapMerge2 f = mapSnd (foldr merge emptyModuleConsts) . unzip . map f -- Transform expressions tExps :: Bool -- traced -> Exp TokenId -- parent -> [Exp TraceId] -- expressions -> ([Exp TokenId],ModuleConsts) tExps traced parent = mapMerge2 (tExp traced False parent) tExpsC traced parent = mapMerge2 (tExp traced True parent) -- Second argument True iff the parent is equal to this expression, i.e., -- the result of this expression is the same as the result of the parent. tExp :: Bool -> Bool -> Exp TokenId -> Exp TraceId -> (Exp TokenId,ModuleConsts) tExp traced cr parent (ExpScc _ l@(ExpLambda _ _ _)) = -- ExpScc is a hack to inform that this lambda is really a do-stmt. (ExpApplication pos [fun, ExpVar pos tokenMkAtomDoLambda, sr, par, lambda] ,rpos) where (ExpApplication pos [fun, _, sr, par, lambda],rpos) = tExp traced cr parent l tExp traced cr parent (ExpLambda pos pats body) = (ExpApplication pos [combFun pos traced funArity ,ExpVar pos tokenMkAtomLambda ,mkSRExp pos traced ,parent ,if neverFailingPats pats then ExpLambda pos (pats' ++ [parent]) body' else ExpLambda pos (vars ++ [parent]) (ExpCase pos (mkTupleExp pos vars) [Alt (mkTupleExp pos pats') (Unguarded body') noDecls ,Alt (PatWildcard pos) (Unguarded (mkFailExp pos parent)) noDecls])] ,pos `addPos` bodyConsts) where (Fun pats' (Unguarded body') _,bodyConsts) = tFun traced True parent failContinuation (Fun pats (Unguarded body) noDecls) vars = map (ExpVar pos) . take funArity $ varsIds varsIds = namesFromPos pos funArity = length pats tExp traced cr parent (ExpLet pos decls body) = (ExpLet pos decls' body' ,declConsts `withLocal` bodyConsts) where (decls',declConsts) = tDecls Local traced parent decls (body',bodyConsts) = tExp traced cr parent body tExp traced cr parent (ExpDo pos stmts) = tExp traced cr parent (removeDo traced stmts) tExp traced cr parent (ExpCase pos e alts) = (ExpApplication pos [combCase pos traced,mkSRExp pos traced,parent ,ExpLet pos (DeclsParse (DeclFun pos varId fun' : defs')) (ExpVar pos varId) ,e'] ,pos `addPos` eConsts `merge` funConsts) where (varId:argId:funsIds) = namesFromPos pos (e',eConsts) = tExp traced False parent e (fun',defs',funConsts) = tFunClauses traced pos parent funsIds [ExpVar pos argId] 1 False . map alt2Fun $ alts tExp True cr parent (ExpIf pos cond e1 e2) = (ExpApplication pos [combIf pos True,mkSRExp pos True,parent,cond' ,ExpLambda pos [parent] e1',ExpLambda pos [parent] e2'] ,pos `addPos` condConsts `merge` e1Consts `merge` e2Consts) where (cond',condConsts) = tExp True False parent cond (e1',e1Consts) = tExp True True parent e1 (e2',e2Consts) = tExp True True parent e2 tExp False cr parent (ExpIf pos cond e1 e2) = (ExpApplication pos [combIf pos False,parent,cond',e1',e2'] ,condConsts `merge` e1Consts `merge` e2Consts) where (cond',condConsts) = tExp False False parent cond (e1',e1Consts) = tExp False True parent e1 (e2',e2Consts) = tExp False True parent e2 tExp traced cr parent (ExpType pos e contexts ty) = (ExpType pos e' (tContexts contexts) (wrapType (tType ty)) ,eConsts) where (e',eConsts) = tExp traced cr parent e tExp traced cr parent (ExpApplication pos (f@(ExpCon _ _) : es))= tConApp pos traced parent f es tExp traced cr parent (ExpApplication pos (f@(ExpVar idPos id) : es)) | case arity id of Nothing -> False Just a -> a > 0 && a == length es && a <= 5 = -- optimised for this special case (if traced || isTraced id then ExpApplication pos (combApplyArity pos (isTraced id) (length es): mkSRExp pos traced:mkSRExp idPos traced:parent: ExpVar pos (nameTraceInfoVar pos Global id): ExpVar pos (nameWorker id):es') else ExpApplication pos (ExpVar pos tokenUWrapForward:parent: [ExpApplication pos (ExpVar pos (nameWorker id):es'++[parent])]) ,pos `addPos` (idPos `addPos` esConsts)) where (es',esConsts) = tExps traced parent es tExp traced cr parent (ExpApplication pos es) = (ExpApplication pos (combApply pos traced (length es - 1):mkSRExp pos traced:parent:es') ,pos `addPos` esConsts) where (es',esConsts) = tExps traced parent es tExp traced cr parent (ExpVar pos id) = if isLambdaBound id then let e' = ExpVar pos (nameTransLambdaVar id) in if cr then (ExpApplication pos [ExpVar pos tokenProjection,mkSRExp pos traced,parent,e'] ,pos `addPos` emptyModuleConsts) else (e',emptyModuleConsts) else (ExpApplication pos [ExpVar pos (nameTransLetVar id),mkSRExp pos traced,parent] ,pos `addPos` emptyModuleConsts) tExp traced cr parent e@(ExpCon pos id) = tConApp pos traced parent e [] tExp traced cr parent (ExpLit pos litstr@(LitString _ s)) = -- Because the result is very large use special combinator that -- transforms string in traced string at runtime instead (ExpApplication pos [ExpVar pos tokenFromLitString,mkSRExp pos traced,parent ,ExpLit pos litstr] ,pos `addPos` emptyModuleConsts) tExp traced cr parent (ExpLit pos lit@(LitChar _ _)) = (ExpApplication pos [ExpVar pos tokenConChar,mkSRExp pos traced,parent,ExpLit pos lit] ,pos `addPos` emptyModuleConsts) tExp traced cr parent (ExpLit pos lit@(LitRational b r)) = -- desugar rational constant into explicit use of ":%", -- because Rational is not a primitive type but defined in PreludeBasic -- however, this way mkNTRational is not used at all (ExpApplication pos [combApply pos traced 1,sr,parent ,ExpApplication pos [ExpVar pos tokenFromRational,sr,parent] ,ExpApplication pos [ExpCon pos tokenR ,ExpApplication pos [ExpCon pos tokenConRational ,ExpApplication pos [ExpVar pos tokenConInteger,sr,parent,num] ,ExpApplication pos [ExpVar pos tokenConInteger,sr,parent,denom]] ,ExpApplication pos [ExpVar pos tokenMkAtomRational,sr,parent,ExpLit pos lit]]] ,pos `addPos` emptyModuleConsts) where num = ExpLit pos (LitInteger b (numerator r)) denom = ExpLit pos (LitInteger b (denominator r)) sr = mkSRExp pos traced tExp traced cr parent (ExpLit pos lit@(LitInteger _ _)) = (ExpApplication pos [combApply pos traced 1,sr ,parent ,ExpApplication pos [ExpVar pos tokenFromInteger,sr,parent] ,ExpApplication pos [ExpVar pos tokenConInteger,sr,parent,ExpLit pos lit]] ,pos `addPos` emptyModuleConsts) where sr = mkSRExp pos traced tExp traced cr parent (ExpList pos es) = -- use special combinator that transforms list at runtime; -- desugaring and subsequent transformation would lead to large program. (ExpApplication pos [ExpVar pos tokenFromExpList,sr,parent,ExpList pos es'] ,pos `addPos` esConsts) where (es',esConsts) = tExps traced parent es sr = mkSRExp pos traced tExp traced cr parent (ExpRecord (ExpCon pos consId) fields) = -- construction (ExpApplication pos [ExpVar pos tokenWrapValFun,sr,ExpRecord consUndefined fields',parent] ,pos `addPos` fieldsConsts) where consUndefined = if consArity == 0 then ExpCon pos (nameTransCon consId) else ExpApplication pos . (ExpCon pos (nameTransCon consId) :) . take consArity . repeat $ ExpApplication pos [ExpVar pos tokenUndefined,mkSRExp pos False,parent] Just consArity = arity consId sr = mkSRExp pos traced (fields',fieldsConsts) = mapMerge2 (tField traced parent) fields tExp True cr parent (ExpRecord exp fields) = -- update (ExpLet pos (DeclsParse $ zipWith (DeclFun pos) fieldVarIds (map ((:[]) . flip (Fun []) noDecls . Unguarded) fieldExps')) (ExpApplication pos (combUpdate pos True (length labels):mkSRExp pos True:parent:exp' :ExpLambda pos [var] (ExpRecord var varFields') :labels ++ fieldVars)) ,pos `addPos` expConsts `merge` fieldsConsts) where (exp',expConsts) = tExp True False parent exp (fields',fieldsConsts) = mapMerge2 (tField True parent) fields labels = map (ExpVar pos . nameTraceInfoVar noPos Global) labelIds varFields' = zipWith (FieldExp pos) (map fieldLabel fields') fieldVars fieldExps' = map fieldExp fields' fieldVars = map (ExpVar pos) fieldVarIds fieldVarIds = map nameShare labelIds labelIds = map fieldLabel fields var = ExpVar pos (nameFromPos pos) pos = getPos fields fieldLabel (FieldExp _ labelId _) = labelId fieldExp (FieldExp _ _ exp) = exp tExp False cr parent (ExpRecord exp fields) = -- update (ExpApplication pos [combUpdate pos False (-1),parent,exp' ,ExpLambda pos [var] (ExpRecord var fields')] ,expConsts `merge` fieldsConsts) where (exp',expConsts) = tExp False False parent exp (fields',fieldsConsts) = mapMerge2 (tField False parent) fields var = ExpVar pos (nameFromPos pos) pos = getPos fields tExp _ _ _ _ = error "tExp: unknown sort of expression" tField :: Bool -> Exp TokenId -> Field TraceId -> (Field TokenId,ModuleConsts) tField traced parent (FieldExp pos labelId exp) = (FieldExp pos (nameTransField labelId) exp',expConsts) where (exp',expConsts) = tExp traced False parent exp -- return False if matching the pattern may fail -- otherwise try to return True -- (safe approximation) neverFailingPat :: Pat id -> Bool neverFailingPat (ExpVar _ _) = True neverFailingPat (PatAs _ _ pat) = neverFailingPat pat neverFailingPat (PatIrrefutable _ _) = True neverFailingPat (PatWildcard _ ) = True neverFailingPat _ = False neverFailingPats :: [Pat id] -> Bool neverFailingPats = all neverFailingPat -- conversion of case alternative into function definition alternative alt2Fun :: Alt a -> Fun a alt2Fun (Alt pat rhs decls) = Fun [pat] rhs decls fun2Alt :: Fun a -> Alt a fun2Alt (Fun [pat] rhs decls) = Alt pat rhs decls -- Transform data constructor application. -- Number of arguments may be smaller than arity of the data constructor. tConApp :: Pos -- of application -> Bool -- traced? -> Exp TokenId -- parent -> Exp TraceId -- data constructor -> [Exp TraceId] -- arguments -> (Exp TokenId,ModuleConsts) tConApp pos traced parent c@(ExpCon _ id) args | conArity > numberOfArgs = -- undersaturated application (ExpApplication pos (combPartial pos numberOfArgs :ExpCon pos (nameTransCon id) :combCn pos (conArity-numberOfArgs) :mkSRExp pos traced :parent :ExpVar pos (nameTraceInfoCon id) :args') ,pos `addPos` argsConsts) | otherwise = tSatConApp pos traced parent c args where Just conArity = arity id -- a constructor always has an arity numberOfArgs = length args (args',argsConsts) = tExps traced parent args -- Transform data constructor application with number of args equal arity. tSatConApp :: Pos -- of application -> Bool -- traced? -> Exp TokenId -- parent -> Exp TraceId -- data constructor -> [Exp TraceId] -- arguments -> (Exp TokenId,ModuleConsts) tSatConApp pos traced parent (ExpCon _ id) args = (ExpApplication pos (combCon pos (length args) :mkSRExp pos traced :parent :ExpCon pos (nameTransCon id) :ExpVar pos (nameTraceInfoCon id) :args') ,pos `addPos` argsConsts) where (args',argsConsts) = tExps traced parent args -- Desugar do-statements removeDo :: Bool -> [Stmt TraceId] -> Exp TraceId removeDo traced [StmtExp e] = e removeDo traced (StmtExp e : stmts) = ExpApplication pos [ExpVar pos tTokenGtGt,e,removeDo traced stmts] where pos = getPos e removeDo traced (StmtLet decls : stmts) = ExpLet pos decls (removeDo traced stmts) where pos = getPos decls removeDo traced (StmtBind pat e : stmts) = ExpApplication pos [ExpVar pos tTokenGtGtEq,e ,ExpScc "" $ -- hack to inform this is really a do-stmt if neverFailingPat pat then ExpLambda pos [pat] (removeDo traced stmts) else ExpLambda pos [newVar] (ExpCase pos newVar [Alt pat (Unguarded (removeDo traced stmts)) noDecls ,Alt (PatWildcard pos) (Unguarded (ExpApplication pos [ExpVar pos tTokenFail ,ExpLit pos (LitString Boxed "pattern-match failure in do expression")])) noDecls]) ] where newVar = ExpVar pos (mkLambdaBound (initAuxInfo traced) newId) newId:_ = namesFromPos pos pos = getPos e {- mapCombine3 :: (a -> (b,[c],[d])) -> [a] -> ([b],[c],[d]) mapCombine3 f = (\(p,es,ds) -> (p,concat es,concat ds)) . unzip3 . map f -- the first part of the result is transformed pattern -- the transformation has to remove numeric constants and -- n+k patterns from a pattern, because numeric arguments are -- wrapped and hence translating into constants and n+k patterns is impossible. -- Furthermore we want their reductions in the trace as well. -- the second part contains boolean expressions that are -- implicitly tested in the original pattern but have to be made -- explicit in the transformed program, e.g. -- tPats 3 = (x,{x==3},{}) -- the third part contains definitions of numeric variables -- that orginate from n+k patterns -- e.g.: tPats (n+2) = (x,{x>=2},{n=x-2}) -- Note that variables in patterns are always lambda bound -- (pattern bindings are treated specially anyway) tPats :: [Pat TraceId] -> ([Pat TokenId],[Exp TraceId],[Decl TraceId]) tPats = mapCombine3 tPat tPat :: Pat TraceId -> (Pat TokenId,[Exp TraceId],[Decl TraceId]) tPat (ExpRecord (ExpCon pos id) fields) = (wrapExp pos (ExpRecord (ExpCon pos (nameTransCon id)) fields') (PatWildcard pos) ,fieldsExps ,fieldsDecls) where (fields',fieldsExps,fieldsDecls) = mapCombine3 tField fields tField (FieldExp pos id pat) = (FieldExp pos (nameTransField id) pat',patExps,patDecls) where (pat',patExps,patDecls) = tPat pat tPat (ExpApplication pos (ExpCon pos2 id : pats)) = (wrapExp pos (ExpApplication pos (ExpCon pos2 (nameTransCon id) : pats')) (PatWildcard pos) ,patsExps,patsDecls) where (pats',patsExps,patsDecls) = tPats pats -- negative numeric literals are represented as (negate number): tPat (ExpApplication _ [_,ExpLit pos (LitInteger boxed i)]) = tPat (ExpLit pos (LitInteger boxed (-i))) tPat (ExpApplication _ [_,ExpLit pos (LitRational boxed r)]) = tPat (ExpLit pos (LitRational boxed (-r))) tPat (ExpApplication _ [_,ExpLit pos _]) = error "tPat: app expLit" tPat (ExpVar pos id) = (ExpVar pos (nameTransLambdaVar id),[],[]) tPat (ExpCon pos id) = (wrapExp pos (ExpCon pos (nameTransCon id)) (PatWildcard pos),[],[]) tPat (ExpLit pos (LitString _ s)) = tPat . mkTList pos . map (ExpLit pos . LitChar Boxed) $ s tPat (ExpLit pos lit@(LitChar _ _)) = (wrapExp pos (ExpLit pos lit) (PatWildcard pos),[],[]) tPat e@(ExpLit pos lit) = -- only LitInteger and LitRational left (ExpVar pos (nameTransLambdaVar tid) ,[ExpApplication pos [ExpVar pos tTokenEqualEqual,ExpVar pos tid,e]] ,[]) where tid = mkLambdaBound (nameFromPos pos) tPat (ExpList pos pats) = tPat . mkTList pos $ pats tPat (PatAs pos id pat) = (PatAs pos (nameTransLambdaVar id) pat',patExps,patDecls) where (pat',patExps,patDecls) = tPat pat tPat (PatWildcard pos) = (PatWildcard pos,[],[]) -- type change tPat (PatIrrefutable pos pat) = if null patExps then (case pat' of ExpApplication pos' [r,p',t'] -> ExpApplication pos' [r,PatIrrefutable pos p',t'] x -> x ,[],[]) else error "Numeric pattern inside ~ is currently not implemented." where (pat',patExps,patDecls) = tPat pat tPat (PatNplusK pos id _ k _ _) = (ExpVar pos (nameTransLambdaVar tid2) ,[ExpApplication pos [ExpVar pos tTokenGreaterEqual,var2,k]] ,[DeclFun pos id [Fun [] (Unguarded (ExpApplication pos [ExpVar pos tTokenMinus,var2,k])) noDecls]]) where var2 = ExpVar pos tid2 tid2 = mkLambdaBound (nameFromPos pos) tPat p = error ("tPat: unknown pattern at " ++ strPos (getPos p)) -} -- new: mapCombinePats :: (Pat TraceId -> (Exp TokenId, Maybe (c,d,[Exp TokenId],[Pat TraceId]))) -> [Pat TraceId] -> ([Exp TokenId], Maybe (c,d,[Exp TokenId],[Pat TraceId])) mapCombinePats f [] = ([],Nothing) mapCombinePats f (x:xs) = case f x of (pat,Nothing) -> (pat:pats,numPatInfos) (pat,Just (e,d,vs,ps)) -> (pat:xvs,Just (e,d,vs++xvs,ps++xs)) where (pats,numPatInfos) = mapCombinePats f xs xvs = map patToVar xs patToVar :: Pat TraceId -> Exp TokenId patToVar (ExpVar pos id) = ExpVar pos (nameTransLambdaVar id) patToVar (PatAs pos id _) = ExpVar pos (nameTransLambdaVar id) patToVar pat = ExpVar pos (nameFromPos pos) where pos = getPos pat tPats :: [Pat TraceId] -> ([Pat TokenId] -- transformed patterns ,Maybe -- only if there is a numeric pattern (k or n+k) (Exp TraceId -- test for the numeric pattern (e.g. x==k) ,[Decl TraceId] -- binding for n if there is an n+k pattern ,[Exp TokenId] -- variables inserted in pattern after num literal ,[Pat TraceId])) -- original patterns after num literal tPats = mapCombinePats tPat tPat :: Pat TraceId -> (Pat TokenId ,Maybe (Exp TraceId,[Decl TraceId],[Exp TokenId],[Pat TraceId])) tPat (ExpRecord (ExpCon pos id) fields) = (wrapExp pos (ExpRecord (ExpCon pos (nameTransCon id)) fields') (PatWildcard pos) ,numInfos) where (poss,ids,pats) = unzipFields fields (pats',numInfos) = mapCombinePats tPat pats fields' = zipFields poss (map nameTransField ids) pats' unzipFields :: [Field a] -> ([Pos],[a],[Pat a]) unzipFields = unzip3 . map (\(FieldExp pos id pat) -> (pos,id,pat)) zipFields :: [Pos] -> [a] -> [Pat a] -> [Field a] zipFields = zipWith3 FieldExp tPat (ExpApplication pos (ExpCon pos2 id : pats)) = (wrapExp pos (ExpApplication pos (ExpCon pos2 (nameTransCon id) : pats')) (PatWildcard pos) ,patsNumInfo) where (pats',patsNumInfo) = tPats pats -- negative numeric literals are represented as (negate number): tPat (ExpApplication _ [_,ExpLit pos (LitInteger boxed i)]) = tPat (ExpLit pos (LitInteger boxed (-i))) tPat (ExpApplication _ [_,ExpLit pos (LitRational boxed r)]) = tPat (ExpLit pos (LitRational boxed (-r))) tPat (ExpApplication _ [_,ExpLit pos _]) = error "tPat: app expLit" tPat (ExpVar pos id) = (ExpVar pos (nameTransLambdaVar id),Nothing) tPat (ExpCon pos id) = (wrapExp pos (ExpCon pos (nameTransCon id)) (PatWildcard pos),Nothing) tPat (ExpLit pos (LitString _ s)) = tPat . mkTList pos . map (ExpLit pos . LitChar Boxed) $ s tPat (ExpLit pos lit@(LitChar _ _)) = (wrapExp pos (ExpLit pos lit) (PatWildcard pos),Nothing) tPat e@(ExpLit pos lit) = -- only LitInteger and LitRational left (ExpVar pos (nameTransLambdaVar tid) ,Just (ExpApplication pos [ExpVar pos tTokenEqualEqual,ExpVar pos tid,e] ,[],[],[])) where tid = mkLambdaBound defaultAuxInfo (nameFromPos pos) tPat (ExpList pos pats) = tPat . mkTList pos $ pats tPat (PatAs pos id pat) = (PatAs pos (nameTransLambdaVar id) pat',patNumInfos) where (pat',patNumInfos) = tPat pat tPat (PatWildcard pos) = (PatWildcard pos,Nothing) -- type change tPat (PatIrrefutable pos pat) = if isNothing patNumInfos then (case pat' of ExpApplication pos' [r,p',t'] -> ExpApplication pos' [r,PatIrrefutable pos p',t'] x -> x ,Nothing) else error "Numeric literal or n+k inside ~ is currently not implemented." where (pat',patNumInfos) = tPat pat tPat (PatNplusK pos id _ k _ _) = (ExpVar pos (nameTransLambdaVar tid2) ,Just (ExpApplication pos [ExpVar pos tTokenGreaterEqual,var2,k] ,[DeclFun pos id [Fun [] (Unguarded (ExpApplication pos [ExpVar pos tTokenMinus,var2,k])) noDecls]] ,[],[])) where var2 = ExpVar pos tid2 tid2 = mkLambdaBound defaultAuxInfo (nameFromPos pos) tPat p = error ("tPat: unknown pattern at " ++ strPos (getPos p)) -- Convert a list of expressions into a list expression (with TraceIds). -- Needed for list literals in patterns. mkTList :: Pos -> [Exp TraceId] -> Exp TraceId mkTList pos = foldr (\x xs -> ExpApplication pos [cons,x,xs]) (ExpCon pos tTokenNil) where cons = ExpCon pos tTokenCons mkList :: Pos -> [Exp TokenId] -> Exp TokenId mkList pos = foldr (\x xs -> ExpApplication pos [cons,x,xs]) (ExpCon pos t_ListNQ) where cons = ExpCon pos t_ColonNQ -- ---------------------------------------------------------------------------- -- Transform types tTyArgs :: [(Maybe [(Pos,TraceId)],Type TraceId)] -> [(Maybe [(Pos,TokenId)],Type TokenId)] tTyArgs = map tTyArg tTyArg :: (Maybe [(Pos,TraceId)],Type TraceId) -> (Maybe [(Pos,TokenId)],Type TokenId) tTyArg (maybePosIds,ty) = (fmap (mapListSnd nameTransField) maybePosIds,wrapType (tType ty)) -- ty ==> R [[ty]] tConstType :: Type TraceId -> Type TokenId tConstType ty = wrapType (tType ty) -- ty ==> RefSrcPos -> Trace -> R [[ty]] tFunType :: Type TraceId -> Type TokenId tFunType ty = TypeCons pos tokenRefSrcPos [] `typeFun` TypeCons pos tokenRefExp [] `typeFun` wrapType (tType ty) where pos = getPos ty -- create type of worker from original type tWorkerType :: Arity -> Type TraceId -> Type TokenId tWorkerType 0 ty = TypeCons (getPos ty) tokenRefExp [] `typeFun` wrapType (tType ty) tWorkerType a ty = tWorkerSynExpand a ty [] -- expand a type synonym and then apply worker type transformation -- need to collect type arguments tWorkerSynExpand :: Arity -> Type TraceId -> [Type TraceId] -> Type TokenId tWorkerSynExpand a (TypeCons pos tyCon []) [ty1,ty2] | isFunTyCon tyCon = wrapType (tType ty1) `typeFun` tWorkerType (a-1) ty2 tWorkerSynExpand a (TypeCons pos tyCon []) tys = tWorkerType a (expandTypeSynonym tyCon tys) tWorkerSynExpand a (TypeCons pos tyCon ty1s) ty2s = tWorkerSynExpand a (TypeCons pos tyCon []) (ty1s++ty2s) tWorkerSynExpand a (TypeApp ty1 ty2) tys = tWorkerSynExpand a ty1 (ty2:tys) tWorkerSynExpand _ _ _ = error "tWorkerSynExpand: type must be a function but is not" expandTypeSynonym :: TraceId -> [Type TraceId] -> Type TraceId expandTypeSynonym tySyn tys = case typeSynonymBody tySyn of Nothing -> error ("expandTypeSynonym: " ++ show (tokenId tySyn) ++ " is not a type synonym") Just body -> fst (go body 1) where go :: TySynBody -> Int -> (Type TraceId,Int) go THelper n = (TypeCons noPos (mkTyCon defaultAuxInfo (nameTransTySynHelper tySyn n)) tys ,n+1) go (TVar v) n = (tys!!v,n) go TFun n = (TypeCons noPos tTokenFun [],n) go (TApp ty1 ty2) n = (TypeApp ty1' ty2',n2) where (ty1',n1) = go ty1 n (ty2',n2) = go ty2 n1 -- just rewrite function types: -- t1 -> t2 ==> Fun [[t1]] [[t2]] tType :: Type TraceId -> Type TokenId tType (TypeCons pos tyCon tys) = TypeCons pos (nameTransTyConCls tyCon) (map tType tys) tType (TypeApp lTy rTy) = TypeApp (tType lTy) (tType rTy) tType (TypeVar pos tyId) = TypeVar pos (nameTransTyVar tyId) tType (TypeStrict pos ty) = TypeStrict pos (tType ty) -- ty ==> R ty (!ty ==> ! (R ty)) wrapType :: Type TokenId -> Type TokenId wrapType (TypeStrict pos ty) = TypeStrict pos (wrapType ty) wrapType ty = TypeCons noPos tokenR [ty] -- replace TraceIds by TokenIds (renaming -> to T.Fun, [] -> T.List etc) tokenIdType :: Type TraceId -> Type TokenId tokenIdType (TypeCons pos tyCon tys) = TypeCons pos (nameTransTyConCls tyCon) (map tokenIdType tys) tokenIdType (TypeApp lTy rTy) = TypeApp (tokenIdType lTy) (tokenIdType rTy) tokenIdType (TypeVar pos tyId) = TypeVar pos (nameTransTyVar tyId) tokenIdType (TypeStrict pos ty) = TypeStrict pos (tokenIdType ty) -- replace TraceIds by TokenIds (no renaming - just plain original types) typePlain :: Type TraceId -> Type TokenId typePlain (TypeCons pos tyCon tys) = TypeCons pos (tokenId tyCon) (map typePlain tys) typePlain (TypeApp lTy rTy) = TypeApp (typePlain lTy) (typePlain rTy) typePlain (TypeVar pos tyId) = TypeVar pos (tokenId tyId) typePlain (TypeStrict pos ty) = TypeStrict pos (typePlain ty) -- function type constructor -- infixr 6 `typeFun` typeFun :: Type TokenId -> Type TokenId -> Type TokenId typeFun ty1 ty2 = TypeCons noPos t_Arrow [ty1,ty2] tContexts :: [Context TraceId] -> [Context TokenId] tContexts = map tContext tContext :: Context TraceId -> Context TokenId tContext (Context pos clsId posTyVarIds) = Context pos (nameTransTyConCls clsId) (map (\(pos',tyVarId)->(pos',nameTransTyVar tyVarId)) posTyVarIds) tSimple :: Simple TraceId -> Simple TokenId tSimple (Simple pos tycon posArgs) = Simple pos (nameTransTyConCls tycon) (tPosTyVars posArgs) tPosShares :: [(Pos,TraceId)] -> [(Pos,TokenId)] tPosShares = mapListSnd nameShare tPosExps :: [(Pos,TraceId)] -> [(Pos,TokenId)] tPosExps = mapListSnd nameTransLetVar tPosClss :: [(Pos,TraceId)] -> [(Pos,TokenId)] tPosClss = mapListSnd nameTransTyConCls tPosTyVars :: [(Pos,TraceId)] -> [(Pos,TokenId)] tPosTyVars = mapListSnd nameTransTyVar -- ---------------------------------------------------------------------------- -- New names -- Module names and hence all qualifications are prefixed. -- Names of classes, type constructors and type variables remain unchanged. -- Names of data constructors remain unchanged. -- (everything but expression variables) -- As prefix characters only those characters can be chosen that do -- not start a reserved identifier or operator. Otherwise the transformation -- might create a reserved identifier. -- (uppercase identifiers can be prefixed by such a character, because -- a reserved identifier will never be created by prefixing) -- names referring to traces (or parts thereof) of program fragments: nameTraceInfoModule :: TraceId -> TokenId nameTraceInfoModule = prefixModName 't' nameTraceInfoVar :: Pos -> Scope -> TraceId -> TokenId nameTraceInfoVar pos Global = prefixName 'a' '+' nameTraceInfoVar pos Local = prefixPosName 'a' '+' pos nameTraceInfoGlobalVar :: TraceId -> TokenId nameTraceInfoGlobalVar = prefixName 'a' '+' nameTraceInfoCon :: TraceId -> TokenId nameTraceInfoCon = prefixName 'a' '+' nameTraceInfoPos :: Pos -> TokenId nameTraceInfoPos pos = mkUnqualifiedTokenId (('p':) . showsEncodePos pos $ "") -- names referring to transformed program fragments: nameTransModule :: TraceId -> TokenId nameTransModule = updateToken updateModule where updateModule ('N':'o':'t':'H':'a':'t':'.':orgName) = orgName updateModule (name@"Main") = name -- if the module is `Main', then unchanged updateModule name = modulePrefix ++ name nameTransTyConCls :: TraceId -> TokenId nameTransTyConCls = updateToken id -- only module name is changed -- names of helper synonyms are a bit of a hack; a name conflict is possible nameTransTySynHelper :: TraceId -> Int -> TokenId nameTransTySynHelper tySyn no = updateToken (++ ("___" ++ show no)) tySyn nameTransTyVar :: TraceId -> TokenId nameTransTyVar = updateToken id -- only module name is changed nameTransCon :: TraceId -> TokenId nameTransCon = updateToken id -- only module name is changed nameTransField :: TraceId -> TokenId nameTransField = prefixName 'b' '^' nameTransLetVar :: TraceId -> TokenId nameTransLetVar = prefixName 'g' '!' nameTransLambdaVar :: TraceId -> TokenId nameTransLambdaVar = prefixName 'f' '&' -- internal, local names -- refering to partially transformed expression nameWorker :: TraceId -> TokenId nameWorker = prefixName 'h' '*' -- refering to original (unwrapped) foreign import nameForeign :: TraceId -> TokenId nameForeign = prefixName 'f' '&' -- names for new variables in transformed expressions: -- variable for sharing in transformation of pattern binding nameShare :: TraceId -> TokenId nameShare = prefixName 's' '|' -- variable for a trace including position nameTraceShared :: Pos -> TraceId -> TokenId nameTraceShared = prefixPosName 'j' '$' -- variable for parent nameParent :: TokenId nameParent = mkUnqualifiedTokenId "p" -- variable for a trace nameTrace :: TraceId -> TokenId nameTrace = prefixName 'j' '$' -- second variable for a trace nameTrace2 :: TraceId -> TokenId nameTrace2 = prefixName 'k' '@' -- name for a local variable for a source reference nameSR :: TraceId -> TokenId nameSR = prefixName 'p' '%' -- intermediate function nameFun :: TokenId nameFun = mkUnqualifiedTokenId "h" -- infinite list of var ids made from one id (for function clauses) nameFuns :: TraceId -> [TokenId] nameFuns = prefixNames 'y' '>' -- infinite list of var ids made from one id (for naming arguments) nameArgs :: TraceId -> [TokenId] nameArgs = prefixNames 'z' '^' -- a single id made from a position (different from below) nameFromPos :: Pos -> TokenId nameFromPos pos = mkUnqualifiedTokenId . ('v':) . showsEncodePos pos $ "n" -- infinite list of ids made from a position namesFromPos :: Pos -> [TokenId] namesFromPos pos = map (mkUnqualifiedTokenId . ('v':) . showsEncodePos pos . ('v':) . show) [1..] -- Generation of new variables showsEncodePos :: Pos -> ShowS showsEncodePos pos = shows beginRow . ('v':) . shows beginColumn . ('v':) . shows endRow . ('v':) . shows endColumn where (beginRow,beginColumn,endRow,endColumn) = fromPos pos showsSymEncodePos :: Pos -> ShowS showsSymEncodePos pos = \xs -> numToSym (show beginRow) ++ '=' : numToSym (show beginColumn) ++ '=' : numToSym (show endRow) ++ '=' : numToSym (show endColumn) ++ xs where (beginRow,beginColumn,endRow,endColumn) = fromPos pos prefixName :: Char -> Char -> TraceId -> TokenId prefixName c d = updateToken update where update name = if isOperatorName name then d:name else c:name prefixModName :: Char -> TraceId -> TokenId prefixModName c = updateToken update where update name = c: map (\c->if c=='.' then '_' else c) name prefixPosName :: Char -> Char -> Pos -> TraceId -> TokenId prefixPosName c d pos = updateToken update where update name = if isOperatorName name then (d:) . showsSymEncodePos pos $ name else (c:) . showsEncodePos pos $ name prefixNames :: Char -> Char -> TraceId -> [TokenId] prefixNames c d token = map (($ token) . updateToken . update) [1..] where update no name = if isOperatorName name then (d:) . (++ name) . numToSym . show $ no else (c:) . (++ name) . show $ no isOperatorName :: String -> Bool isOperatorName = not . (\c -> isAlpha c || c == '_') . head numToSym :: String -> String numToSym = map (("!#$%&*+^@>" !!) . digitToInt) -- Tokens modulePrefix = "Hat." -- apply function to unqualified name part -- and prefix module name (if qualified) updateToken :: (String -> String) -> TraceId -> TokenId updateToken f traceId | isFunTyCon traceId = Qualified tracingModuleShort (packString . reverse $ "Fun") updateToken f traceId = case tokenId (traceId) of t | eqPredefined "[]" t -> Qualified tracingModuleShort (packString . reverse . f $ "List") t | eqPredefined ":" t -> Qualified tracingModuleShort (packString . reverse . f $ "Cons") t@(TupleId n) -> Qualified tracingModuleShort (packString . reverse . f $ ("Tuple"++show n)) Visible n -> Visible (packString . reverse . f . unqual $ n) Qualified m n -> Qualified (packString . reverse . updateModule . reverse . unpackPS $ m) (packString . reverse . f . unqual $ n) _ -> error "TraceTrans: updateToken" where updateModule (name@"Main") = name -- if module is `Main', then unchanged updateModule name = modulePrefix ++ name unqual :: PackedString -> String unqual = reverse . unpackPS -- case reverse . unpackPS $ n of -- change predefined names -- -- "->" -> "Fun" -- ":" -> "Cons" -- "[]" -> "List" -- here both type and data constructor -- s -> s -- ---------------------------------------------------------------------------- -- hardwired Haskell combinators and other names used by transformed modules mkRoot :: Pos -> Exp TokenId mkRoot pos = ExpVar pos tokenMkRoot mkParentVar :: Pos -> Exp TokenId mkParentVar pos = ExpVar pos nameParent mkSRExp :: Pos -> Bool -> Exp TokenId mkSRExp pos traced = ExpVar pos (if traced then nameTraceInfoPos pos else tokenMkNoPos) combApply :: Pos -> Bool -> Arity -> Exp TokenId combApply pos traced a = testArity pos (if traced then 15 else 8) a "application with more than " " arguments." (ExpVar pos ((if traced then tokenAp else tokenUAp) a)) combApplyArity :: Pos -> Bool -> Arity -> Exp TokenId combApplyArity pos traced a = ExpVar pos ((if traced then tokenApp else tokenUApp) a) combFun :: Pos -> Bool -> Arity -> Exp TokenId combFun pos traced a = testArity pos (if traced then 15 else 8) a "function definition with more than " " arguments." (ExpVar pos ((if traced then tokenFun else tokenUFun) a)) combConstUse :: Pos -> Bool -> Exp TokenId combConstUse pos traced = ExpVar pos (if traced then tokenConstUse else tokenUConstUse) combConstDef :: Pos -> Bool -> Exp TokenId combConstDef pos traced = ExpVar pos (if traced then tokenConstDef else tokenUConstDef) combGuard :: Pos -> Bool -> Exp TokenId combGuard pos traced = ExpVar pos (if traced then tokenGuard else tokenUGuard) combIf :: Pos -> Bool -> Exp TokenId combIf pos traced = ExpVar pos (if traced then tokenIf else tokenUIf) combCase :: Pos -> Bool -> Exp TokenId combCase pos traced = ExpVar pos (if traced then tokenCase else tokenUCase) combCon :: Pos -> Arity -> Exp TokenId combCon pos arity = testArity pos 15 arity "application of constructor to more than " " arguments." (ExpVar pos (tokenCon arity)) combPartial :: Pos -> Arity -> Exp TokenId combPartial pos arity = testArity pos 8 arity "partial application of constructor to more than " " arguments." (ExpVar pos (tokenPa arity)) combCn :: Pos -> Arity -> Exp TokenId combCn pos arity = testArity pos 12 arity "partial application of constructor with more than " " missing arguments." (ExpVar pos (tokenCn arity)) combUpdate :: Pos -> Bool -> Arity -> Exp TokenId combUpdate pos traced arity = testArity pos (if traced then 10 else maxBound) arity "field update with more than " " labels." (ExpVar pos (if traced then tokenUpdate arity else tokenUUpdate)) testArity :: Pos -> Arity -> Arity -> String -> String -> a -> a testArity pos maxArity arity str1 str2 x = if arity > maxArity then error ("Cannot handle " ++ str1 ++ show maxArity ++ str2 ++ "\nAttempted arity " ++ show arity ++ " at " ++ strPos pos) else x -- apply data constructor R wrapExp :: Pos -> Exp TokenId -> Exp TokenId -> Exp TokenId wrapExp pos ev et = ExpApplication pos [ExpCon pos tokenR,ev,et] -- hardwired tokens: -- constants are here just for sharing tracingModule :: PackedString -- name of module with combinators tracingModule = packString . reverse $ "Hat.Hat" tracingModuleShort :: PackedString tracingModuleShort = packString . reverse $ "T" -- abbreviation tPreludeModule :: PackedString tPreludeModule = packString . reverse $ "Hat.PreludeBasic" mkTPreludeToken :: String -> TokenId mkTPreludeToken s = Qualified tPreludeModule (packString . reverse $ s) mkTracingToken :: String -> TokenId mkTracingToken s = Qualified tracingModuleShort (packString . reverse $ s) mkTracingTokenArity :: String -> Arity -> TokenId mkTracingTokenArity s a = mkTracingToken (s ++ show a) mkTypeToken :: String -> TokenId mkTypeToken s@"fromId" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toId" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromIO" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toIO" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromTuple0" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toTuple0" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromTuple2" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toTuple2" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toChar" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromChar" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toInt" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromInt" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toInteger" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromInteger" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toFloat" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromFloat" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"toDouble" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s@"fromDouble" = Qualified tracingModuleShort (packString . reverse $ s) mkTypeToken s = Visible (packString . reverse $ s) -- tokens for trace constructors: tokenMkRoot :: TokenId tokenMkRoot = mkTracingToken "mkRoot" tokenR :: TokenId tokenR = mkTracingToken "R" tokenMkModule :: TokenId tokenMkModule = mkTracingToken "mkModule" tokenMkPos :: TokenId tokenMkPos = mkTracingToken "mkSrcPos" tokenMkNoPos :: TokenId tokenMkNoPos = mkTracingToken "mkNoSrcPos" tokenMkAtomConstructor :: Bool -> TokenId tokenMkAtomConstructor withFields = mkTracingToken (if withFields then "mkConstructorWFields" else "mkConstructor") tokenMkAtomVariable :: TokenId tokenMkAtomVariable = mkTracingToken "mkVariable" tokenMkExpValueApp :: Arity -> TokenId tokenMkExpValueApp = mkTracingTokenArity "mkValueApp" tokenMkExpValueUse :: TokenId tokenMkExpValueUse = mkTracingToken "mkValueUse" tokenMkAtomRational :: TokenId tokenMkAtomRational = mkTracingToken "mkAtomRational" tokenMkAtomLambda :: TokenId tokenMkAtomLambda = mkTracingToken "mkLambda" tokenMkAtomDoLambda :: TokenId tokenMkAtomDoLambda = mkTracingToken "mkDoLambda" -- tokens for expression combinators: tokenAp :: Arity -> TokenId tokenAp = mkTracingTokenArity "ap" tokenUAp :: Arity -> TokenId tokenUAp = mkTracingTokenArity "uap" tokenApp :: Arity -> TokenId tokenApp = mkTracingTokenArity "app" tokenUApp :: Arity -> TokenId tokenUApp = mkTracingTokenArity "uapp" tokenFun :: Arity -> TokenId tokenFun = mkTracingTokenArity "fun" tokenUFun :: Arity -> TokenId tokenUFun = mkTracingTokenArity "ufun" tokenCon :: Arity -> TokenId tokenCon = mkTracingTokenArity "con" tokenPa :: Arity -> TokenId tokenPa = mkTracingTokenArity "pa" tokenCn :: Arity -> TokenId tokenCn = mkTracingTokenArity "cn" tokenConstUse :: TokenId tokenConstUse = mkTracingToken "constUse" tokenUConstUse :: TokenId tokenUConstUse = mkTracingToken "uconstUse" tokenConstDef :: TokenId tokenConstDef = mkTracingToken "constDef" tokenUConstDef :: TokenId tokenUConstDef = mkTracingToken "uconstDef" tokenGuard :: TokenId tokenGuard = mkTracingToken "cguard" tokenUGuard :: TokenId tokenUGuard = mkTracingToken "ucguard" tokenIf :: TokenId tokenIf = mkTracingToken "cif" tokenUIf :: TokenId tokenUIf = mkTracingToken "ucif" tokenCase :: TokenId tokenCase = mkTracingToken "ccase" tokenUCase :: TokenId tokenUCase = mkTracingToken "uccase" tokenUpdate :: Arity -> TokenId tokenUpdate = mkTracingTokenArity "update" tokenUUpdate :: TokenId tokenUUpdate = mkTracingToken "uupdate" tokenProjection :: TokenId tokenProjection = mkTracingToken "projection" tokenConChar :: TokenId tokenConChar = mkTracingToken "conChar" tokenConInteger :: TokenId tokenConInteger = mkTracingToken "conInteger" tokenFromLitString :: TokenId tokenFromLitString = mkTracingToken "fromLitString" tokenFromExpList :: TokenId tokenFromExpList = mkTracingToken "fromExpList" tokenWrapValClass :: TokenId tokenWrapValClass = mkTracingToken "WrapVal" tokenWrapValFun :: TokenId tokenWrapValFun = mkTracingToken "wrapVal" tokenUWrapForward :: TokenId tokenUWrapForward = mkTracingToken "uwrapForward" -- tokens of the Prelude tokenUndefined :: TokenId tokenUndefined = mkTPreludeToken "gundefined" -- for integer literals tokenFromInteger :: TokenId tokenFromInteger = mkTPreludeToken "gfromInteger" -- for rational literals tokenConRational :: TokenId tokenConRational = mkTPreludeToken ":%" tokenFromRational :: TokenId tokenFromRational = mkTPreludeToken "gfromRational" -- function for pattern-match failure error message tokenFatal :: TokenId tokenFatal = mkTracingToken "fatal" -- other hardcoded tokens: tokenTraceIO :: TokenId tokenTraceIO = mkTracingToken "traceIO" tokenRefSrcPos :: TokenId tokenRefSrcPos = mkTracingToken "RefSrcPos" tokenRefExp :: TokenId tokenRefExp = mkTracingToken "RefExp" -- ---------------------------------------------------------------------------- expTo :: Pos -> Type TraceId -> Exp TokenId expTo = expType True expFrom :: Pos -> Type TraceId -> Exp TokenId expFrom = expType False expType :: Bool -> Pos -> Type TraceId -> Exp TokenId expType to pos (TypeVar _ tyId) = ExpVar pos (mkTypeToken (prefix to ++ "Id")) expType to pos (TypeCons _ tyCon []) = ExpVar pos (mkTypeToken (prefix to ++ typeName tyCon)) expType to pos (TypeCons _ tyCon [ty1,ty2]) | isFunTyCon tyCon = ExpApplication pos [ExpVar pos (mkTypeToken (prefix to ++ "Fun")) ,expType (not to) pos ty1 ,expType to pos ty2] expType to pos (TypeCons _ tyCon tys) = ExpApplication pos (ExpVar pos (mkTypeToken (prefix to ++ typeName tyCon)) : map (expType to pos) tys) prefix :: Bool -> String prefix True = "to" prefix False = "from" typeName :: TraceId -> String typeName aId = case tokenId aId of TupleId n -> "Tuple" ++ show n t | eqPredefined "[]" t -> "List" _ -> getUnqualified aId -- ---------------------------------------------------------------------------- -- various little helper functions extractUnqual :: TokenId -> String extractUnqual = reverse . unpackPS . extractV eqPredefinedTrace :: String -> TraceId -> Bool eqPredefinedTrace s id = eqPredefined s (tokenId id) eqPredefined :: String -> TokenId -> Bool eqPredefined s id = -- a bit of a hack -- without qualification and even with qualification "Prelude" -- the token does not necessarily originate from Prelude -- but we pretend it does ((==) s . extractUnqual $ id) && ((==) "Prelude" . qualModule . extractM $ id) -- test for specific tokens isFunTyCon :: TraceId -> Bool isFunTyCon = eqPredefinedTrace "->" -- (tokenId id) == t_Arrow isTrue :: TraceId -> Bool isTrue = eqPredefinedTrace "True" -- (tokenId id) == tTrue isOtherwise :: TraceId -> Bool isOtherwise = eqPredefinedTrace "otherwise" -- (tokenId id) == t_otherwise isMain :: TraceId -> Bool isMain = eqPredefinedTrace "Main" -- (tokenId id) == tMain -- other stuff mkFailExp :: Pos -> Exp TokenId -> Exp TokenId mkFailExp pos parent = ExpApplication pos [ExpVar pos tokenFatal,parent] mkTupleExp :: Pos -> [Exp TokenId] -> Exp TokenId mkTupleExp pos es = ExpApplication pos (ExpCon pos (t_Tuple (length es)): es) -- ---------------------------------------------------------------------------- instance Functor Module where fmap f (Module pos id mayExports imps fixs decls) = Module pos (f id) (fmap (map (fmap f)) mayExports) (map (fmap f) imps) (map (mapDeclFixity f) fixs) (fmap f decls) instance Functor Export where fmap f (ExportEntity pos entity) = ExportEntity pos (fmap f entity) fmap f (ExportModid pos id) = ExportModid pos (f id) instance Functor ImpDecl where fmap f (Import (pos,id) impSpec) = Import (pos,f id) (fmap f impSpec) fmap f (ImportQ (pos,id) impSpec) = ImportQ (pos,f id) (fmap f impSpec) fmap f (ImportQas (pos,id) (pos2,id2) impSpec) = ImportQas (pos,f id) (pos2,f id2) (fmap f impSpec) fmap f (Importas (pos,id) (pos2,id2) impSpec) = Importas (pos,f id) (pos2,f id2) (fmap f impSpec) instance Functor ImpSpec where fmap f (NoHiding entities) = NoHiding (map (fmap f) entities) fmap f (Hiding entities) = Hiding (map (fmap f) entities) instance Functor Entity where fmap f (EntityVar pos id) = EntityVar pos (f id) fmap f (EntityConClsAll pos id) = EntityConClsAll pos (f id) fmap f (EntityConClsSome pos id pids) = EntityConClsSome pos (f id) (mapListSnd f pids) instance Functor InfixClass where fmap f InfixDef = InfixDef fmap f InfixL = InfixL fmap f InfixR = InfixR fmap f Infix = Infix fmap f (InfixPre a) = InfixPre (f a) mapDeclFixity :: (a -> b) -> FixDecl a -> FixDecl b mapDeclFixity f (iclass,fix,fixIds) = (fmap f iclass,fix,map (fmap f) fixIds) instance Functor FixId where fmap f (FixCon pos id) = FixCon pos (f id) fmap f (FixVar pos id) = FixVar pos (f id) instance Functor Decls where fmap f (DeclsParse decls) = DeclsParse (map (fmap f) decls) fmap f (DeclsScc decldeps) = DeclsScc (map (fmap f) decldeps) instance Functor DeclsDepend where fmap f (DeclsNoRec d) = DeclsNoRec (fmap f d) fmap f (DeclsRec ds) = DeclsRec (map (fmap f) ds) instance Functor Decl where fmap f (DeclType simple ty) = DeclType (fmap f simple) (fmap f ty) fmap f (DeclTypeRenamed pos id) = DeclTypeRenamed pos id fmap f (DeclData sort contexts simple constrs derive) = DeclData sort (map (fmap f) contexts) (fmap f simple) (map (fmap f) constrs) (map (\(p,i)->(p,f i)) derive) fmap f (DeclDataPrim pos id size) = DeclDataPrim pos (f id) size fmap f (DeclConstrs pos id fields) = DeclConstrs pos (f id) (map (\(p,i1,i2)->(p,f i1,f i2)) fields) fmap f (DeclClass pos contexts cls tys fundeps decls) = DeclClass pos (map (fmap f) contexts) (f cls) (map f tys) (map (fmap f) fundeps) (fmap f decls) fmap f (DeclInstance pos contexts cls insts decls) = DeclInstance pos (map (fmap f) contexts) (f cls) (map (fmap f) insts) (fmap f decls) fmap f (DeclDefault tys) = DeclDefault (map (fmap f) tys) fmap f (DeclPrimitive pos id a ty) = DeclPrimitive pos (f id) a (fmap f ty) fmap f (DeclForeignImp pos callconv extfun id a fspec ty id') = DeclForeignImp pos callconv extfun (f id) a fspec (fmap f ty) (f id') fmap f (DeclVarsType vars contexts ty) = DeclVarsType (mapListSnd f vars) (map (fmap f) contexts) (fmap f ty) fmap f (DeclPat alt) = DeclPat (fmap f alt) fmap f (DeclFun pos id funs) = DeclFun pos (f id) (map (fmap f) funs) fmap f (DeclIgnore s) = DeclIgnore s fmap f (DeclError s) = DeclError s fmap f (DeclAnnot decl annots) = DeclAnnot (fmap f decl) (map (fmap f) annots) fmap f (DeclFixity fixity) = DeclFixity (mapDeclFixity f fixity) instance Functor Annot where fmap f (AnnotArity (p,id) i) = AnnotArity (p,f id) i fmap f (AnnotPrimitive (p,id) s) = AnnotPrimitive (p, f id) s fmap f (AnnotNeed idss) = AnnotNeed (map (map f) idss) fmap f AnnotUnknown = AnnotUnknown instance Functor FunDep where fmap f (as :->: bs) = (map f as) :->: (map f bs) instance Functor Fun where fmap f (Fun pats rhs decls) = Fun (map (fmap f) pats) (fmap f rhs) (fmap f decls) instance Functor Alt where fmap f (Alt pat rhs decls) = Alt (fmap f pat) (fmap f rhs) (fmap f decls) instance Functor Rhs where fmap f (Unguarded exp) = Unguarded (fmap f exp) fmap f (Guarded gdexps) = Guarded (map (\(e1,e2)->(fmap f e1,fmap f e2)) gdexps) instance Functor Type where fmap f (TypeCons pos id tys) = TypeCons pos (f id) (map (fmap f) tys) fmap f (TypeApp ty1 ty2) = TypeApp (fmap f ty1) (fmap f ty2) fmap f (TypeVar pos id) = TypeVar pos (f id) fmap f (TypeStrict pos ty) = TypeStrict pos (fmap f ty) instance Functor Simple where fmap f (Simple pos id ids) = Simple pos (f id) (mapListSnd f ids) instance Functor Context where fmap f (Context pos id pis) = Context pos (f id) (map (\(p,id2)->(p,f id2)) pis) instance Functor Constr where fmap f (Constr pos id fields) = Constr pos (f id) (mapFields f fields) fmap f (ConstrCtx vars contexts pos id fields) = ConstrCtx (mapListSnd f vars) (map (fmap f) contexts) pos (f id) (mapFields f fields) mapFields :: (a -> b) -> [(Maybe [(Pos,a)],Type a)] -> [(Maybe [(Pos,b)],Type b)] mapFields f = map (\(may,ty)-> (fmap (mapListSnd f) may, fmap f ty)) instance Functor Stmt where fmap f (StmtExp exp) = StmtExp (fmap f exp) fmap f (StmtBind e1 e2) = StmtBind (fmap f e1) (fmap f e2) fmap f (StmtLet decls) = StmtLet (fmap f decls) instance Functor Exp where fmap f (ExpScc s e) = ExpScc s (fmap f e) fmap f (ExpDict e) = ExpDict (fmap f e) fmap f (ExpLambda pos pats e) = ExpLambda pos (map (fmap f) pats) (fmap f e) fmap f (ExpLet pos decls e) = ExpLet pos (fmap f decls) (fmap f e) fmap f (ExpDo pos stmts) = ExpDo pos (map (fmap f) stmts) fmap f (ExpCase pos e alts) = ExpCase pos (fmap f e) (map (fmap f) alts) fmap f (ExpFatbar e1 e2) = ExpFatbar (fmap f e1) (fmap f e2) fmap f ExpFail = ExpFail fmap f (ExpIf pos e1 e2 e3) = ExpIf pos (fmap f e1) (fmap f e2) (fmap f e3) fmap f (ExpType pos e contexts ty) = ExpType pos (fmap f e) (map (fmap f) contexts) (fmap f ty) fmap f (ExpRecord e fields) = ExpRecord (fmap f e) (map (fmap f) fields) fmap f (ExpApplication pos es) = ExpApplication pos (map (fmap f) es) fmap f (ExpVar pos id) = ExpVar pos (f id) fmap f (ExpCon pos id) = ExpCon pos (f id) fmap f (ExpInfixList pos es) = ExpInfixList pos (map (fmap f) es) fmap f (ExpVarOp pos id) = ExpVarOp pos (f id) fmap f (ExpConOp pos id) = ExpConOp pos (f id) fmap f (ExpLit pos lit) = ExpLit pos lit fmap f (ExpList pos es) = ExpList pos (map (fmap f) es) fmap f (Exp2 pos id1 id2) = Exp2 pos (f id1) (f id2) fmap f (PatAs pos id pat) = PatAs pos (f id) (fmap f pat) fmap f (PatWildcard pos) = PatWildcard pos fmap f (PatIrrefutable pos pat) = PatIrrefutable pos (fmap f pat) fmap f (PatNplusK pos id1 id2 e1 e2 e3) = PatNplusK pos (f id1) (f id2) (fmap f e1) (fmap f e2) (fmap f e3) instance Functor Field where fmap f (FieldExp pos id e) = FieldExp pos (f id) (fmap f e) fmap f (FieldPun pos id) = FieldPun pos (f id) -- ---------------------------------------------------------------------------- -- End