hat-2.9.1: trans/TraceTrans.hs
{-# LANGUAGE PatternGuards #-}
{- ---------------------------------------------------------------------------
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, Tracing(..)) where
import Language.Haskell.Exts
import System.FilePath (FilePath,takeBaseName)
import Data.Maybe (fromMaybe,isNothing,isJust,fromJust)
import Data.List (stripPrefix,nubBy,partition)
import Data.Char (digitToInt,isAlpha)
import Data.Ratio (numerator,denominator)
import Data.Set (Set)
import qualified Data.Set as Set
import Relation (emptyRelation,unionLocalRelation)
import Environment (Environment,Scope(..),isLocal
,TySynBody(TApp,TFun,THelper,TVar)
,lookupExpEnv, lookupTypeEnv
,eArity, eNo, eBody, eCons, eFields
,Entity,isClass, isSyn, isType
,arity,isLambdaBound,isTracedQName
,fixPriority,isUndefinedMethod
,isExpandableTypeSynonym,typeSynonymBody
,nameTransTySynHelper,expandTypeSynonym
,declsEnv,instanceEnv,moduleDefines,maybeBindsEnv,bindsEnv,patsEnv,defineNameEnv
,lambdaVarEnv,makeAllLambdaBound)
import Wired
import SynHelp
import Derive (derive)
import Environment (prettyEnv)
import Debug.Trace
-- ----------------------------------------------------------------------------
-- central types
data Tracing = Traced | Trusted deriving Eq
isTraced :: Tracing -> Bool
isTraced Traced = True
isTraced Trusted = False
-- ----------------------------------------------------------------------------
-- Transform a module
traceTrans ::
FilePath -> -- complete filename of the module (essential for module Main)
Tracing -> -- whether transforming for tracing or trusting
Environment -> -- contains already info about all imported identifiers
Module SrcSpanInfo ->
Module SrcSpanInfo -- some srcSpanInfo will be fake
traceTrans moduleFilename tracing env
mod@(Module span maybeModuleHead modulePragmas impDecls decls) =
Module span (adaptMain (fmap (tModuleHead env declsExported) maybeModuleHead))
(map tModulePragma modulePragmas)
(tImpDecls env impDecls)
(declsExported ++
[PatBind span patParent
(UnGuardedRhs span expRoot) Nothing] ++
[defNameMod modName moduleFilename tracing] ++
(if isTraced tracing then map (defNameSpan modTrace) ls else []))
where
modName = getModuleNameFromModule mod
declsExported = decls' ++ map (\f -> f modTrace) defFuns ++
if isMain modName
then [defMain tracing (traceBaseFilename moduleFilename)]
else []
-- conNameDefs = map (defNameCon env modTrace) cons
-- globalVarNameDefs = map (defNameVar env Global Global modTrace) tvars
modName' = nameTransModule modName
modTrace = Var span (UnQual span (nameTraceInfoModule modName))
-- (poss,tvars,vars,mvars,cons) = getModuleConsts consts
(decls',consts) = tDecls env Global tracing decls
definedEnv = moduleDefines (isTraced tracing) env mod
(ls,defFuns) = moduleConstsGet (moduleConstsEnv Global definedEnv `moduleConstsUnion` consts)
adaptMain maybeModuleHead = if isMain modName then Nothing else maybeModuleHead
traceTrans _ _ _ (XmlPage span _ _ _ _ _ _) = notSupported span "XmlPage"
traceTrans _ _ _ (XmlHybrid span _ _ _ _ _ _ _ _) = notSupported span "XmlHybrid"
-- For the complete filename of a module yields the base filename for the
-- trace file.
-- Pre-condition: The module is a Main module
traceBaseFilename :: FilePath -> FilePath
traceBaseFilename = takeBaseName
-- obtain the module identifier
getModuleId :: ModuleHead l -> String
getModuleId (ModuleHead _ (ModuleName _ modId) _ _) = modId
tModuleHead :: Environment ->
[Decl SrcSpanInfo] -> -- transformed declarations of this module
ModuleHead SrcSpanInfo -> ModuleHead SrcSpanInfo
tModuleHead env decls
(ModuleHead span moduleName maybeWarningText maybeExportSpecList) =
ModuleHead span (nameTransModule moduleName)
(fmap tWarningText maybeWarningText)
(tMaybeExportSpecList ((\(ModuleName _ modId) -> modId) moduleName)
env maybeExportSpecList decls)
-- warnings stay unchanged
tWarningText :: WarningText l -> WarningText l
tWarningText w = w
-- not all module pragmas can be transformed
tModulePragma :: ModulePragma SrcSpanInfo -> ModulePragma SrcSpanInfo
tModulePragma (LanguagePragma l names) = LanguagePragma l names
tModulePragma (OptionsPragma l maybeTool string) =
OptionsPragma l maybeTool string
tModulePragma (AnnModulePragma l _) =
notSupported l "ANN pragma with module scope"
-- ----------------------------------------------------------------------------
-- construct new main function definition
-- main = T.traceIO "artFilename" gmain
-- equivalent to
-- main = do
-- T.openTrace "artFilename"
-- case omain Prelude.undefined Prelude.undefined of
-- T.R v _ -> v
-- T.closeTrace
defMain :: Tracing -> String -> Decl SrcSpanInfo
defMain tracing artFileName =
PatBind noSpan (PVar noSpan (nameMain noSpan))
(UnGuardedRhs noSpan (appN
[expTraceIO
,litString noSpan artFileName
,appN [Var noSpan qNameGMain, mkExpSR noSpan Trusted, expRoot]]))
Nothing
where
qNameGMain = nameTransLetVar (UnQual noSpan (nameMain noSpan))
-- ----------------------------------------------------------------------------
-- Produce export list
tMaybeExportSpecList :: String -> -- name of this module
Environment ->
Maybe (ExportSpecList SrcSpanInfo) -> -- original list
[Decl SrcSpanInfo] -> -- new declarations
Maybe (ExportSpecList SrcSpanInfo)
tMaybeExportSpecList _ _ Nothing decls =
Just (ExportSpecList noSpan (concatMap makeExport decls))
tMaybeExportSpecList thisModuleId env
(Just (ExportSpecList l exportSpecs)) decls =
Just (ExportSpecList l
(concatMap (tExportSpec env decls thisModuleId) exportSpecs))
tExportSpec :: Environment -> [Decl SrcSpanInfo] ->
String -> -- name of *this* module, being transformed
ExportSpec SrcSpanInfo ->
[ExportSpec SrcSpanInfo]
tExportSpec env _ _ (EVar span qname) =
map (EVar span) (tEntityVar env qname)
tExportSpec env _ _ (EAbs span namespace qname) =
map (EAbs span namespace) qnames'
where
qnames' = tEntityAbs env qname
-- tExportSpec env decls thisModule (EThingAll span qName)
-- | isClass e = [EThingAll span (nameTransCls qName)]
-- | isType e = tExportSpec env decls thisModule
-- (EThingWith span qName (map conName (eCons e) ++ map fieldName (eFields e)))
-- | otherwise = error "TraceTrans.tExportSpec: type synonym with (..)."
-- where
-- e = lookupTypeEnv env qName
-- conName str = ConName span (Symbol span str)
-- fieldName str = VarName span (Ident span str)
tExportSpec env _ _ (EThingWith span wildcard qname cnames) =
EThingWith span wildcard qname' cnames' : map (EVar span) qnames'
where
(qname', cnames', qnames') = tEntityThingWith env qname cnames
tExportSpec env decls thisModuleId
(EModuleContents span moduleName@(ModuleName _ moduleId)) =
if thisModuleId == moduleId
then concatMap makeExport decls
else [EModuleContents span (nameTransModule moduleName)]
-- Produce export entities from the declarations generated by the transformation
-- These are all entities defined in this module and meant for export.
makeExport :: Decl SrcSpanInfo -> [ExportSpec SrcSpanInfo]
makeExport (TypeDecl l declHead _) =
[EVar l (UnQual l (getDeclHeadName declHead))]
makeExport (TypeFamDecl l declHead _ _) =
[EVar l (UnQual l (getDeclHeadName declHead))]
makeExport (DataDecl l _ _ declHead _ _) =
[EThingWith l (EWildcard l 0) (UnQual l (getDeclHeadName declHead)) []]
makeExport (GDataDecl l _ _ declHead _ _ _) =
[EThingWith l (EWildcard l 0) (UnQual l (getDeclHeadName declHead)) []]
makeExport (ClassDecl l _ declHead _ _) =
[EThingWith l (EWildcard l 0) (UnQual l (getDeclHeadName declHead)) []]
makeExport (FunBind l matches) =
if exportedTransName name then [EVar l (UnQual l name)] else []
where
name = getMatchName (head matches)
makeExport (PatBind l (PVar l' name) _ _) =
if exportedTransName name then [EVar l (UnQual l name)] else []
makeExport _ = []
-- Checks whether this is the name of a function that should be exported
-- by the module.
exportedTransName :: Name l -> Bool
exportedTransName (Ident _ name) = head name `elem` ['g','a','h']
exportedTransName (Symbol _ name) = head name `elem` ['!','+','*']
getMatchName :: Match l -> Name l
getMatchName (Match _ name _ _ _) = name
getMatchName (InfixMatch _ _ name _ _ _) = name
getMatchArity :: Match l -> Arity
getMatchArity (Match _ _ pats _ _) = length pats
getMatchArity (InfixMatch _ _ _ pats _ _) = 1 + length pats
getDeclHeadName :: DeclHead l -> Name l
getDeclHeadName (DHead _ name) = name
getDeclHeadName (DHInfix _ _ name) = name
getDeclHeadName (DHParen _ declHead) = getDeclHeadName declHead
getDeclHeadName (DHApp _ declHead _) = getDeclHeadName declHead
-- ----------------------------------------------------------------------------
-- Produce imports
tImpDecls :: Environment -> [ImportDecl SrcSpanInfo] -> [ImportDecl SrcSpanInfo]
tImpDecls env impDecls =
ImportDecl {importAnn = noSpan,
importModule = ModuleName noSpan "Prelude",
importQualified = True,
importSrc = False,
importSafe = False,
importPkg = Nothing,
importAs = Nothing,
importSpecs = Nothing}
-- Avoid default import of Prelude by importing it qualified.
-- Transformed program still uses a few (qualified) Prelude
-- functions and data constructors.
-- : ImportDecl {importAnn = noSpan,
-- importModule = ModuleName noSpan "Hat.Hack",
-- importQualified = False,
-- importSrc = False,
-- importPkg = Nothing,
-- importAs = Nothing,
-- importSpecs = Nothing}
-- -- For list syntax : and [].
-- -- Is that really needed?
: ImportDecl {importAnn = noSpan,
importModule = ModuleName noSpan "Hat.Hat",
importQualified = True,
importSrc = False,
importSafe = False,
importPkg = Nothing,
importAs = Just (ModuleName noSpan "T"),
importSpecs = Nothing}
-- All types and combinators for tracing, inserted by the transformation
: map (tImportDecl env) impDecls
tImportDecl :: Environment -> ImportDecl SrcSpanInfo -> ImportDecl SrcSpanInfo
tImportDecl env importDecl =
if importSrc importDecl
then notSupported (importAnn importDecl) "{-# SOURCE #-}"
else if isJust (importPkg importDecl)
then notSupported (importAnn importDecl) "explicit package name"
else
importDecl{importModule = nameTransModule (importModule importDecl),
importAs = fmap nameTransModule (importAs importDecl),
importSpecs = fmap (tImportSpecList env) (importSpecs importDecl)
}
tImportSpecList :: Environment -> ImportSpecList SrcSpanInfo ->
ImportSpecList SrcSpanInfo
tImportSpecList env (ImportSpecList l hiding importSpecs) =
ImportSpecList l hiding (concatMap (tImportSpec env) importSpecs)
-- Nearly identical with tExportSpec except for the types.
tImportSpec :: Environment -> ImportSpec SrcSpanInfo -> [ImportSpec SrcSpanInfo]
tImportSpec env (IVar span name) =
map (IVar span . qName2Name) qnames'
where
qnames' = tEntityVar env (UnQual (ann name) name)
tImportSpec env (IAbs span namespace name) =
map (IAbs span namespace . qName2Name) qnames'
where
qnames' = tEntityAbs env (UnQual (ann name) name)
tImportSpec env (IThingAll span name)
| isClass e = [IThingAll span (nameTransCls name)]
| isType e = tImportSpec env (IThingWith span name
(map conName (eCons e) ++ map fieldName (eFields e)))
| otherwise = error "TraceTrans.tImportSpec: unexpected type synonym with (..)"
where
e = lookupTypeEnv env (UnQual (ann name) name)
conName str = ConName span (mkName span str)
fieldName str = VarName span (mkName span str)
tImportSpec env (IThingWith span name cnames) =
IThingWith span (qName2Name qname') cnames' :
map (IVar span . qName2Name) qnames'
where
(qname', cnames', qnames') =
tEntityThingWith env (UnQual (ann name) name) cnames
-- ----------------------------------------------------------------------------
-- Produce entities in either import or export list
tEntityVar :: SrcInfo l => Environment -> QName l -> [QName l]
tEntityVar env qname =
nameTransLetVar qname :
case arity env qname of
Just a | a > 0 -> [nameTraceInfoGlobalVar qname, nameWorker qname]
Just (-1) -> [nameShare qname]
_ -> []
-- a class or datatype ex-/imported abstractly, or a type synonym
tEntityAbs :: SrcInfo l => Environment -> QName l -> [QName l]
tEntityAbs env qname
| isClass e = [nameTransCls qname]
| isType e = [nameTransTy qname]
| isSyn e = nameTransSyn qname :
map (nameTransTySynHelper qname) [1..eNo e]
where
e = lookupTypeEnv env qname
-- a class with some methods or a datatype with some constructors/fields
tEntityThingWith :: SrcInfo l => Environment -> QName l -> [CName l] ->
(QName l, [CName l], [QName l])
tEntityThingWith env qname cnames
| isClass e = (nameTransCls qname,
map nameTransLetVar cnames ++
map nameShare cnames,
[])
| isType e = (nameTransTy qname,
map nameTransCon consNames ++ map nameTransField fieldNames,
map nameTransLetVar qFieldNames ++
map nameWorker qFieldNames ++
map nameTraceInfoGlobalVar qFieldNames ++
map nameTraceInfoCon qConsNames)
| otherwise = error "TraceTrans.tEntityThingWith: unexpected sort of type."
where
e = lookupTypeEnv env qname
qConsNames = map (cName2QName qname) consNames
qFieldNames = map (cName2QName qname) fieldNames
(consNames, fieldNames) = partition isSymbol cnames
-- ----------------------------------------------------------------------------
-- 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 :: ModuleName SrcSpanInfo -> String -> Tracing -> Decl SrcSpanInfo
defNameMod modName@(ModuleName l modId) filename tracing =
PatBind l (PVar l (nameTraceInfoModule modName))
(UnGuardedRhs l
(appN
[Var l (qNameMkModule l)
,litString l modId
,litString l filename
,Con l (if isTraced tracing then qNamePreludeTrue l
else qNamePreludeFalse l)]))
Nothing
-- The span in the name is used in the declared name and its definition.
defNameCon :: Name SrcSpanInfo -> [Name SrcSpanInfo] -> Int -> Int -> Exp SrcSpanInfo -> Decl SrcSpanInfo
defNameCon conName fieldNames fixPri arity moduleTrace =
PatBind l (PVar l (nameTraceInfoCon conName))
(UnGuardedRhs l
(appN
(Var l (qNameMkAtomConstructor l withFields) :
moduleTrace :
encodeSpan l ++
litInt l fixPri :
Paren l (litInt l arity) :
litString l ident :
if withFields
then (:[]) . mkExpList .
map (Var l . UnQual l . nameTraceInfoVar l Global) $
fieldNames
else [] )
))
Nothing
where
l = ann conName
ident = getId conName
withFields = not (null fieldNames)
{-
defNameCon :: Environment ->
Exp SrcSpanInfo ->
(Name SrcSpanInfo, [Name SrcSpanInfo]) ->
Decl SrcSpanInfo
defNameCon env moduleTrace (conName, fieldNames) =
PatBind l (PVar l (nameTraceInfoCon conName)) Nothing
(UnGuardedRhs l
(appN
(Var l (qNameMkAtomConstructor l withFields) :
moduleTrace :
encodeSpan l ++
litInt l (fixPriority env conName) :
litInt l (fromJust (arity env (UnQual l conName))) :
litString l ident :
if withFields
then (:[]) . mkExpList .
map (Var l . UnQual l . nameTraceInfoVar l Global) $
fieldNames
else [] )
))
Nothing
where
l = ann conName
ident = getId conName
withFields = not (null fieldNames)
-}
-- The span in the name is used in the declared name and its definition.
defNameVar :: Name SrcSpanInfo -> Int -> Int -> Scope -> Scope -> Exp SrcSpanInfo -> Decl SrcSpanInfo
defNameVar varName fixPri arity defScope visScope moduleTrace =
PatBind l (PVar l (nameTraceInfoVar l visScope varName))
(UnGuardedRhs l
(appN
(Var l (qNameMkAtomVariable l) :
moduleTrace :
encodeSpan l ++
[litInt l fixPri,
Paren l (litInt l arity),
litString l (getId varName),
Con l (if isLocal defScope then qNamePreludeTrue l
else qNamePreludeFalse l)])))
Nothing
where
l = ann varName
{-
defNameVar :: Environment -> Scope -> Scope ->
Exp SrcSpanInfo -> Name SrcSpanInfo ->
Decl SrcSpanInfo
defNameVar env defScope visScope moduleTrace varName =
PatBind l (PVar l (nameTraceInfoVar l visScope varName)) Nothing
(UnGuardedRhs l
(appN
(Var l (qNameMkAtomVariable l) :
moduleTrace :
encodeSpan l ++
[litInt l (fixPriority env varName),
-- 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.
litInt l (fromMaybe 0 (arity env (UnQual l varName))),
litString l (getId varName),
Con l (if isLocal defScope then qNamePreludeTrue l
else qNamePreludeFalse l)])))
Nothing
where
l = ann varName
-}
defNameSpan :: Exp SrcSpanInfo -> SrcSpan -> Decl SrcSpanInfo
defNameSpan moduleTrace span =
PatBind l (PVar l (nameTraceInfoSpan l))
(UnGuardedRhs l
(appN
(Var l (qNameMkSpan l) :
moduleTrace :
encodeSpan l)))
Nothing
where
l = noInfoSpan span
-- Encode a span in the trace file
encodeSpan :: SrcSpanInfo -> [Exp SrcSpanInfo]
encodeSpan span =
[litInt noSpan (10000*beginRow + beginCol)
,litInt noSpan (10000*endRow + endCol)]
where
(beginRow,beginCol,endRow,endCol) = getSpan span
-- Obtain start line, column and end line, column
-- Try to get correct end, as parser gives start of next construct instead.
getSpan :: SrcSpanInfo -> (Int,Int,Int,Int)
getSpan SrcSpanInfo{srcInfoSpan=srcSpan,srcInfoPoints=points} =
(srcSpanStartLine srcSpan, srcSpanStartColumn srcSpan, erow, ecol)
where
end = if null points
then srcSpanEnd srcSpan
else srcSpanEnd (last points)
correct (row,col) = (row,if col > 0 then col-1 else col)
(erow,ecol) = correct end
-- Compress data.
dropInfo :: SrcSpanInfo -> SrcSpan
dropInfo SrcSpanInfo{srcInfoSpan=srcSpan,srcInfoPoints=points} =
srcSpan{srcSpanEndLine = line, srcSpanEndColumn = col}
where
(line,col) = if null points then srcSpanEnd srcSpan else srcSpanEnd (last points)
-- ----------------------------------------------------------------------------
-- Abstract data type for keeping track of two sorts of constants introduced
-- by the transformation.
--
-- 1. Collects all spans used in source references of transformed code,
-- so that corresponding variables can be defined at the top-level of the module.
-- The same span can be added repeatedly, but doubtful this ever happens.
-- 2. Collects information about defined expression names
-- (let-bound variables, fields, methods and data constructors)
-- from the environment of every scope. From this corresponding variables
-- describing the namse and definition locations are obtained at the end.
-- Needs to know whether a scope is local or global, to produce appropriate
-- variable names.
--
-- Have compositional union operator to combine constants.
data ModuleConsts = MC (Set SrcSpan) ([DeclFun] -> [DeclFun])
type DeclFun = Exp SrcSpanInfo -> Decl SrcSpanInfo
moduleConstsEmpty :: ModuleConsts
moduleConstsEmpty = MC Set.empty id
moduleConstsSpan :: SrcSpanInfo -> ModuleConsts
moduleConstsSpan l = MC (Set.singleton (dropInfo l)) id
-- Add a name declaration for every unqualified value name (not type/class) in the environment.
moduleConstsEnv :: Scope -> Environment -> ModuleConsts
moduleConstsEnv scope env = MC Set.empty (\xs -> defineNameEnv scope env defNameVar defNameCon ++ xs)
infixl 5 `moduleConstsUnion`
moduleConstsUnion :: ModuleConsts -> ModuleConsts -> ModuleConsts
moduleConstsUnion (MC spans1 dfs1) (MC spans2 dfs2) = MC (spans1 `Set.union` spans2) (dfs1 . dfs2)
moduleConstsGet :: ModuleConsts -> ([SrcSpan], [DeclFun])
moduleConstsGet (MC spans dfs) = (Set.elems spans, dfs [])
-- ----------------------------------------------------------------------------
-- Transformation of declarations, expressions etc.
-- pre-condition: The environment contains information about all
-- identifiers declared on this level and more global,
-- but not the local scopes inside.
tDecls :: Environment -> Scope -> Tracing ->
[Decl SrcSpanInfo] ->
([Decl SrcSpanInfo], ModuleConsts)
tDecls env scope tracing decls =
foldr combine ([], moduleConstsEmpty)
(map (tDecl env scope tracing) decls)
where
combine :: ([Decl SrcSpanInfo], ModuleConsts) ->
([Decl SrcSpanInfo], ModuleConsts) ->
([Decl SrcSpanInfo], ModuleConsts)
combine (ds1, c1) (ds2, c2) = (ds1 ++ ds2, c1 `moduleConstsUnion` c2)
tDecl :: Environment -> Scope -> Tracing ->
Decl SrcSpanInfo ->
([Decl SrcSpanInfo], ModuleConsts)
tDecl env _ _ synDecl@(TypeDecl span declHead ty) =
(map tTypeSynonym (splitSynonym env synDecl), moduleConstsEmpty)
where
tTypeSynonym :: Decl SrcSpanInfo -> Decl SrcSpanInfo
tTypeSynonym (TypeDecl span declHead ty) =
TypeDecl span (declHead) (tType ty)
tDecl _ _ _ (TypeFamDecl l _ _ _) =
notSupported l "type family declaration"
tDecl env Global tracing d@(DataDecl span dataOrNew maybeContext declHead
qualConDecls maybeDeriving) =
(DataDecl span dataOrNew (fmap tContext maybeContext)
(declHead) (map tQualConDecl qualConDecls) Nothing :
-- "derive" must be empty, because transformed classes cannot be derived
instDecl : fieldSelectorDecls ++ deriveDecls'
,derivedConsts `moduleConstsUnion` fieldSelectorConsts `moduleConstsUnion` deriveConsts)
where
derivedDecls = derive env d
derivedConsts = moduleConstsEnv Local (declsEnv False env derivedDecls)
(deriveDecls', deriveConsts) =
tDecls env Global Trusted derivedDecls
instDecl = wrapValInstDecl env tracing maybeContext declHead qualConDecls
(fieldSelectorDecls, fieldSelectorConsts) = mkFieldSelectors qualConDecls
tDecl _ _ _ (GDataDecl l _ _ _ _ _ _) =
notSupported l "generalized algebraic data type declaration"
tDecl _ _ _ (DataFamDecl l _ _ _) =
notSupported l "data family declaration"
tDecl _ _ _ (TypeInsDecl l _ _) =
notSupported l "type family instance declaration"
tDecl _ _ _ (DataInsDecl l _ _ _ _) =
notSupported l "data family instance declaration"
tDecl _ _ _ (GDataInsDecl l _ _ _ _ _) =
notSupported l "GADT family instance declaration"
tDecl env _ tracing -- class without methods
(ClassDecl l maybeContext declHead fundeps Nothing) =
onlyDecl (ClassDecl l (fmap tContext maybeContext)
(mapDeclHead (updateId id) declHead)
(map tFunDep fundeps) Nothing)
tDecl env _ tracing -- class with methods
(ClassDecl l maybeContext declHead fundeps (Just classDecls)) =
([ClassDecl l (fmap tContext maybeContext)
(mapDeclHead (updateId id) declHead)
(map tFunDep fundeps) (Just classDecls')]
,declsConsts)
where
(classDecls', declsConsts) = tClassDecls env tracing classDecls
tDecl env _ tracing -- class instance without methods
(InstDecl l maybeOverlap instRule Nothing) =
onlyDecl (InstDecl l maybeOverlap (tInstRule instRule)
Nothing)
tDecl env _ tracing -- class instance with methods
inst@(InstDecl l maybeOverlap instRule (Just instDecls)) =
([InstDecl l maybeOverlap (tInstRule instRule)
(Just instDecls')]
,declsConsts `moduleConstsUnion` moduleConstsEnv Local localEnv)
where
(instDecls', declsConsts) = tInstDecls env2 tracing instDecls
-- Add unqualified method names to environment.
-- Qualfied ones should already be in environment but unqualfied may not.
localEnv = instanceEnv (isTraced tracing) env inst
env2 = env `unionLocalRelation` localEnv
tDecl _ _ _ (DerivDecl l _ _) =
notSupported l "standalone deriving declaration"
tDecl _ _ _ (InfixDecl l assoc priority ops) =
([],moduleConstsEmpty)
-- Not needed, because pretty printer produces unambgious output.
-- Transforming would require to differentiate between normal
-- functions and data constructors.
-- onlyDecl (InfixDecl l assoc priority (map nameTransLetVar ops))
tDecl env _ _ (DefaultDecl l tys) =
([DefaultDecl l []
,WarnPragmaDecl l [([], "Defaulting doesn't work in traced programs. Add type annotations to resolve ambiguities.")]]
,moduleConstsEmpty)
tDecl _ _ _ (SpliceDecl l _) =
notSupported l "Template Haskell splicing declaration"
tDecl env _ _ (TypeSig l names ty) =
-- Type signatures need to be preserved (i.e. transformed),
-- because polymorphic recursion needs them or more general
-- types may later lead to ambiguous types
-- Also shared constants need to be typed, in case they are overloaded,
-- so that the monomorphic restriction does not lead to type error
-- (actually then sharing is unfortunately lost)
(TypeSig l (map nameTransLetVar names) (tMapType tFunType ty) :
concatMap mkWorkerTypeSig nonConstNames ++
if null constNames then []
else [TypeSig l (map nameShare constNames) (tMapType tConstType ty)]
,moduleConstsEmpty)
where
(constNames, nonConstNames) = Data.List.partition isNonMethodConstant names
isNonMethodConstant :: Name SrcSpanInfo -> Bool
isNonMethodConstant name =
isLambdaBound env qName || maybe False (==0) (arity env qName)
where
qName = UnQual l name
mkWorkerTypeSig :: Name SrcSpanInfo -> [Decl SrcSpanInfo]
mkWorkerTypeSig name =
case arity env (UnQual l name) of
Just n | n > 0 -> [TypeSig l [nameWorker name] (tMapType (tWorkerType env n) ty)]
_ -> []
tDecl env scope tracing (FunBind l matches) =
tFunBind env scope tracing l matches
-- a function does not use the static parent
tDecl env scope tracing (PatBind l pat rhs maybeBinds) =
tPatBind env scope tracing l pat rhs maybeBinds
tDecl env _ _ (ForImp l callConv maybeSafety maybeString name ty) =
case maybeString >>= stripPrefix "NotHat." of
Just origName -> tForeignImp l (mkQName l origName) name ty
Nothing ->
(ForImp l callConv maybeSafety maybeString (nameForeign name) ty :
-- type is not renamed, original given type left unchanged
wrapperDecls
,consts)
where
(wrapperDecls, consts) = tForeignImp l (UnQual l (nameForeign name)) name ty
tDecl _ _ _ (ForExp l _ _ _ _) =
notSupported l "foreign export declaration"
tDecl _ _ _ (RulePragmaDecl l _) =
notSupported l "RULES pragma"
tDecl _ _ _ (DeprPragmaDecl l list) = onlyDecl (DeprPragmaDecl l list)
tDecl _ _ _ (WarnPragmaDecl l list) = onlyDecl (WarnPragmaDecl l list)
tDecl _ _ _ (InlineSig l _ _ _) =
onlyDecl (WarnPragmaDecl l [([], "ignore INLINE pragma")])
tDecl _ _ _ (InlineConlikeSig l _ _) =
onlyDecl (WarnPragmaDecl l [([], "ignore INLINE CONLIKE pragma")])
tDecl _ _ _ (SpecSig l _ _ _) =
onlyDecl (WarnPragmaDecl l [([], "ignore SPECIALISE pragma")])
tDecl _ _ _ (SpecInlineSig l _ _ _ _) =
onlyDecl (WarnPragmaDecl l [([], "ignore SPECIALISE INLINE pragma")])
tDecl _ _ _ (InstSig l _) =
onlyDecl (WarnPragmaDecl l [([], "ignore SPECIALISE instance pragma")])
tDecl _ _ _ (AnnPragma l _) =
onlyDecl (WarnPragmaDecl l [([], "ignore ANN pragma")])
onlyDecl :: Decl l -> ([Decl l], ModuleConsts)
onlyDecl d = ([d], moduleConstsEmpty)
-- Process pattern binding:
tPatBind :: Environment -> Scope -> Tracing -> SrcSpanInfo ->
Pat SrcSpanInfo -> Rhs SrcSpanInfo ->
Maybe (Binds SrcSpanInfo) ->
([Decl SrcSpanInfo], ModuleConsts)
tPatBind env scope tracing l (PVar _ name) rhs maybeBinds =
-- simple case
tCaf env scope tracing l name rhs maybeBinds
tPatBind env scope tracing l (PAsPat _ name pat) rhs maybeBinds =
-- can break off simple case
(cafDecls ++ patDecls, cafConsts `moduleConstsUnion` patConsts)
where
(cafDecls, cafConsts) =
tCaf env scope tracing l name rhs maybeBinds
(patDecls, patConsts) = tDecl env scope tracing
(PatBind l pat (UnGuardedRhs l (Var l (UnQual l name))) Nothing)
tPatBind env scope tracing l pat rhs maybeBinds =
-- 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 tracing) patNames ++
map (projDef scope tracing l patTuple
(Var l (UnQual l resultTraceName)) patName resultTraceName) patNames ++
[PatBind l (PVar l patName) (UnGuardedRhs l (
(Case l exp'
[Alt l pat'' (UnGuardedRhs l expTuple) Nothing
,Alt l (PWildCard l) (UnGuardedRhs l (mkFailExp expParent)) Nothing])))
Nothing]
,foldr moduleConstsUnion altConsts (map (moduleConstsSpan . ann) patNames))
where
firstName = head patNames
patNames = map (\(PVar _ name) -> name) patVars
patName = nameTraceShared l firstName
resultTraceName = nameTrace2 firstName
expTuple = Tuple l Boxed (map (Var l . UnQual l) (resultTraceName : patNames'))
patTuple = PTuple l Boxed (map (PVar l) (resultTraceName : patNames'))
patNames' = map (\(PVar _ name) -> name) patVars'
(patVars', Nothing) = tPats patVars
-- Nothing means that we do not support numeric patterns (k and n+k)
patVars = getPatVars pat
pat'' = patAddReference resultTraceName pat'
(Match _ _ [pat'] (UnGuardedRhs _ exp') maybeBinds', altConsts) =
tMatch env tracing False undefined failContinuation
(Match l firstName [pat] rhs maybeBinds)
patAddReference :: Name l -> Pat l -> Pat l
patAddReference n (PParen l pat) = PParen l (patAddReference n pat)
patAddReference n (PApp l r [v,_]) = PApp l r [v,PVar l n]
-- Build the first set of definitions for pattern bindings.
useDef :: Tracing -> Name SrcSpanInfo -> Decl SrcSpanInfo
useDef tracing name =
FunBind l [Match l (nameTransLetVar name) [PVar l sr, patParent]
(UnGuardedRhs l (appN
[mkExpConstUse tracing
,Var l (UnQual l sr)
,expParent
,Var l (UnQual l (nameShare name))]))
Nothing]
where
l = ann name
sr = nameSR name
-- Caf for one variable in a pattern binding
projDef :: Scope -> Tracing -> SrcSpanInfo -> Pat SrcSpanInfo -> Exp SrcSpanInfo ->
Name SrcSpanInfo -> Name SrcSpanInfo -> Name SrcSpanInfo -> Decl SrcSpanInfo
projDef scope tracing l patTuple expVarResultTrace patName resultTraceName name =
PatBind l (PVar l (nameShare name))
(UnGuardedRhs l (appN
[mkExpConstDef tracing
,expParent
,Var l (UnQual l (nameTraceInfoVar l scope name))
,Lambda l [PWildCard l]
(Case l (Var l (UnQual l patName))
[Alt l patTuple (UnGuardedRhs l
(if isLocal scope && tracing == Trusted
then varLambdaName
else appN
[Var l (qNameProjection l)
,mkExpSR (ann name) tracing
,Var l (UnQual l resultTraceName)
,varLambdaName]))
Nothing])]))
Nothing
where
varLambdaName = Var l (UnQual l (nameTransLambdaVar name))
-- Extract all variables from a pattern, left-to-right
getPatVars :: Pat SrcSpanInfo -> [Pat SrcSpanInfo]
getPatVars p@(PVar _ _) = [p]
getPatVars (PLit _ _ _) = []
getPatVars (PNPlusK l _ _) = notSupported l "n+k pattern in pattern binding"
getPatVars (PInfixApp _ pl _ pr) = getPatVars pl ++ getPatVars pr
getPatVars (PApp _ _ ps) = concatMap getPatVars ps
getPatVars (PTuple _ _ ps) = concatMap getPatVars ps
getPatVars (PList _ ps) = concatMap getPatVars ps
getPatVars (PParen _ p) = getPatVars p
getPatVars (PRec _ _ patFields) = concatMap getPatFieldVars patFields
where
getPatFieldVars :: PatField SrcSpanInfo -> [Pat SrcSpanInfo]
getPatFieldVars (PFieldPat _ _ p) = getPatVars p
getPatFieldVars (PFieldPun _ _) = []
getPatFieldVars (PFieldWildcard _) = []
getPatVars (PAsPat _ n p) = PVar (ann n) n : getPatVars p
getPatVars (PWildCard _) = []
getPatVars (PIrrPat _ p) = getPatVars p
getPatVars (PatTypeSig _ p _) = getPatVars p
getPatVars (PViewPat _ _ p) = getPatVars p
getPatVars (PBangPat _ p) = getPatVars p
getPatVars p = notSupported (ann p) "in pattern binding"
-- Binding of a single variable
-- The second binding is similar to what projDef produces
tCaf :: Environment -> Scope -> Tracing -> SrcSpanInfo ->
Name SrcSpanInfo -> -- name of original caf
Rhs SrcSpanInfo -> Maybe (Binds SrcSpanInfo) ->
([Decl SrcSpanInfo], ModuleConsts)
tCaf env scope tracing l name rhs maybeBinds =
-- Produce a wrapper and a worker, the latter must be a caf
-- to avoid reevaluation.
-- name sr p = constUse sr p name'
-- name' = constDef parent "name" (\p -> [[rhs]]_p)
([useDef tracing name
,PatBind l (PVar l (nameShare name))
(UnGuardedRhs l (appN
[mkExpConstDef tracing
,expParent
,Var l (UnQual l (nameTraceInfoVar l scope name))
,Lambda l [patParent] (smartExpLet maybeBinds' rhs')]))
Nothing]
,moduleConstsEnv Local envLocal `moduleConstsUnion` rhsConsts `moduleConstsUnion` bindsConsts)
--,addVar l name moduleConstsEmpty `withLocal`
-- (rhsConsts `moduleConstsUnion` bindsConsts))
where
envLocal = maybeBindsEnv (isTraced tracing) maybeBinds
env2 = env `unionLocalRelation` envLocal
(rhs', rhsConsts) = tRhs env2 tracing True failContinuation rhs
(maybeBinds', bindsConsts) = tMaybeBinds env2 tracing maybeBinds
smartExpLet :: Maybe (Binds SrcSpanInfo) -> Exp SrcSpanInfo -> Exp SrcSpanInfo
smartExpLet Nothing exp = exp
smartExpLet (Just binds) exp = Let noSpan binds exp
tMaybeBinds :: Environment -> Tracing -> Maybe (Binds SrcSpanInfo) ->
(Maybe (Binds SrcSpanInfo), ModuleConsts)
tMaybeBinds env tracing Nothing =
(Nothing, moduleConstsEmpty)
tMaybeBinds env tracing (Just binds) =
(Just binds', bindsConsts)
where
(binds', bindsConsts) = tBinds env tracing binds
tBinds :: Environment -> Tracing -> Binds SrcSpanInfo ->
(Binds SrcSpanInfo, ModuleConsts)
tBinds env tracing (BDecls l decls) =
(BDecls l decls', declsConsts)
where
(decls', declsConsts) = tDecls env Local tracing decls
tBinds env tracing (IPBinds l _) =
notSupported l "binding group for implicit parameters"
-- Process function binding:
tFunBind :: Environment -> Scope -> Tracing -> SrcSpanInfo ->
[Match SrcSpanInfo] ->
([Decl SrcSpanInfo], ModuleConsts)
tFunBind env scope tracing l matches =
-- Define the wrapper and the worker.
(FunBind l [Match l (nameTransLetVar orgName)
[PVar l sr, patParent]
(UnGuardedRhs l
(mkExpFun tracing (Var l (UnQual l sr))
(Var l (UnQual l (nameTraceInfoVar l scope orgName)))
(Var l (UnQual l wrappedId')) funArity))
Nothing]
:(if isLocal scope
then (PatBind l (PVar l (nameTraceInfoVar l Global orgName))
(UnGuardedRhs l
(Var l (UnQual l (nameTraceInfoVar l Local orgName))))
Nothing :)
else \x->x)
(FunBind l matches' : 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
,funConsts)
-- ,addVar l orgName (moduleConstsEmpty `withLocal` funConsts))
where
funArity = getMatchArity (head matches)
orgName = getMatchName (head matches)
sr = nameSR orgName
wrappedId' = nameWorker orgName
(matches', newDecls', funConsts) =
tMatches env tracing l (nameFuns orgName)
(map (PVar l) (nameArgs orgName)) wrappedId'
(matchArity (head matches)) False
(map changeInfixMatch matches)
-- Transformation of matches is complex because guarded equations may fail
-- and thus 'fall' to next equation.
-- This is simulated here by a sequence of functions, each possibly calling
-- the next, i.e., we use continuation passing style.
tMatches :: Environment -> Tracing -> SrcSpanInfo ->
[Name SrcSpanInfo] -> -- names for definitions that clauses become
[Pat SrcSpanInfo] -> -- vars for naming arguments that are not vars
Name SrcSpanInfo -> -- name of this definition
Arity ->
Bool -> -- preceeding match will never fail
[Match SrcSpanInfo] ->
([Match SrcSpanInfo], [Decl SrcSpanInfo], ModuleConsts)
tMatches _ _ _ _ _ _ _ True [] =
-- Preceeding match never fails, so no further match required.
([], [], moduleConstsEmpty)
tMatches env tracing l ids pVars funName funArity False [] =
-- End of matches, but add catch-all match to explicitly raise an error.
([Match l funName (replicate funArity (PWildCard l) ++ [patParent])
(UnGuardedRhs l (continuationToExp failContinuation))
Nothing]
,[]
,moduleConstsEmpty)
tMatches env tracing l ids pVars funName funArity _
(m@(Match _ _ pats _ _) : matches) | not (null matches) && matchCanFail m =
-- Normal sort of match: further matches afterwards and guard or numeric literals may fail.
([Match l funName (pats'' ++ [patParent]) rhs' decls'
,Match l funName (vars ++ [patParent])
(UnGuardedRhs l (continuationToExp failCont)) Nothing]
,FunBind l matches' : matchesDecls
,matchConsts `moduleConstsUnion` matchesConsts)
where
contId = head ids
failCont = functionContinuation (UnQual l contId) (map pVarToVar vars)
(pats'', vars) = namePats pats' pVars
(Match _ _ pats' rhs' decls', matchConsts) =
tMatch env tracing True funName failCont m
(matches', matchesDecls, matchesConsts) =
tMatches env tracing l (tail ids) pVars contId funArity
(neverFailingPats pats) matches
tMatches env tracing l ids pVars funName funArity _
(m@(Match _ _ pats _ _) : matches) =
-- Last match or guards and numeric literals cannot fail.
(Match l funName (pats' ++ [patParent]) rhs' decls' : matches'
,matchesDecls
,matchConsts `moduleConstsUnion` matchesConsts)
where
(Match _ _ pats' rhs' decls', matchConsts) =
tMatch env tracing True funName failContinuation m
(matches', matchesDecls, matchesConsts) =
tMatches env tracing l ids pVars funName funArity
(neverFailingPats pats) matches
namePats :: [Pat SrcSpanInfo] -> [Pat SrcSpanInfo] ->
([Pat SrcSpanInfo], [Pat SrcSpanInfo])
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 SrcSpanInfo -- pattern to name
-> Pat SrcSpanInfo -- default variable
-> (Pat SrcSpanInfo,Pat SrcSpanInfo) -- named pattern, name variable
namePat pat@(PVar _ _) _ = (pat,pat)
namePat pat@(PAsPat l name pat') _ = (pat,PVar l name)
namePat pat var@(PVar l name) = (PAsPat l name pat,var)
-- 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.
-- Correct: f 1 True = M -> f v1 v2 | v1 == 1 = h v2 where h True = M
-- Assume that ~ has been removed before.
-- Cannot remove numeric patterns in a separate, earlier phase, because
-- need to handle continuation correctly when already a guard exists.
-- Definition similar to tGuardedExps
tMatch :: Environment ->
Tracing ->
Bool -> -- whether this is reduct of the parent
Name SrcSpanInfo -> -- name for function this match partially defines
ContExp SrcSpanInfo -> -- continuation in case of match failure
Match SrcSpanInfo ->
(Match SrcSpanInfo, ModuleConsts)
tMatch env tracing cr funName contExp m@(Match l _ pats rhs maybeBinds) =
if isNothing numericLitInfos
then (Match l funName pats' (UnGuardedRhs l rhs') maybeBinds'
,moduleConstsEnv Local envLocal `moduleConstsUnion` bindsConsts `moduleConstsUnion` rhsConsts)
else (Match l funName pats' (UnGuardedRhs l (appN (case tracing of
Traced -> [mkExpGuard Traced
,mkExpSR l tracing
,expParent
,cond'
,Lambda l [patParent]
(appN (varFun : argvars ++ [expParent]))
,Lambda l [patParent]
(continuationToExp contExp)]
Trusted -> [mkExpGuard Trusted
,cond'
,appN (varFun : argvars ++ [expParent])
,continuationToExp contExp])))
(Just (BDecls l (def:decl')))
,moduleConstsSpan l `moduleConstsUnion` condConsts `moduleConstsUnion`
declConsts `moduleConstsUnion` matchConsts `moduleConstsUnion` rhsConsts)
-- condConsts contains locations of the Boolean guards
-- declsConsts contains locations of the bound variables
where
envLocal = maybeBindsEnv (isTraced tracing) maybeBinds
envLambdas = makeAllLambdaBound (patsEnv l (isTraced tracing) pats)
env2 = (env `unionLocalRelation` envLambdas) `unionLocalRelation` envLocal
(pats', numericLitInfos) = tPats pats
(rhs', rhsConsts) = tRhs env2 tracing cr contExp rhs
(maybeBinds', bindsConsts) = tMaybeBinds env2 tracing maybeBinds
-- from here for else branch above:
nameFun = nameFunFromSpan l
varFun = Var l (UnQual l nameFun)
Just (qName, cond, bindings, argvars, argpats) = numericLitInfos
envLocalExtra = declsEnv (isTraced tracing) env2 bindings
env3 = (env2 `unionLocalRelation` envLocalExtra) `unionLocalRelation` lambdaVarEnv (isTraced tracing) qName
(cond', condConsts) = tExp env3 tracing False cond
(decl', declConsts) = tDecls env3 Local tracing bindings
def = FunBind l [Match l nameFun (mpats'++[patParent]) mrhs' mmdecls'
,Match l nameFun
(replicate funArity (PWildCard l) ++ [patParent])
(UnGuardedRhs l (continuationToExp contExp))
Nothing]
funArity = length argpats
(Match _ _ mpats' mrhs' mmdecls', matchConsts) =
tMatch env3 tracing cr funName contExp
(Match l nameFun argpats rhs maybeBinds)
-- Here failure means a failed test that can be observed in the trace,
-- not simply non-matching of data constructors.
matchCanFail :: Match l -> Bool
matchCanFail (Match _ _ pats rhs _) =
any numericLitIn pats || case rhs of
UnGuardedRhs _ _ -> False
GuardedRhss _ gdRhss -> gdRhssCanFail gdRhss
numericLitIn :: Pat l -> Bool
numericLitIn (PLit _ _ (Int _ _ _)) = True
numericLitIn (PLit _ _ (Frac _ _ _)) = True
numericLitIn (PInfixApp _ pL _ pR) = numericLitIn pL || numericLitIn pR
numericLitIn (PApp _ _ pats) = any numericLitIn pats
numericLitIn (PTuple _ _ pats) = any numericLitIn pats
numericLitIn (PList _ pats) = any numericLitIn pats
numericLitIn (PParen _ p) = numericLitIn p
numericLitIn (PRec _ _ patFields) = any numericLitInField patFields
where
numericLitInField (PFieldPat _ _ pat) = numericLitIn pat
numericLitInField _ = False
numericLitIn (PAsPat _ _ p) = numericLitIn p
numericLitIn (PIrrPat _ p) = numericLitIn p
numericLitIn (PatTypeSig _ p _) = numericLitIn p
numericLitIn (PViewPat _ _ p) = numericLitIn p
numericLitIn (PBangPat _ p) = numericLitIn p
numericLitIn _ = False
-- Returns False only if one of the guards definitely evaluates to True
-- Note this is an approximation, no guarantee that failure is possible.
gdRhssCanFail :: [GuardedRhs l] -> Bool
gdRhssCanFail = all gdRhsCanFail
gdRhsCanFail :: GuardedRhs l -> Bool
gdRhsCanFail (GuardedRhs _ [Qualifier _ (Var _ name)] _) =
not (isTrue name || isOtherwise name)
gdRhsCanFail _ = True
tRhs :: Environment ->
Tracing ->
Bool -> -- equal to parent?
ContExp SrcSpanInfo -> -- continuation in case of match failure
Rhs SrcSpanInfo ->
(Exp SrcSpanInfo, ModuleConsts)
tRhs env tracing cr failCont (UnGuardedRhs _ exp) =
tExp env tracing cr exp
tRhs env tracing cr failCont (GuardedRhss _ gdRhss) =
tGuardedRhss env tracing cr failCont gdRhss
tGuardedRhss :: Environment ->
Tracing ->
Bool -> -- equal to parent?
ContExp SrcSpanInfo -> -- continuation in case of match failure
[GuardedRhs SrcSpanInfo] ->
(Exp SrcSpanInfo, ModuleConsts)
tGuardedRhss _ _ _ failCont [] =
(continuationToExp failCont, moduleConstsEmpty)
tGuardedRhss env Traced cr failCont
(GuardedRhs _ [Qualifier l guard] exp : gdRhss) =
(appN
[mkExpGuard Traced
,mkExpSR l Traced
,expParent
,guard'
,Lambda l [patParent] exp'
,Lambda l [patParent] gdRhss']
,moduleConstsSpan l `moduleConstsUnion` guardConsts `moduleConstsUnion`
expConsts `moduleConstsUnion` gdRhssConsts)
where
(guard', guardConsts) = tExp env Traced False guard
(exp', expConsts) = tExp env Traced cr exp
(gdRhss', gdRhssConsts) =
tGuardedRhss env Traced cr failCont gdRhss
tGuardedRhss env Trusted cr failCont
(GuardedRhs _ [Qualifier l guard] exp : gdRhss) =
(appN
[mkExpGuard Trusted
,guard'
,exp'
,gdRhss']
,guardConsts `moduleConstsUnion` expConsts `moduleConstsUnion` gdRhssConsts)
where
(guard', guardConsts) = tExp env Trusted False guard
(exp', expConsts) = tExp env Trusted cr exp
(gdRhss', gdRhssConsts) = tGuardedRhss env Trusted cr failCont gdRhss
tGuardedRhss _ _ _ _ (GuardedRhs l _ _ : _) =
notSupported l "statements in pattern guards"
-- Process foreign import:
tForeignImp :: SrcSpanInfo -> QName SrcSpanInfo -> Name SrcSpanInfo ->
Type SrcSpanInfo ->
([Decl SrcSpanInfo], ModuleConsts)
tForeignImp l foreignName name ty =
if arity == 0
then ([TypeSig l [letVarName] (tFunType ty)
,FunBind l [Match l letVarName [PVar l sr, patParent]
(UnGuardedRhs l (appN
[mkExpConstUse Trusted
,Var l (UnQual l sr)
,expParent
,Var l (UnQual l shareName)]))
Nothing]
,PatBind l (PVar l shareName)
(UnGuardedRhs l (appN
[mkExpConstDef Trusted
,expParent
,Var l (UnQual l (nameTraceInfoVar l Global name))
,Lambda l [patParent]
(appN
[expFrom ty, expParent, Var l foreignName])]))
Nothing]
,moduleConstsEmpty)
else ([TypeSig l [letVarName] (tFunType ty)
,FunBind l [Match l letVarName [PVar l sr, patParent]
(UnGuardedRhs l
(mkExpFun Trusted (Var l (UnQual l sr))
(Var l (UnQual l (nameTraceInfoVar l Global name)))
(Var l (UnQual l workerName)) arity))
Nothing]
,FunBind l [Match l workerName (map (PVar l) (args++[hidden]))
(UnGuardedRhs l (appN
[expFrom tyRes
,Var l (UnQual l hidden)
,appN (Var l foreignName : zipWith to tyArgs args)]))
Nothing]]
,moduleConstsEmpty)
where
sr = nameSR name
workerName = nameWorker name
letVarName = nameTransLetVar name
shareName = nameShare name
args = take arity (nameArgs name)
hidden = nameTrace2 name
to :: Type SrcSpanInfo -> Name SrcSpanInfo -> Exp SrcSpanInfo
to ty arg = appN [expTo ty, Var l (UnQual l hidden), Var l (UnQual l arg)]
where
l = ann ty
arity = length tyArgs
(tyArgs, tyRes) = decomposeFunType ty
-- Process class instances:
tInstRule :: InstRule SrcSpanInfo -> InstRule SrcSpanInfo
tInstRule (IRule l mTyVars mCtx iHead) = IRule l (fmap (map tTyVarBind) mTyVars) (fmap tContext mCtx) (tInstHead iHead)
tInstRule (IParen l iRule) = IParen l (tInstRule iRule)
tInstHead :: InstHead SrcSpanInfo -> InstHead SrcSpanInfo
tInstHead (IHCon l qname) = IHCon l (nameTransCls qname) -- or type name?
tInstHead (IHInfix l ty qname) = IHInfix l (tType ty) (nameTransCls qname) -- or type name?
tInstHead (IHParen l iHead) = IHParen l (tInstHead iHead)
tInstHead (IHApp l iHead ty) = IHApp l (tInstHead iHead) (tType ty)
tInstDecls :: Environment -> Tracing ->
[InstDecl SrcSpanInfo] ->
([InstDecl SrcSpanInfo], ModuleConsts)
tInstDecls env tracing instDecls =
(concat instDeclss', foldr moduleConstsUnion moduleConstsEmpty declsConsts)
where
(instDeclss', declsConsts) =
unzip (map (tInstDecl env tracing) instDecls)
tInstDecl :: Environment -> Tracing ->
InstDecl SrcSpanInfo ->
([InstDecl SrcSpanInfo], ModuleConsts)
tInstDecl env tracing (InsDecl l decl) =
(map (InsDecl l) decls', moduleConsts)
where
(decls', moduleConsts) = tClassInstDecl env tracing decl
tInstDecl env tracing (InsType l _ _) =
notSupported l "associated type definition"
tInstDecl env tracing (InsData l _ _ _ _) =
notSupported l "associated data type implementation"
tInstDecl env tracing (InsGData l _ _ _ _ _) =
notSupported l "associated data type implementation using a GADT"
-- Process class declarations:
-- Transform any declarations in a class declaration.
tClassDecls :: Environment -> Tracing ->
[ClassDecl SrcSpanInfo] ->
([ClassDecl SrcSpanInfo], ModuleConsts)
tClassDecls env tracing classDecls =
(concat classDeclss', foldr moduleConstsUnion moduleConstsEmpty declsConsts)
where
(classDeclss', declsConsts) =
unzip (map (tClassDecl env tracing) classDecls)
tClassDecl :: Environment -> Tracing ->
ClassDecl SrcSpanInfo ->
([ClassDecl SrcSpanInfo], ModuleConsts)
tClassDecl env tracing (ClsDecl l decl) =
(map (ClsDecl l) decls', moduleConsts)
where
(decls', moduleConsts) = tClassInstDecl env tracing decl
tClassDecl env tracing (ClsDataFam l _ _ _) =
notSupported l "declaration of an associated data type"
tClassDecl env tracing (ClsTyFam l _ _ _) =
notSupported l "declaration of an associated type synonym"
tClassDecl env tracing (ClsTyDef l _) =
notSupported l "default choice for an associated type synonym"
-- Transform a standard declaration inside a class or instance declaration.
-- Basically patch the result of the standard transformation of such a
-- declaration.
tClassInstDecl :: Environment -> Tracing ->
Decl SrcSpanInfo ->
([Decl SrcSpanInfo], ModuleConsts)
tClassInstDecl env tracing decl@(FunBind _ _) =
-- Worker needs to be local, because it does not belong to the
-- class / instance, nor can it be outside of it.
-- (Cannot use arity optimisation for a method anyway.)
([FunBind l [addToWhere match workerDecls]], moduleConsts)
where
(FunBind l [match] : _ : workerDecls, moduleConsts) =
tDecl env Local tracing decl
tClassInstDecl env tracing decl@(PatBind _ _ _ _) =
-- Currently don't do any patching!
-- 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
-- What does the above mean??
tDecl env Local tracing decl
tClassInstDecl env tracing decl@(TypeSig l names ty) =
-- For every method type declaration produce an additional type declaration
-- of the sharing variable.
(tySig' :
TypeSig l (map nameShare names) (tMapType tConstType ty) :
map (\name -> PatBind l (PVar l (nameShare name))
(UnGuardedRhs l (appN [expUndefined,expSR,expParent])) Nothing)
(filter (isUndefinedMethod env) names)
,moduleConsts)
where
expSR = mkExpSR l Trusted
([tySig'], moduleConsts) = tDecl env Local tracing decl
-- This should cover all declarations that can occur.
-- No changes in functional dependencies; all names are type variables.
tFunDep :: FunDep l -> FunDep l
tFunDep (FunDep l names1 names2) = FunDep l names1 names2
addToWhere :: Match l -> [Decl l] -> Match l
addToWhere (Match l name pats rhs Nothing) decls =
Match l name pats rhs (Just (BDecls l decls))
addToWhere (Match l name pats rhs (Just (BDecls l' ds))) decls =
Match l name pats rhs (Just (BDecls l' (ds ++ decls)))
addToWhere (InfixMatch l pl name pr rhs Nothing) decls =
InfixMatch l pl name pr rhs (Just (BDecls l decls))
addToWhere (InfixMatch l pl name pr rhs (Just (BDecls l' ds))) decls =
InfixMatch l pl name pr rhs (Just (BDecls l' (ds ++ decls)))
-- Split a synonym into a core synonym plus several helpers.
-- pre-condition: the declaration is a type synonym declaration.
-- post-condition: all resulting declarations are type synonym declarations.
-- 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.
splitSynonym :: Environment -> Decl SrcSpanInfo -> [Decl SrcSpanInfo]
splitSynonym env typeDecl@(TypeDecl span declHead ty) =
typeDecl : zipWith mkTypeDecl (hrhss ty) [1..]
where
mkTypeDecl :: Type SrcSpanInfo -> Int -> Decl SrcSpanInfo
mkTypeDecl hrhs no =
TypeDecl span (mapDeclHead (flip nameTransTySynHelper no) declHead) hrhs
hrhss ty = if tys == [ty] then [] else tys
where
tys = go ty []
-- 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 SrcSpanInfo -> [Type SrcSpanInfo] -> [Type SrcSpanInfo]
go ty@(TyForall l _ _ _) [] = [ty]
go (TyFun l tyL tyR) [] = tyL : go tyR []
go ty@(TyTuple _ _ _) [] = [ty]
go ty@(TyList _ _) [] = [ty]
go (TyApp l tyL tyR) tys = go tyL (tyR:tys)
go (TyVar _ _) tys = []
go ty@(TyCon l tyCon) tys
| isFunTyCon tyCon = case tys of
[] -> []
[ty] -> [ty]
[ty1,ty2] -> ty1 : (go ty2 [])
| isExpandableTypeSynonym env tyCon
= go (expandTypeSynonym env tyCon tys) []
| otherwise = [tyAppN (ty:tys)]
go (TyParen l ty) tys = map (TyParen l) (go ty tys) -- a bit dubious
go (TyInfix l tyL tyCon tyR) tys =
if isExpandableTypeSynonym env tyCon
then go (expandTypeSynonym env tyCon (tyL:tyR:tys)) []
else []
go (TyKind l ty kind) tys = notSupported l "kind annotation in type synonym"
-- Map given function over the head name (not argument type names)
mapDeclHead :: (Name l -> Name l) -> DeclHead l -> DeclHead l
mapDeclHead f (DHead l name) = DHead l (f name)
mapDeclHead f (DHInfix l tyVarBind name) = DHInfix l tyVarBind (f name)
mapDeclHead f (DHParen l declHead) = DHParen l (mapDeclHead f declHead)
mapDeclHead f (DHApp l declHead tyVarBind) = DHApp l (mapDeclHead f declHead) tyVarBind
-- Process data type declarations:
{-
addConInfo :: QualConDecl SrcSpanInfo -> ModuleConsts -> ModuleConsts
addConInfo (QualConDecl _ _ _ condecl) =
addConDeclModuleConsts condecl
addConDeclModuleConsts :: ConDecl SrcSpanInfo -> ModuleConsts -> ModuleConsts
addConDeclModuleConsts (ConDecl l name bangtypes) =
addCon name []
addConDeclModuleConsts (InfixConDecl l btL name btR) =
addCon name []
addConDeclModuleConsts (RecDecl l name fieldDecls) =
addCon name (concatMap (\(FieldDecl _ names _) -> names) fieldDecls)
-}
tQualConDecl :: QualConDecl SrcSpanInfo -> QualConDecl SrcSpanInfo
tQualConDecl (QualConDecl l maybeTyVarBinds maybeContext condecl) =
QualConDecl l (fmap (map tTyVarBind) maybeTyVarBinds)
(fmap tContext maybeContext) (tConDecl condecl)
-- Just identity, no change.
tTyVarBind :: TyVarBind SrcSpanInfo -> TyVarBind SrcSpanInfo
tTyVarBind (KindedVar l name kind) = KindedVar l name kind
tTyVarBind (UnkindedVar l name) = UnkindedVar l name
tConDecl :: ConDecl SrcSpanInfo -> ConDecl SrcSpanInfo
tConDecl (ConDecl l name tys) =
ConDecl l (nameTransCon name) (map tConstType tys)
tConDecl (InfixConDecl l tyL name tyR) =
InfixConDecl l (tConstType tyL) (nameTransCon name) (tConstType tyR)
tConDecl (RecDecl l name fieldDecls) =
RecDecl l (nameTransCon name) (map tFieldDecl fieldDecls)
tFieldDecl :: FieldDecl SrcSpanInfo -> FieldDecl SrcSpanInfo
tFieldDecl (FieldDecl l fieldNames ty) =
FieldDecl l (map nameTransField fieldNames) (tConstType ty)
{- not used
tBangType :: BangType SrcSpanInfo -> BangType SrcSpanInfo
tBangType (BangedTy l) = BangedTy l
tBangType (UnpackedTy l) = UnpackedTy l
-}
-- Build field selectors:
mkFieldSelectors :: [QualConDecl SrcSpanInfo] ->
([Decl SrcSpanInfo], ModuleConsts)
mkFieldSelectors qualConDecls =
foldr combine ([], moduleConstsEmpty) . map mkFieldSelector . nubBy eqName .
concatMap getFieldNamesFromQualConDecl $ qualConDecls
where
combine :: ([Decl SrcSpanInfo], ModuleConsts) ->
([Decl SrcSpanInfo], ModuleConsts) ->
([Decl SrcSpanInfo], ModuleConsts)
combine (decls1, modConsts1) (decls2, modConsts2) =
(decls1++decls2, modConsts1 `moduleConstsUnion` modConsts2)
-- 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 :: Name SrcSpanInfo -> ([Decl SrcSpanInfo], ModuleConsts)
mkFieldSelector fieldName =
([FunBind l [Match l (nameTransLetVar fieldName)
[PVar l (nameSR fieldName), patParent]
(UnGuardedRhs l
(mkExpFun Trusted (Var l (UnQual l (nameSR fieldName)))
(Var l (UnQual l (nameTraceInfoVar l Global fieldName)))
(Var l (UnQual l wrappedName)) 1))
Nothing]
,FunBind l [Match l wrappedName
[wrapPat (PVar l varName) (PWildCard l), patParent]
(UnGuardedRhs l (appN
[Var l (qNameProjection l)
,mkExpSR l Trusted
,expParent
,App l (Var l (UnQual l (nameTransField fieldName)))
(Var l (UnQual l varName))]))
Nothing]]
,moduleConstsEmpty)
where
l = ann fieldName
wrappedName = nameWorker fieldName
varName:_ = nameArgs fieldName
-- Build the instance of class WrapVal for type with given data constructors.
-- This instance is needed for constructing and updating with labelled fields.
wrapValInstDecl :: Environment -> Tracing ->
Maybe (Context SrcSpanInfo) ->
DeclHead SrcSpanInfo ->
[QualConDecl SrcSpanInfo] ->
Decl SrcSpanInfo
wrapValInstDecl env tracing maybeContext declHead qualConDecls =
InstDecl l Nothing
(IRule l Nothing maybeContext
(IHApp l (IHCon l (qNameWrapValClass l)) (dataDeclHeadToType declHead)))
(Just [InsDecl l (FunBind l (map wrapValMatch conDecls))])
where
l = ann declHead
conDecls = map (\(QualConDecl _ _ _ conDecl) -> conDecl) qualConDecls
-- assuming this is the head of a type declaration, turn it into a type
-- data T a b = .... => (T a b)
dataDeclHeadToType :: DeclHead SrcSpanInfo -> Type SrcSpanInfo
dataDeclHeadToType declHead = go declHead []
where
go (DHead l name) tys = -- type name
tyAppN (TyCon l (UnQual l name) : tys)
go (DHInfix l tyVarBind name) (ty2:tys) =
tyAppN (TyInfix l (tyVarBind2Type tyVarBind) (UnQual l name) ty2 : tys)
go (DHInfix l _ _) [] = notSupported l "Infix data type with single argument."
go (DHParen l declHead) tys = go declHead tys
go (DHApp l declHead tyVarBind) tys = go declHead (tyVarBind2Type tyVarBind : tys)
wrapValMatch :: ConDecl SrcSpanInfo -> Match SrcSpanInfo
wrapValMatch conDecl =
Match l (nameWrapValFun l)
[PVar l (nameSR (nameWrapValFun l))
,PAsPat l varName patConsApp
,patParent]
(UnGuardedRhs l (wrapExp (Var l (UnQual l varName)) consAppTrace))
Nothing
where
l = ann conDecl
consAppTrace =
if numOfArgs == 0
then appN (Var l (qNameMkExpValueUse l) : expParent :
map (Var l . UnQual l) [srName, funAtom])
else appN (Var l (qNameMkExpValueApp l numOfArgs) : expParent :
map (Var l . UnQual l) (srName : funAtom : traces))
funAtom = nameTraceInfoCon consName
patConsApp =
PApp l (UnQual l consName) (map (wrapPat (PWildCard l) . PVar l) traces)
consName = getConstructorFromConDecl conDecl
traces = take numOfArgs (nameArgs (nameWrapValFun l)) :: [Name SrcSpanInfo]
numOfArgs = getArityFromConDecl conDecl
varName = nameTrace2 (nameWrapValFun l)
srName = nameSR (nameWrapValFun l)
-- ----------------------------------------------------------------------------
-- Transform expressions
-- Boolean 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 :: Environment -> Tracing -> Bool -> Exp SrcSpanInfo ->
(Exp SrcSpanInfo, ModuleConsts)
tExp env tracing cr exp = tExpA env tracing cr exp [] []
-- Order of both lists is innermost first.
-- All input expressions still need to be transformed.
tExpA :: Environment -> Tracing -> Bool -> Exp SrcSpanInfo ->
[SrcSpanInfo] -> -- locations of applications of arguments in list
[Exp SrcSpanInfo] -> -- arguments from surrounding applications
(Exp SrcSpanInfo, ModuleConsts)
tExpA env tracing cr (Var l qName) ls es
| Just a <- ari, a > 0, a <= length es, a <= 5,
let lApp = ls!!(a-1) =
-- Known arity optimisation that calls worker directly
tExpF env tracing (drop a ls) (drop a es) $
(if isTraced tracing || isTracedQName env qName
then mkExpApplyArity (isTracedQName env qName) (mkExpSR lApp tracing) (mkExpSR l tracing)
a (Var noSpan (nameTraceInfoVar l Global qName)) expWorker es'
else mkExpUWrapForward (appN (expWorker : es' ++ [expParent]))
,moduleConstsSpan l `moduleConstsUnion` moduleConstsSpan lApp `moduleConstsUnion` esConsts)
where
ari = arity env qName
(es', esConsts) = tExps env tracing (take (fromJust ari) es)
expWorker = Var noSpan (nameWorker qName)
tExpA env tracing cr (Var l qName) ls es =
-- Unknown arity.
tExpF env tracing ls es $
if isLambdaBound env qName
then
let e' = Var l (nameTransLambdaVar qName)
in if cr
then (mkExpProjection sr e', moduleConstsSpan l)
else (e', moduleConstsEmpty)
else
(appN [Var l (nameTransLetVar qName), sr, expParent]
,moduleConstsSpan l)
where
sr = mkExpSR l tracing
tExpA _ _ _ (IPVar l _) _ _ =
notSupported l "implicit parameter variable"
tExpA env tracing cr (Con l qName) ls es =
tConApp env tracing qName ls es
tExpA env tracing cr (Lit l literal) [] [] = -- no arguments possible
(tLiteral env tracing literal, moduleConstsSpan (ann literal))
tExpA env tracing cr (InfixApp l e1 qop e2) ls es =
tExpA env tracing cr
(App l (App (ann e1 <++> ann qop) (qOp2Exp qop) e1) e2) ls es
tExpA env tracing cr (App l e1 e2) ls es =
tExpA env tracing cr e1 (l:ls) (e2:es)
tExpA env tracing cr (NegApp l e) ls es =
tExpA env tracing cr (App l (Var l (qNameDeriveIdent "negate" l)) e) ls es
-- Use identifier negate, otherwise confusion with binary (-).
tExpA env tracing cr (Lambda l pats body) ls es =
tExpF env tracing ls es
(mkExpFun tracing (mkExpSR l tracing) expMkAtomLambda fun funArity
,moduleConstsSpan l `moduleConstsUnion` bodyConsts)
where
fun = if neverFailingPats pats
then Lambda l (pats' ++ [patParent]) body'
else Lambda l (map (PVar l) nameVars ++ [patParent])
(Case l (mkExpTuple (map (Var l . UnQual l) nameVars))
[Alt l (mkPatTuple pats') (UnGuardedRhs l body') Nothing
,Alt l (PWildCard l) (UnGuardedRhs l expFail) Nothing]
)
(Match _ _ pats' (UnGuardedRhs _ body') _, bodyConsts) =
tMatch env tracing True undefined failContinuation
(Match l undefined pats (UnGuardedRhs l body) Nothing)
nameVars = take funArity (namesFromSpan l)
funArity = length pats
tExpA env tracing cr (Let l binds body) ls es =
tExpF env tracing ls es
(Let l binds' body'
,moduleConstsEnv Local localEnv `moduleConstsUnion` bindsConsts `moduleConstsUnion` bodyConsts)
where
localEnv = bindsEnv (isTraced tracing) binds
env2 = env `unionLocalRelation` localEnv
(binds', bindsConsts) = tBinds env2 tracing binds
(body', bodyConsts) = tExp env2 tracing cr body
tExpA env Traced cr (If l cond e1 e2) ls es =
tExpF env Traced ls es
(mkExpIf l Traced cond'
(Lambda l [patParent] e1') (Lambda l [patParent] e2')
,moduleConstsSpan l `moduleConstsUnion` condConsts `moduleConstsUnion` e1Consts `moduleConstsUnion` e2Consts)
where
(cond', condConsts) = tExp env Traced False cond
(e1', e1Consts) = tExp env Traced True e1
(e2', e2Consts) = tExp env Traced True e2
tExpA env Trusted cr (If l cond e1 e2) ls es =
tExpF env Trusted ls es
(mkExpIf l Trusted cond' e1' e2'
,condConsts `moduleConstsUnion` e1Consts `moduleConstsUnion` e2Consts)
where
(cond', condConsts) = tExp env Trusted False cond
(e1', e1Consts) = tExp env Trusted True e1
(e2', e2Consts) = tExp env Trusted True e2
tExpA env tracing cr (Case l exp alts) ls es =
-- translate case into function f:
-- case exp of
-- pat1 -> exp1
-- pat2 -> exp2
-- ...
-- ==>
-- (let f pat1 = exp1; f pat2 = exp2;... in f) exp
-- but not fully, as we don't want to trace function f and the application
tExpF env tracing ls es
(mkExpCase l tracing
(Let l (BDecls l (FunBind l matches' : decls'))
(Var l (UnQual l funName))) exp'
,moduleConstsSpan l `moduleConstsUnion` expConsts `moduleConstsUnion` funConsts)
where
(funName : argName : funsNames) = namesFromSpan l
(exp', expConsts) = tExp env tracing False exp
(matches', decls', funConsts) =
tMatches env tracing l funsNames [PVar l argName]
funName 1 True (map alt2Match alts)
tExpA env tracing cr (Do l stmts) ls es =
tExpF env tracing ls es (tExpA env tracing cr (removeDo stmts) [] [])
tExpA env tracing cr (MDo l _) ls es =
notSupported l "mdo-expression"
tExpA env tracing cr (Tuple l Boxed exps) [] [] =
tConApp env tracing (Special l (TupleCon l Boxed a))
(replicate a l) exps
where
a = length exps
tExpA env tracing cr (TupleSection l Boxed maybeExps) ls es =
-- desugar tuple section into lambda
tExpA env tracing cr (desugarTupleSection l maybeExps) ls es
tExpA env tracing cr (List l []) [] [] = -- just the empty list, transform efficiently
(appN [Var noSpan (qNameCon noSpan 0),mkExpSR l tracing,expParent
,Con noSpan (qNameConNil noSpan),Var noSpan (qNameTraceInfoConNil noSpan)]
,moduleConstsSpan l)
tExpA env tracing cr (List l exps) [] [] =
-- use special combinator that transforms list at runtime;
-- desugaring and subsequent transformation would lead to large program.
(appN [expFromExpList, mkExpSR l tracing, expParent, List l exps']
,moduleConstsSpan l `moduleConstsUnion` expsConsts)
where
(exps', expsConsts) = tExps env tracing exps
tExpA env tracing cr (Paren l exp) ls es =
tExpA env tracing cr exp ls es
tExpA env tracing cr (LeftSection l exp qOp) ls es =
-- desugar into normal function application
tExpA env tracing cr (App l (qOp2Exp qOp) exp) ls es
tExpA env tracing cr (RightSection l qOp exp) ls es =
-- desugar into use of flip: (op e) = (flip op e)
tExpA env tracing cr (App l (App l (mkExpDeriveFlip l) (qOp2Exp qOp)) exp) ls es
-- -- desugar into a lambda abstraction
-- tExpA env tracing cr
-- (Lambda noSpan [PVar noSpan name]
-- (App l (App l (qOp2Exp qOp) (Var noSpan (UnQual noSpan name))) exp))
-- ls es
-- where
-- name = nameFromSpan l
tExpA env tracing cr (RecConstr l qName fieldUpdates) ls es =
tExpF env tracing ls es $
(appN [expWrapValFun, mkExpSR l tracing,
Paren l (RecUpdate l (Paren l consUndefined) fieldUpdates'), expParent]
,moduleConstsSpan l `moduleConstsUnion` fieldsConsts)
-- Add parenthesis to avoid a bug in the pretty printing of
-- record updates in the haskell-exts library.
where
consUndefined =
if consArity == 0
then Con l (nameTransCon qName)
else appN (Con l (nameTransCon qName) : replicate consArity
(appN [expUndefined, expSR, expParent]))
Just consArity = arity env qName
expSR = mkExpSR l Trusted
(fieldUpdates', fieldsConsts) = mapMerge2 (tField env tracing) fieldUpdates
tExpA env Traced cr (RecUpdate l exp fieldUpdates) ls es =
tExpF env Traced ls es $
(Let l (BDecls l (zipWith mkFieldVarDecl fieldVarNames fieldExps'))
(appN (mkExpUpdate Traced (length labels)
:mkExpSR l Traced
:expParent
:exp'
:Lambda l [PVar l nameVar]
(RecUpdate l (Var l (UnQual l nameVar)) varFields')
:labels ++ fieldVars))
,moduleConstsSpan l `moduleConstsUnion` expConsts `moduleConstsUnion` fieldsConsts)
where
mkFieldVarDecl :: Name SrcSpanInfo -> Exp SrcSpanInfo -> Decl SrcSpanInfo
mkFieldVarDecl name exp =
PatBind noSpan (PVar noSpan name) (UnGuardedRhs noSpan exp) Nothing
(exp', expConsts) = tExp env Traced False exp
(fieldUpdates', fieldsConsts) = mapMerge2 (tField env Traced) fieldUpdates
labels = map (Var l . UnQual l . nameTraceInfoVar l Global) labelNames
varFields' = zipWith (FieldUpdate l) (map fieldLabel fieldUpdates') fieldVars
fieldExps' = map fieldExp fieldUpdates'
fieldVars = map (Var l . UnQual l) fieldVarNames
fieldVarNames = map nameShare labelNames
labelNames = map (qName2Name . fieldLabel) fieldUpdates
nameVar = nameFromSpan l
fieldLabel (FieldUpdate _ qNameLabel _) = qNameLabel
fieldLabel (FieldPun l _) = notSupported l "record field pun"
fieldLabel (FieldWildcard l) = notSupported l "record field wildcard"
fieldExp (FieldUpdate _ _ exp) = exp
fieldExp (FieldPun l _) = notSupported l "record field pun"
fieldExp (FieldWildcard l) = notSupported l "record field wildcard"
tExpA env Trusted cr (RecUpdate l exp fieldUpdates) ls es =
tExpF env Trusted ls es $
(appN [mkExpUpdate Trusted (-1)
,expParent
,exp'
,Lambda l [PVar l nameVar]
(RecUpdate l (Var l (UnQual l nameVar)) fieldUpdates')]
,expConsts `moduleConstsUnion` fieldsConsts)
where
(exp', expConsts) = tExp env Trusted False exp
(fieldUpdates', fieldsConsts) = mapMerge2 (tField env Trusted) fieldUpdates
nameVar = nameFromSpan l
tExpA env tracing cr (EnumFrom l exp) ls es =
-- desugar list enumeration [from ..]
tExpA env tracing cr (App l (mkExpDeriveEnumFrom l) exp) ls es
tExpA env tracing cr (EnumFromTo l from to) ls es =
tExpA env tracing cr (App l (App l (mkExpDeriveEnumFromTo l) from) to) ls es
tExpA env tracing cr (EnumFromThen l from the) ls es =
tExpA env tracing cr
(App l (App l (mkExpDeriveEnumFromThen l) from) the) ls es
tExpA env tracing cr (EnumFromThenTo l from the to) ls es =
tExpA env tracing cr
(App l (App l (App l (mkExpDeriveEnumFromThenTo l) from) the) to) ls es
tExpA env tracing cr (ListComp l exp qualStmts) ls es =
tExpF env tracing ls es $
tExpA env tracing cr (desugarListComprehension l exp qualStmts) ls es
tExpA env tracing cr (ParComp l _ _) ls es =
notSupported l "parallel list comprehension"
tExpA env tracing cr (ExpTypeSig l exp ty) ls es =
tExpF env tracing ls es $
(ExpTypeSig l exp' ty', expConsts)
where
(exp', expConsts) = tExp env tracing cr exp
ty' = tConstType ty
tExpA env tracing cr (VarQuote l _) ls es =
notSupported l "template Haskell reifying of expressions"
tExpA env tracing cr (TypQuote l _) ls es =
notSupported l "template Haskell reifying of types"
tExpA env tracing cr (BracketExp l _) ls es =
notSupported l "template Haskell bracket expression"
tExpA env tracing cr (SpliceExp l _) ls es =
notSupported l "template Haskell splice expression"
tExpA env tracing cr (QuasiQuote l _ _) ls es =
notSupported l "template Haskell quasi-quote"
tExpA env tracing cr (XTag l _ _ _ _) ls es =
notSupported l "xml element with attributes and children"
tExpA env tracing cr (XETag l _ _ _) ls es =
notSupported l "empty xml element, with attributes"
tExpA env tracing cr (XPcdata l _) ls es =
notSupported l "PCDATA child element"
tExpA env tracing cr (XExpTag l _) ls es =
notSupported l "escaped Haskell expression inside XML"
tExpA env tracing cr (XChildTag l _) ls es =
notSupported l "children of an xml element"
tExpA env tracing cr (CorePragma l _ _) ls es =
notSupported l "CORE pragma"
tExpA env tracing cr (SCCPragma _ "" exp@(Lambda _ _ _)) ls es =
-- This is a hack: desugaring of do-expressions uses empty SCC marker
-- so that here we can say that the lambda is from a do-expression.
tExpF env tracing ls es $ (appN [fun,expMkAtomDoLambda,sr,par,lambda], expConsts)
where
(App l1 (App l2 (App l3 (App l4 fun _) sr) par) lambda, expConsts) = tExp env tracing cr exp
tExpA env tracing cr (SCCPragma l str exp) ls es =
tExpF env tracing ls es $
(SCCPragma l str exp', expConsts)
where
(exp', expConsts) = tExp env tracing cr exp
tExpA env tracing cr (GenPragma l _ _ _ _) ls es =
notSupported l "GENERATED pragma"
tExpA env tracing cr (Proc l _ _) ls es =
notSupported l "arrows proc"
tExpA env tracing cr (LeftArrApp l _ _) ls es =
notSupported l "arrow application from left"
tExpA env tracing cr (RightArrApp l _ _) ls es =
notSupported l "arrow application from right"
tExpA env tracing cr (LeftArrHighApp l _ _) ls es =
notSupported l "higher-order arrow application from left"
tExpA env tracing cr (RightArrHighApp l _ _) ls es =
notSupported l "higher-order arrow application from right"
tExpA _ _ _ exp _ _ =
notSupported (ann exp) "unkown form of expression"
-- At end of transforming expressions possibly add deferred applications.
-- Lists are ordered from innermost to outermost.
-- Pre-condition: expression already transformed,
-- but expressions in list not yet transformed.
tExpF :: Environment -> Tracing ->
[SrcSpanInfo] -> -- locations of surrounding applications
[Exp SrcSpanInfo] -> -- arguments of surrounding apps
(Exp SrcSpanInfo, ModuleConsts) ->
(Exp SrcSpanInfo, ModuleConsts)
tExpF _ _ [] [] result = result
tExpF env tracing ls es (e, consts) =
(mkExpApply tracing (mkExpSR l tracing) (e : es'),
moduleConstsSpan l `moduleConstsUnion` esConsts `moduleConstsUnion` consts)
where
l = last ls
(es', esConsts) = tExps env tracing es
-- Transform a list of expressions.
-- Mainly have to merge all constants.
tExps :: Environment -> Tracing -> [Exp SrcSpanInfo] ->
([Exp SrcSpanInfo], ModuleConsts)
tExps env tracing = mapMerge2 (tExp env tracing False)
mapMerge2 :: (a -> (b, ModuleConsts)) -> [a] -> ([b], ModuleConsts)
mapMerge2 f = mapSnd (foldr moduleConstsUnion moduleConstsEmpty) . unzip . map f
mapSnd :: (a -> b) -> (c, a) -> (c, b)
mapSnd f (x,y) = (x, f y)
-- Transform data constructor application.
-- Number of arguments may be smaller than arity of the data constructor.
-- (but never greater.)
tConApp :: Environment -> Tracing -> QName SrcSpanInfo ->
[SrcSpanInfo] -> [Exp SrcSpanInfo] ->
(Exp SrcSpanInfo, ModuleConsts)
tConApp env tracing qName ls es =
(if conArity > numberOfArgs -- undersaturated application
then mkExpPartial sr conArity numberOfArgs qName es'
else if conArity == numberOfArgs -- saturated application
then mkExpCon sr conArity qName es'
else
error "TraceTrans.tConApp: data constructor with too many arguments."
,moduleConstsSpan lApp `moduleConstsUnion` esModuleConsts)
where
Just conArity = arity env qName -- a constructor always has an arity
numberOfArgs = length es
lApp = last (ann qName : ls) -- location of outermost application (or just constructor itself)
sr = mkExpSR lApp tracing
(es',esModuleConsts) = tExps env tracing es
tLiteral :: Environment -> Tracing -> Literal SrcSpanInfo ->
Exp SrcSpanInfo
tLiteral env tracing lit@(Char l c _) =
mkExpConChar (mkExpSR l tracing) lit
tLiteral env tracing lit@(String l str _) =
-- Because the result of transforming a list of characters would be very
-- large use special combinator that
-- transforms string in traced string at runtime instead
mkExpFromLitString (mkExpSR l tracing) lit
tLiteral env tracing lit@(Int l integer _) =
mkExpApply tracing sr
[mkExpFromInteger sr, mkExpConInteger sr lit]
where
sr = mkExpSR l tracing
tLiteral env tracing lit@(Frac l rational _) =
-- 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
mkExpApply tracing sr
[appN [expFromRational, sr, expParent]
,appN [Var l (qNameR l)
,appN [expConRational
,mkExpConInteger sr litNum
,mkExpConInteger sr litDenom]
,appN [expMkAtomRational, sr, expParent, Lit noSpan lit]
]]
where
sr = mkExpSR l tracing
Lit _ litNum = litInt noSpan (numerator rational)
Lit _ litDenom = litInt noSpan (denominator rational)
tLiteral env tracing lit =
notSupported (ann lit) "unboxed literal"
-- return False if matching the pattern may fail
-- otherwise try to return True
-- (safe approximation)
neverFailingPat :: Pat l -> Bool
neverFailingPat (PVar _ _) = True
neverFailingPat (PTuple _ _ ps) = neverFailingPats ps
neverFailingPat (PParen _ p) = neverFailingPat p
neverFailingPat (PAsPat _ _ p) = neverFailingPat p
neverFailingPat (PWildCard _) = True
neverFailingPat (PIrrPat _ _) = True
neverFailingPat (PatTypeSig _ p _) = neverFailingPat p
neverFailingPat (PBangPat _ p) = neverFailingPat p
neverFailingPat _ = False
neverFailingPats :: [Pat l] -> Bool
neverFailingPats = all neverFailingPat
-- Minor transformation here.
-- The main step is in the construction or update expression for a record.
tField :: Environment -> Tracing -> FieldUpdate SrcSpanInfo ->
(FieldUpdate SrcSpanInfo, ModuleConsts)
tField env tracing (FieldUpdate l qName exp) =
(FieldUpdate l (nameTransField qName) exp', expConsts)
where
(exp', expConsts) = tExp env tracing False exp
tField env tracing (FieldPun l name) =
notSupported l "record field pun"
tField env tracing (FieldWildcard l) =
notSupported l "record field wildcard"
-- Desugar do-statements
removeDo :: [Stmt SrcSpanInfo] -> Exp SrcSpanInfo
removeDo [Qualifier l exp] = -- last stmt in do-expression
exp
removeDo (Qualifier l exp : stmts) =
appN [Var l (qNameDeriveGtGt l), exp, removeDo stmts]
removeDo (LetStmt l binds : stmts) =
Let l binds (removeDo stmts)
removeDo (Generator l pat e : stmts) =
appN [Var l (qNameDeriveGtGtEq l)
,e
,SCCPragma l "" $ -- hack to inform this really from a do-stmt
if neverFailingPat pat
then Lambda l [pat] (removeDo stmts)
else Lambda l [PVar l newName]
(Case l (Var l (UnQual l newName))
[Alt l pat (UnGuardedRhs l (removeDo stmts)) Nothing
,Alt l (PWildCard l)
(UnGuardedRhs l
(App l (Var l (qNameDeriveFail l))
(Lit l (String l msg msg))))
Nothing])]
where
newName : _ = namesFromSpan l
msg = "pattern-match failure in do-expression"
-- Desugar tuple section (,4,,1)
-- Replace by a lambda abstraction \x1 x2 -> (x1,4,x2,1)
desugarTupleSection :: SrcSpanInfo -> [Maybe (Exp SrcSpanInfo)] ->
Exp SrcSpanInfo
desugarTupleSection l maybeExps =
Lambda l (map (PVar l) varNames) (mkExpTuple (mkTuple maybeExps varNames))
where
arity = length (filter isNothing maybeExps)
varNames = take arity (namesFromSpan l)
mkTuple :: [Maybe (Exp SrcSpanInfo)] -> [Name SrcSpanInfo] ->
[Exp SrcSpanInfo]
mkTuple [] _ = []
mkTuple (Nothing : mes) (name : names) =
Var l (UnQual l name) : mkTuple mes names
mkTuple (Just e : mes) names = e : mkTuple mes names
desugarListComprehension :: SrcSpanInfo -> Exp SrcSpanInfo ->
[QualStmt SrcSpanInfo] ->
Exp SrcSpanInfo
desugarListComprehension l exp qualStmts =
Do l (map (trans . unQual) qualStmts ++ [Qualifier l (App l (mkExpDeriveReturn l) exp)])
where
unQual :: QualStmt SrcSpanInfo -> Stmt SrcSpanInfo
unQual (QualStmt _ stmt) = stmt
unQual qs = notSupported l "qualifier beyond a statement in list comprehension"
trans :: Stmt SrcSpanInfo -> Stmt SrcSpanInfo
trans s@(Generator _ _ _) = s
trans (Qualifier l exp ) = Qualifier l (App l (mkExpDeriveGuard l) exp)
trans s@(LetStmt _ _) = s
trans (RecStmt _ _) = notSupported l "recursive statement for arrows in list comprehension"
-- ----------------------------------------------------------------------------
-- Transform patterns
tPats :: [Pat SrcSpanInfo] ->
([Pat SrcSpanInfo] -- transformed patterns
,Maybe -- only if there is a numeric pattern (k or n+k)
(QName SrcSpanInfo -- new name for numeric pattern
,Exp SrcSpanInfo -- test for the numeric pattern (e.g. x==k)
,[Decl SrcSpanInfo] -- binding for n if there is an n+k pattern
,[Exp SrcSpanInfo] -- variables inserted in pattern after num pat
,[Pat SrcSpanInfo])) -- original patterns after num pat
tPats = mapCombinePats tPat
mapCombinePats :: (Pat SrcSpanInfo ->
(Pat SrcSpanInfo, Maybe (a,c,d,[Exp SrcSpanInfo],[Pat SrcSpanInfo]))) ->
[Pat SrcSpanInfo] ->
([Pat SrcSpanInfo], Maybe (a,c,d,[Exp SrcSpanInfo],[Pat SrcSpanInfo]))
mapCombinePats f [] = ([], Nothing)
mapCombinePats f (x:xs) =
case f x of
(pat, Nothing) -> (pat:pats, numPatInfos)
(pat, Just (i,e,d,vs,ps)) -> (pat:xvps, Just (i,e,d,vs++xves,ps++xs))
where
(pats, numPatInfos) = mapCombinePats f xs
xvps = map patToVar xs
xves = map pVarToVar xvps
-- Replace every pattern by a variable pattern.
patToVar :: Pat SrcSpanInfo -> Pat SrcSpanInfo
patToVar (PVar l name) = PVar l (nameTransLambdaVar name)
patToVar (PAsPat l name pat) = PVar l (nameTransLambdaVar name)
patToVar pat = PVar l (nameFromSpan l)
where
l = ann pat
pVarToVar :: Pat l -> Exp l
pVarToVar (PVar l name) = Var l (UnQual l name)
-- Transform a pattern.
-- In particular handle numeric subpatterns, i.e. k and n+k.
-- Also create environment for occuring variables assuming they are
-- lambda-bound, except where declaration with let-binding created.
tPat :: Pat SrcSpanInfo ->
(Pat SrcSpanInfo
,Maybe (QName SrcSpanInfo, Exp SrcSpanInfo, [Decl SrcSpanInfo]
,[Exp SrcSpanInfo], [Pat SrcSpanInfo]))
tPat (PVar l name) = (PVar l (nameTransLambdaVar name), Nothing)
tPat (PLit _ (Signless _) lit@(Char l c str)) =
(wrapPat (PLit l (Signless l) lit) (PWildCard l), Nothing)
tPat (PLit _ (Signless _) (String l s str)) =
tPat . mkPatList l . map mkPatChar $ s
where
mkPatChar :: Char -> Pat SrcSpanInfo
mkPatChar c = PLit l (Signless l) (Char l c (show c))
tPat (PLit _ (Signless _) lit@(Int l int str)) =
(PVar l (nameTransLambdaVar nameNew)
,Just (UnQual l nameNew
,App l (App l (mkExpDeriveEqualEqual l)
(Var l (UnQual l nameNew)))
(Lit l lit)
,[],[],[]))
where
nameNew = nameFromSpan l
tPat (PLit _ (Signless _) lit@(Frac l rat str)) =
(PVar l (nameTransLambdaVar nameNew)
,Just (UnQual l nameNew
,App l (App l (mkExpDeriveEqualEqual l)
(Var l (UnQual l nameNew)))
(Lit l lit)
,[],[],[]))
where
nameNew = nameFromSpan l
tPat (PLit l (Negative _) (Int _ int str)) =
-- a negative integer literal is represented as negate int, so literal can be negative
-- differs from ghc where
-- f (-k) = v is sugar for f z | z == negate (fromInteger k) = v
tPat (PLit l (Signless l) (Int l (-int) ('-':str)))
tPat (PLit l (Negative _) (Frac _ rat str)) =
-- a negative floating point literal is represented as negate frac
-- same issues as above
tPat (PLit l (Signless l) (Frac l (-rat) ('-':str)))
tPat (PLit l _ lit) =
notSupported l "unsupported literal in pattern"
tPat (PNPlusK l n k) =
(PVar l (nameTransLambdaVar nameNew)
,Just (UnQual l nameNew
,App l (App l (mkExpDeriveGreaterEqual l)
varNew)
litK
,[PatBind l (PVar l n)
(UnGuardedRhs l (App l (App l (mkExpDeriveMinus l) varNew)
litK))
Nothing]
,[],[]))
where
nameNew = nameFromSpan l
varNew = Var l (UnQual l nameNew)
litK = Lit l (Int l k (show k))
tPat (PInfixApp l pL qName pR) =
tPat (PApp l qName [pL, pR])
tPat (PApp l qName pats) =
(wrapPat (PApp l (nameTransCon qName) pats') (PWildCard l)
,patsNumInfo)
where
(pats', patsNumInfo) = tPats pats
tPat (PTuple l Boxed pats) =
tPat (PApp l (Special l (TupleCon l Boxed arity)) pats)
where
arity = length pats
tPat (PList l []) = -- just empty list constructor
(wrapPat (PApp l (qNameConNil l) []) (PWildCard l), Nothing)
tPat (PList l pats) =
tPat (mkPatList l pats)
tPat (PParen l pat) =
(PParen l pat', patNumInfo)
where
(pat', patNumInfo) = tPat pat
tPat (PRec l qName patFields) =
(wrapPat (PRec l (nameTransCon qName) patFields') (PWildCard l)
,numInfos)
where
(patFields', numInfos) = tPatFields patFields
tPat (PAsPat l name pat) =
(PAsPat l (nameTransLambdaVar name) pat', patNumInfos)
where
(pat', patNumInfos) = tPat pat
tPat (PWildCard l) =
(PWildCard l, Nothing)
tPat (PIrrPat l pat) =
if isNothing patNumInfos
then
(case pat' of
PApp l' nameR [p',t'] -> PApp l' nameR [PIrrPat l p', t']
x -> x -- wildcard, ...
,Nothing)
else notSupported l "numeric literal or n+k inside ~ pattern"
where
(pat', patNumInfos) = tPat pat
tPat (PatTypeSig l pat ty) =
(PatTypeSig l pat' (tConstType ty), patNumInfos)
where
(pat', patNumInfos) = tPat pat
tPat (PViewPat l _ _) =
notSupported l "view pattern"
tPat (PRPat l _) =
notSupported l "regular list pattern"
tPat (PXTag l _ _ _ _) =
notSupported l "XML element pattern"
tPat (PXETag l _ _ _) =
notSupported l "XML singleton element pattern"
tPat (PXPcdata l _) =
notSupported l "XML PCDATA pattern"
tPat (PXPatTag l _) =
notSupported l "XML embedded pattern"
tPat (PXRPats l _) =
notSupported l "XML regular list pattern"
tPat (PQuasiQuote l _ _) =
notSupported l "quasi quote pattern"
tPat (PBangPat l pat) =
-- strictness is currently ignored
tPat pat
-- Rename field labels and process patterns.
tPatFields :: [PatField SrcSpanInfo] ->
([PatField SrcSpanInfo]
,Maybe (QName SrcSpanInfo, Exp SrcSpanInfo, [Decl SrcSpanInfo]
,[Exp SrcSpanInfo], [Pat SrcSpanInfo]))
tPatFields patFields =
(patFields', numInfos)
where
(spans, names, pats) = unzipFields patFields
(pats', numInfos) = mapCombinePats tPat pats
patFields' = zipFields spans (map nameTransField names) pats'
unzipFields :: [PatField SrcSpanInfo] ->
([SrcSpanInfo], [QName SrcSpanInfo], [Pat SrcSpanInfo])
unzipFields [] = ([],[],[])
unzipFields (PFieldPat l qName pat : fields) = (l:ls, qName:names, pat:pats)
where
(ls, names, pats) = unzipFields fields
unzipFields (PFieldPun l _ : _) = notSupported l "record field pun"
unzipFields (PFieldWildcard l : _) = notSupported l "record field wildcard"
zipFields :: [SrcSpanInfo] -> [QName SrcSpanInfo] -> [Pat SrcSpanInfo] ->
[PatField SrcSpanInfo]
zipFields = zipWith3 PFieldPat
-- apply data constructor R
wrapPat :: Pat SrcSpanInfo -> Pat SrcSpanInfo -> Pat SrcSpanInfo
wrapPat expVal expTrace = PApp noSpan (qNameR noSpan) [expVal, expTrace]
-- apply data constructor R
wrapExp :: Exp SrcSpanInfo -> Exp SrcSpanInfo -> Exp SrcSpanInfo
wrapExp expVal expTrace = appN [Con noSpan (qNameR noSpan), expVal, expTrace]
mkPatList :: l -> [Pat l] -> Pat l
mkPatList l =
foldr (\x xs -> PApp l cons [x,xs]) (PList l [])
where
cons = qNameCons l
-- ----------------------------------------------------------------------------
-- 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 l = Fail | Function (QName l) [Exp l]
failContinuation :: ContExp l
failContinuation = Fail
functionContinuation :: QName l -> [Exp l] -> ContExp l
functionContinuation = Function
continuationToExp :: ContExp SrcSpanInfo -> Exp SrcSpanInfo
continuationToExp Fail = mkFailExp expParent
continuationToExp (Function fun args) =
appN (Var l fun : args ++ [expParent])
where
l = ann fun
-- ----------------------------------------------------------------------------
-- Transform types
-- ty ==> R [[ty]]
tConstType :: Type SrcSpanInfo -> Type SrcSpanInfo
tConstType ty = wrapType (tType ty)
-- ty ==> RefSrcPos -> Trace -> R [[ty]]
tFunType :: Type SrcSpanInfo -> Type SrcSpanInfo
tFunType ty =
TyCon l (qNameRefSrcSpan l) `typeFun` TyCon l (qNameRefExp l) `typeFun`
wrapType (tType ty)
where
l = ann ty
-- Leave any outer context unchanged but apply function to rest of type.
tMapType :: (Type SrcSpanInfo -> Type SrcSpanInfo) -> Type SrcSpanInfo -> Type SrcSpanInfo
tMapType f (TyForall l maybeBinds maybeContext ty) = TyForall l maybeBinds maybeContext (f ty)
tMapType f (TyParen l ty) = TyParen l (f ty)
tMapType f ty = f ty
-- Build type of worker from original type
tWorkerType :: Environment -> Arity -> Type SrcSpanInfo -> Type SrcSpanInfo
tWorkerType _ 0 ty =
TyCon l (qNameRefExp l) `typeFun` wrapType (tType ty)
where
l = ann ty
tWorkerType env a ty = tWorkerSynExpand env a ty []
-- Expand a type synonym and then apply worker type transformation.
-- Need to collect type arguments.
tWorkerSynExpand :: Environment -> Arity -> Type SrcSpanInfo ->
[Type SrcSpanInfo] ->
Type SrcSpanInfo
tWorkerSynExpand env a (TyFun l tyL tyR) [] =
wrapType (tType tyL) `typeFun` tWorkerType env (a-1) tyR
tWorkerSynExpand env a (TyCon l qname) [tyL, tyR] | isFunTyCon qname =
wrapType (tType tyL) `typeFun` tWorkerType env (a-1) tyR
tWorkerSynExpand env a (TyCon l qname) tys =
tWorkerType env a (expandTypeSynonym env qname tys)
tWorkerSynExpand env a (TyApp l tyL tyR) tys =
tWorkerSynExpand env a tyL (tyR : tys)
tWorkerSynExpand env a (TyParen l ty) tys =
TyParen l (tWorkerSynExpand env a ty tys)
tWorkerSynExpand _ a ty tys =
error ("TraceTrans.tWorkerSynExpand: type must be a function but is not:\ntWorkerSynExpand env " ++
show a ++ prettyPrint ty ++ concatMap ((" & "++) . prettyPrint) tys)
-- Just rewrite built-in type constructors, especially function type.
-- (Otherwise type names stay unchanged, they will refer to different modules.)
-- t1 -> t2 ==> Fun [[t1]] [[t2]]
tType :: Type SrcSpanInfo -> Type SrcSpanInfo
tType (TyForall l maybeTyVarBinds maybeContext ty) =
TyForall l maybeTyVarBinds maybeContext (tType ty)
tType (TyFun l tyL tyR) =
tType (tyAppN [TyCon l (Special l (FunCon l)), tyL, tyR])
tType (TyTuple l boxed tys) =
tType (tyAppN (TyCon l (Special l (TupleCon l boxed (length tys))) : tys))
tType (TyList l ty) =
tType (TyApp l (TyCon l (Special l (ListCon l))) ty)
tType (TyApp l tyL tyR) = TyApp l (tType tyL) (tType tyR)
tType (TyVar l name) = TyVar l (nameTransTyVar name)
tType (TyCon l name) = TyCon l (nameTransTy name)
tType (TyParen l ty) = TyParen l (tType ty)
tType (TyInfix l tyL name tyR) =
TyInfix l (tType tyL) (nameTransTy name) (tType tyR)
tType (TyKind l ty kind) = TyKind l (tType ty) kind
-- ty ==> R ty
wrapType :: Type SrcSpanInfo -> Type SrcSpanInfo
wrapType ty = TyApp noSpan (TyCon noSpan (qNameR noSpan)) ty
-- Class contexts remain unchanged
-- (except possibly for identifier qualifications and type renaming)
tContext :: Context SrcSpanInfo -> Context SrcSpanInfo
tContext (CxSingle l asst) = CxSingle l (tAsst asst)
tContext (CxTuple l assts) = CxTuple l (map tAsst assts)
tContext (CxEmpty l) = CxEmpty l
tAsst :: Asst SrcSpanInfo -> Asst SrcSpanInfo
tAsst (ClassA l qNameClass tys) =
ClassA l (nameTransCls qNameClass) (map tType tys)
tAsst (InfixA l tyL qNameClass tyR) =
InfixA l (tType tyL) (nameTransCls qNameClass) (tType tyR)
tAsst (IParam l _ _) = notSupported l "implicit parameter assertion"
tAsst (EqualP l tyL tyR) = EqualP l (tType tyL) (tType tyR)
-- ----------------------------------------------------------------------------
-- 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 :: ModuleName l -> Name l
nameTraceInfoModule (ModuleName l ident) = Ident l ('t' : withoutPrefix)
where
withoutPrefix = reverse . takeWhile (/= '.') . reverse $ ident
nameTraceInfoVar :: UpdId i => SrcSpanInfo -> Scope -> i -> i
nameTraceInfoVar span Global = prefixName 'a' '+'
nameTraceInfoVar span Local = prefixSpanName 'c' '+' span
nameTraceInfoGlobalVar :: UpdId i => i -> i
nameTraceInfoGlobalVar = prefixName 'a' '+'
nameTraceInfoCon :: UpdId i => i -> i
nameTraceInfoCon = prefixName 'a' '+'
nameTraceInfoSpan :: SrcSpanInfo -> Name SrcSpanInfo
nameTraceInfoSpan span = Ident span ('p' : showsEncodeSpan span "")
-- names referring to transformed program fragments:
-- The unqualfied names in the namespace of classes, types and type synonyms
-- are left unchanged, but the module changes.
-- Names of some built-in type constructors (e.g ->, [], (,)) are changed!
-- Similarly type variable names are left unchanged.
nameTransCls :: UpdId i => i -> i
nameTransCls = updateId id
nameTransTy :: UpdId i => i -> i
nameTransTy = updateId id
nameTransSyn :: UpdId i => i -> i
nameTransSyn = updateId id
nameTransTyVar :: Name l -> Name l
nameTransTyVar = id -- unchanged
nameTransCon :: UpdId i => i -> i
nameTransCon = updateId id -- unchanged
nameTransField :: UpdId i => i -> i
nameTransField = prefixName 'b' '^'
nameTransLetVar :: UpdId i => i -> i
nameTransLetVar = prefixName 'g' '!'
nameTransLambdaVar :: UpdId i => i -> i
nameTransLambdaVar = prefixName 'f' '&'
-- internal, local names
-- refering to partially transformed expression
nameWorker :: UpdId i => i -> i
nameWorker = prefixName 'h' '*'
-- refering to original (unwrapped) foreign import
nameForeign :: UpdId i => i -> i
nameForeign = prefixName 'f' '&'
-- names for new variables in transformed expressions:
-- variable for sharing in transformation of pattern binding
nameShare :: UpdId i => i -> i
nameShare = prefixName 's' '|'
-- Turn a QName into a Name, assuming it will be prefixed.
-- Uses span to make qualified names unique even without qualification.
qName2Name :: QName SrcSpanInfo -> Name SrcSpanInfo
qName2Name (Qual l' _ name) = updateId update name
where
update :: Name l -> Name l
update (Ident l id) = Ident l (showsEncodeSpan l' id)
update (Symbol l id) = Symbol l (showsSymEncodeSpan l' id)
qName2Name (UnQual l name) = name
qName2Name (Special l _) = error "hat-trans: special name in binding position"
-- variable for a trace including span
nameTraceShared :: UpdId i => SrcSpanInfo -> i -> i
nameTraceShared = prefixSpanName 'j' '$'
-- variable for parent
nameParent :: Name SrcSpanInfo
nameParent = Ident noSpan "p"
-- variable for a trace
nameTrace :: UpdId i => i -> i
nameTrace = prefixName 'j' '$'
-- second variable for a trace
nameTrace2 :: UpdId i => i -> i
nameTrace2 = prefixName 'k' '@'
-- name for a local variable for a source reference
nameSR :: UpdId i => i -> i
nameSR = prefixName 'p' '%'
-- intermediate function
nameFunFromSpan :: SrcSpanInfo -> Name SrcSpanInfo
nameFunFromSpan span = Ident span ('h' : showsEncodeSpan span "n")
-- infinite list of var ids made from one id (for function clauses)
nameFuns :: UpdId i => i -> [i]
nameFuns = prefixNames 'y' '>'
-- infinite list of var ids made from one id (for naming arguments)
nameArgs :: UpdId i => i -> [i]
nameArgs = prefixNames 'z' '^'
-- a single id made from a span (different from below)
nameFromSpan :: SrcSpanInfo -> Name SrcSpanInfo
nameFromSpan span = Ident span ('v' : showsEncodeSpan span "n")
-- infinite list of ids made from a span
namesFromSpan :: SrcSpanInfo -> [Name SrcSpanInfo]
namesFromSpan span =
map (Ident span . ('v':) . showsEncodeSpan span . ('v':) . show)
[1..]
-- Generation of new variables
showsEncodeSpan :: SrcSpanInfo -> ShowS
showsEncodeSpan span = shows beginRow . ('v':) . shows beginColumn . ('v':)
. shows endRow . ('v':) . shows endColumn
where
(beginRow,beginColumn,endRow,endColumn) = getSpan span
showsSymEncodeSpan :: SrcSpanInfo -> ShowS
showsSymEncodeSpan span =
\xs -> numToSym (show beginRow) ++ '=' : numToSym (show beginColumn) ++ '='
: numToSym (show endRow) ++ '=' : numToSym (show endColumn) ++ xs
where
(beginRow,beginColumn,endRow,endColumn) = getSpan span
prefixName :: UpdId i => Char -> Char -> i -> i
prefixName c d = updateId update
where
update (Ident l name) = Ident l (c:name)
update (Symbol l name) = Ident l (d:name)
-- really used with that general type?
prefixModName :: UpdId i => Char -> i -> i
prefixModName c = updateId update
where
update (Ident l name) = Ident l (c: map (\c->if c=='.' then '_' else c) name)
prefixSpanName :: UpdId i => Char -> Char -> SrcSpanInfo -> i -> i
prefixSpanName c d span = updateId update
where
update (Ident l name) = Ident l (c : showsEncodeSpan span name)
update (Symbol l name) = Symbol l (d : showsSymEncodeSpan span name)
prefixNames :: UpdId i => Char -> Char -> i -> [i]
prefixNames c d name = map (($ name) . updateId . update) [(1::Int)..]
where
update no (Ident l name) = Ident l (c : show no ++ name)
update no (Symbol l name) = Symbol l (d : numToSym (show no) ++ name)
numToSym :: String -> String
numToSym = map (("!#$%&*+^@>" !!) . digitToInt)
-- ----------------------
-- Hardwired identifiers
expRoot :: Exp SrcSpanInfo
expRoot = expShortIdent "mkRoot"
mkExpSR :: SrcSpanInfo -> Tracing -> Exp SrcSpanInfo
mkExpSR l tracing =
Var noSpan (if isTraced tracing then UnQual l (nameTraceInfoSpan l)
else qNameMkNoSpan l)
mkExpProjection :: Exp SrcSpanInfo -> Exp SrcSpanInfo -> Exp SrcSpanInfo
mkExpProjection sr e =
appN [expProjection, sr, expParent, e]
mkExpApplyArity :: Bool -> -- function is traced
Exp SrcSpanInfo -> -- location of application
Exp SrcSpanInfo -> -- location of applied function
Arity ->
Exp SrcSpanInfo ->
Exp SrcSpanInfo ->
[Exp SrcSpanInfo] ->
Exp SrcSpanInfo
mkExpApplyArity tracedFun srA srF a info fun args =
appN (Var noSpan ((if tracedFun then qNameApp else qNameUApp) noSpan a)
:srA
:srF
:expParent
:info
:fun
:args)
mkExpApply :: Tracing -> Exp SrcSpanInfo -> [Exp SrcSpanInfo] ->
Exp SrcSpanInfo
mkExpApply tracing sr es =
appN (Var noSpan ((if isTraced tracing then qNameAp else qNameUAp) noSpan a)
:sr
:expParent
:es)
where
a = length es - 1 -- function is in list
mkExpPartial :: Exp SrcSpanInfo -> -- location of application
Arity -> Arity ->
QName SrcSpanInfo -> [Exp SrcSpanInfo] ->
Exp SrcSpanInfo
mkExpPartial sr conArity numberOfArgs qName es =
appN (Var noSpan (qNamePa noSpan numberOfArgs)
:Con noSpan (nameTransCon qName)
:Var noSpan (qNameCn noSpan (conArity-numberOfArgs))
:sr
:expParent
:Var noSpan (nameTraceInfoCon qName)
:es)
mkExpCon :: Exp SrcSpanInfo -> -- location of constructor application
Arity ->
QName SrcSpanInfo -> [Exp SrcSpanInfo] ->
Exp SrcSpanInfo
mkExpCon sr arity qName es =
appN (Var noSpan (qNameCon noSpan arity)
:sr
:expParent
:Con noSpan (nameTransCon qName)
:Var noSpan (nameTraceInfoCon qName)
:es)
mkExpConChar :: Exp SrcSpanInfo -> Literal SrcSpanInfo -> Exp SrcSpanInfo
mkExpConChar sr lit =
appN [expConChar, sr, expParent, Lit noSpan lit]
mkExpFromLitString :: Exp SrcSpanInfo -> Literal SrcSpanInfo ->
Exp SrcSpanInfo
mkExpFromLitString sr lit =
appN [expFromLitString, sr, expParent, Lit noSpan lit]
mkExpFromInteger :: Exp SrcSpanInfo ->
Exp SrcSpanInfo
mkExpFromInteger sr =
appN [expFromInteger, sr, expParent]
mkExpConInteger :: Exp SrcSpanInfo ->
Literal SrcSpanInfo ->
Exp SrcSpanInfo
mkExpConInteger sr lit =
appN [expConInteger, sr, expParent, Paren noSpan (Lit noSpan lit)]
mkExpFun :: Tracing -> Exp SrcSpanInfo -> Exp SrcSpanInfo -> Exp SrcSpanInfo ->
Arity ->
Exp SrcSpanInfo
mkExpFun tracing sr funName fun a =
appN [Var noSpan ((if isTraced tracing then qNameFun else qNameUFun) noSpan a)
,funName
,sr
,expParent
,fun]
mkExpIf :: SrcSpanInfo -> Tracing ->
Exp SrcSpanInfo -> Exp SrcSpanInfo -> Exp SrcSpanInfo ->
Exp SrcSpanInfo
mkExpIf l Traced cond e1 e2 =
appN [Var noSpan (qNameIf noSpan),mkExpSR l Traced,expParent,cond,e1,e2]
mkExpIf l Trusted cond e1 e2 =
appN [Var noSpan (qNameUIf noSpan),expParent,cond,e1,e2]
mkExpCase :: SrcSpanInfo -> Tracing -> Exp SrcSpanInfo -> Exp SrcSpanInfo ->
Exp SrcSpanInfo
mkExpCase l tracing caseFun arg =
appN [Var noSpan ((if isTraced tracing then qNameCase else qNameUCase) noSpan)
,mkExpSR l tracing
,expParent
,caseFun
,arg]
mkExpUWrapForward :: Exp SrcSpanInfo -> Exp SrcSpanInfo
mkExpUWrapForward exp =
appN [Var noSpan (qNameUWrapForward noSpan)
,expParent
,exp]
expShortIdent :: String -> Exp SrcSpanInfo
expShortIdent ident = Var noSpan (qNameShortIdent ident noSpan)
-- ----------------------------------------------------------------------------
-- Wrapping of untransformed code
expTo :: Type SrcSpanInfo -> Exp SrcSpanInfo
expTo = expType True
expFrom :: Type SrcSpanInfo -> Exp SrcSpanInfo
expFrom = expType False
-- The following assumes a limited form of types as they
-- occur in foreign import / export declarations.
-- Variables of kind other than * pose a problem.
expType :: Bool -> Type SrcSpanInfo -> Exp SrcSpanInfo
expType to (TyForall l _ _ _) = notSupported l "local type forall"
expType to (TyFun l tyL tyR) =
appN
[Var l (qNameShortIdent (prefix to ++ "Fun") l)
,expType (not to) tyL
,expType to tyR]
expType to (TyTuple l boxed tys) =
appN
(Var l (qNameShortIdent (prefix to ++ "Tuple" ++ show (length tys)) l) :
map (expType to) tys)
expType to (TyList l ty) =
appN [Var l (qNameShortIdent (prefix to ++ "List") l), expType to ty]
expType to (TyApp l tyL tyR) =
App l (expType to tyL) (expType to tyR)
expType to (TyVar l _) =
Var l (qNameShortIdent (prefix to ++ "Id") l)
expType to (TyCon l qName) =
Var l (qNameShortIdent (prefix to ++ getName qName) l)
where
getName :: QName SrcSpanInfo -> String
getName (Special _ specialCon) = specialToId specialCon
getName qName = getId qName
expType to (TyParen l ty) = Paren l (expType to ty)
expType to (TyInfix l tyL qName tyR) = expType to (TyApp l (TyApp l (TyCon l qName) tyL) tyR)
expType to (TyKind l ty kind) = notSupported l "type with kind"
prefix :: Bool -> String
prefix True = "to"
prefix False = "from"
-- ----------------------------------------------------------------------------
-- Useful stuff
-- Frequently used in transformed code:
mkExpTuple :: [Exp SrcSpanInfo] -> Exp SrcSpanInfo
mkExpTuple es = Tuple noSpan Boxed es
mkPatTuple :: [Pat SrcSpanInfo] -> Pat SrcSpanInfo
mkPatTuple ps = PTuple noSpan Boxed ps
mkExpList :: [Exp SrcSpanInfo] -> Exp SrcSpanInfo
mkExpList =
foldr (\x xs -> appN [mkExpCons noSpan,x,xs]) (List noSpan [])
mkFailExp :: Exp l -> Exp l
mkFailExp parent = App l (Var l (qNameFatal l)) parent
where
l = ann parent
expFail :: Exp SrcSpanInfo
expFail = mkFailExp expParent
patParent :: Pat SrcSpanInfo
patParent = PVar noSpan nameParent
expParent :: Exp SrcSpanInfo
expParent = Var noSpan (UnQual noSpan nameParent)
-- Test for specific names
-- Is this the module name "Main"?
isMain :: ModuleName l -> Bool
isMain (ModuleName l name) = name == "Main"
-- This test is an unsafe hack.
-- Even with qualification "Prelude" this may be a different "True"
-- There is no origin-tracking
isTrue :: QName l -> Bool
isTrue (Qual _ (ModuleName _ "Prelude") (Ident _ "True")) = True
isTrue (UnQual _ (Ident _ "True")) = True
isTrue _ = False
isOtherwise :: QName l -> Bool
isOtherwise (Qual _ (ModuleName _ "Prelude") (Ident _ "otherwise")) = True
isOtherwise (UnQual _ (Ident _ "otherwise")) = True
isOtherwise _ = False
-- ----------------------------------------------------------------------------
expMkAtomRational :: Exp SrcSpanInfo
expMkAtomRational = Var noSpan (qNameMkAtomRational noSpan)
expMkAtomLambda :: Exp SrcSpanInfo
expMkAtomLambda = Var noSpan (qNameMkAtomLambda noSpan)
expMkAtomDoLambda :: Exp SrcSpanInfo
expMkAtomDoLambda = Var noSpan (qNameMkAtomDoLambda noSpan)
mkExpConstUse :: Tracing -> Exp SrcSpanInfo
mkExpConstUse tracing =
Var noSpan
(if isTraced tracing then qNameConstUse noSpan else qNameUConstUse noSpan)
mkExpConstDef :: Tracing -> Exp SrcSpanInfo
mkExpConstDef tracing =
Var noSpan
(if isTraced tracing then qNameConstDef noSpan else qNameUConstDef noSpan)
mkExpGuard :: Tracing -> Exp SrcSpanInfo
mkExpGuard tracing =
Var noSpan
(if isTraced tracing then qNameGuard noSpan else qNameUGuard noSpan)
mkExpUpdate :: Tracing -> Arity -> Exp SrcSpanInfo
mkExpUpdate tracing arity =
Var noSpan
(if isTraced tracing then qNameUpdate noSpan arity else qNameUUpdate noSpan)
expProjection :: Exp SrcSpanInfo
expProjection = Var noSpan (qNameProjection noSpan)
expConChar :: Exp SrcSpanInfo
expConChar = Var noSpan (qNameConChar noSpan)
expConInteger :: Exp SrcSpanInfo
expConInteger = Var noSpan (qNameConInteger noSpan)
expFromLitString :: Exp SrcSpanInfo
expFromLitString = Var noSpan (qNameFromLitString noSpan)
expFromExpList :: Exp SrcSpanInfo
expFromExpList = Var noSpan (qNameFromExpList noSpan)
expWrapValFun :: Exp SrcSpanInfo
expWrapValFun = Var noSpan (qNameShortIdent "wrapVal" noSpan)
expTraceIO :: Exp SrcSpanInfo
expTraceIO = Var noSpan (qNameShortIdent "traceIO" noSpan)