timberc-1.0.3: src/Rename.hs
{-# LANGUAGE FlexibleInstances #-}
-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008-2009 Johan Nordlander <nordland@csee.ltu.se>
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
--
-- 1. Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- 2. Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
--
-- 3. Neither the names of the copyright holder and any identified
-- contributors, nor the names of their affiliations, may be used to
-- endorse or promote products derived from this software without
-- specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
module Rename where
{-
This module does the following:
- Checks all binding groups and patterns for duplicates (both types & terms).
- Checks all signatures for duplicates and dangling references (kind and type sigs).
- Completes all type signatures and constructor definitions with explicit type variable bindings.
- Shuffles explicit signatures as close as possible to their binding occurrences (even inside patterns)
- Checks that variables bound in generators and equations in commands do not shadow state variables.
- Checks that assignments are to declared state variables only.
- Resolves proper binding occurrences for all identifier references by setting the unique tag in each Name
identifier, or possibly replacing a Name with a Prim.
-}
import Monad
import Common
import Syntax
import Depend
import PP
import List(sort)
renameM e1 m = rename (initEnv e1) m
-- Syntax traversal environment --------------------------------------------------
data Env = Env { rE :: Map Name Name,
rT :: Map Name Name,
rS :: Map Name Name,
rL :: Map Name Name,
self :: [Name],
void :: [Name]
} deriving Show
initEnv (rL',rT',rE') = Env { rE = primTerms ++ rE', rT = primTypes ++ rT', rS = [], rL = primSels ++ rL', self = [], void = [] }
stateVars env = dom (rS env)
tscope env = dom (rT env)
renE env n@(Tuple _ _) = n
renE env n@(Prim _ _) = n
renE env v = case lookup v (rE env) of
Just n -> n { annot = (annot v) {suppressMod = suppressMod (annot n)} }
Nothing -> errorIds "Undefined identifier" [v]
renS env n@(Tuple _ _) = n
renS env n@(Prim _ _) = n
renS env v = case lookup v (rS env) of
Just n -> n { annot = a { stateVar = True} }
Nothing -> errorIds "Undefined state variable" [v]
where a = annot v
renL env v = case lookup v (rL env) of
Just n -> n { annot = (annot v){suppressMod = suppressMod (annot n)} }
Nothing -> errorIds "Undefined selector" [v]
renT env n@(Tuple _ _) = n
renT env n@(Prim _ _) = n
renT env v = case lookup v (rT env) of
Just n -> n { annot = (annot v) {suppressMod = suppressMod (annot n)} }
Nothing -> errorIds "Undefined type identifier" [v]
extRenE env vs
| not (null shadowed) = errorIds "Illegal shadowing of state variables" shadowed
| not (null shadowed') = errorIds "Illegal shadowing of state reference" shadowed'
| otherwise = do rE' <- renaming (noDups "Duplicate variables" (legalBind vs))
return (env { rE = rE' ++ rE env })
where shadowed = intersect vs (stateVars env)
shadowed' = intersect vs (self env)
setRenS env vs
| not (null shadowed) = errorIds "Illegal shadowing of state reference" shadowed
| otherwise = do rS' <- renaming (noDups "Duplicate state variables" (legalBind vs))
return (env { rS = rS', void = vs })
where shadowed = intersect vs (self env)
unvoid vs env = env { void = void env \\ vs }
unvoidAll env = env { void = [] }
extRenT env vs = do rT' <- renaming (noDups "Duplicate type variables" (legalBind vs))
return (env { rT = rT' ++ rT env })
extRenEMod _ _ env [] = return env
extRenEMod pub m env vs = do rE' <- extRenXMod pub m (rE env) vs
return (env {rE = rE'})
extRenTMod _ _ env [] = return env
extRenTMod pub m env vs = do rT' <- extRenXMod pub m (rT env) vs
return (env {rT = rT'})
extRenLMod _ _ env [] = return env
extRenLMod pub m env vs = do rL' <- extRenXMod pub m (rL env) vs
return (env {rL = rL'})
extRenSelf env s = do rE' <- renaming (legalBind [s])
return (env { rE = rE' ++ rE env, self = [s] })
extRenXMod pub m rX vs = if pub
then do rX1 <- renaming (map (qName (str m)) (legalBind vs))
let rX2 = map suppressPair rX1
return (mergeRenamings1 (map dropModFst rX2) rX ++ rX2)
else do rX' <- renaming (legalBind vs)
return (mergeRenamings1 rX' rX)
where suppressPair (n1,n2) = (n1, n2 {annot = (annot n2) {suppressMod = True}})
dropModFst (n1,n2) = (dropMod n1,n2)
legalBind vs = map checkName vs
where checkName v@(Tuple _ _) = errorIds "Tuple constructors may not be redefined" [v]
checkName v@(Prim _ _) = errorIds "Rigid symbol may not be redefined" [v]
checkName v
| fromMod v == Nothing = v
| otherwise = errorIds "Binding occurrence may not be qualified" [v]
-- Binding of overloaded names ------------------------------------------------------------------------
oloadBinds xs ds = f te
where te = [ (s,t') | DRec True c vs _ sels <- ds, let p = PType (foldl TAp (TCon c) (map TVar vs)),
Sig ss t <- sels, s <- ss, s `notElem` xs, let t' = tQual [p] t ]
f [] = []
f (sig:te) = mkSig sig : mkEqn sig : f te
mkSig (s,t) = BSig [s] t
mkEqn (s,TQual t ps) = BEqn (LFun s' (w:ws)) (RExp (foldl EAp (ESelect w s') ws))
where w:ws = map EVar (take (length ps) abcSupply)
s' = annotExplicit s
-- Renaming -----------------------------------------------------------------------------------------
class Rename a where
rename :: Env -> a -> M s a
instance Rename a => Rename [a] where
rename env as = mapM (rename env) as
instance Rename a => Rename (Maybe a) where
rename env (Just e) = liftM Just (rename env e)
rename env Nothing = return Nothing
instance Rename Module where
rename env (Module c is ds ps) = do assert (null kDups) "Duplicate kind signatures" kDups
assert (null tDups) "Duplicate type constructors" tDups
assert (null sDups) "Duplicate selectors" sDups
assert (null cDups) "Duplicate constructors" cDups
assert (null wDups) "Duplicate instance declarations" wDups
assert (null eDups) "Duplicate top-level variable" eDups
assert (null tcDups) "Duplicate typeclass declaration" tcDups
assert (null dks) "Dangling kind signatures" dks
assert (null dws1) "Dangling instance declarations" dws1
assert (null dws2) "Dangling instance declarations" dws2
assert (null dtcs1) "Dangling typeclass declarations" dtcs1
assert (null dtcs2) "Dangling typeclass declarations" dtcs2
assert (null badImpl) "Illegal type signature for instance" badImpl
env1 <- extRenTMod True c env (ts1 ++ ks1')
env2 <- extRenEMod True c env1 (cs1 ++ vs1 ++ vs1' ++ vss++is1)
env3 <- extRenLMod True c env2 ss1
env4 <- extRenTMod False c env3 ((ts2 \\ ks1') ++ ks2)
env5 <- extRenEMod False c env4 (cs2 ++ (vs2 \\ vss) ++ vs2'++is2)
env6 <- extRenLMod False c env5 ss2
ds <- rename env6 (ds1 ++ ps1)
bs <- rename env6 (bs1' ++ bs2' ++ shuffleB (bs1 ++ bs2))
return (Module c is (ds ++ map DBind (groupBindsS bs)) [])
where (ks1,ts1,ss1,cs1,ws1,tcs1,is1,bss1) = renameD [] [] [] [] [] [] [] [] ds
(ks2,ts2,ss2,cs2,ws2,tcs2,is2,bss2) = renameD [] [] [] [] [] [] [] [] ps
ds1 = mergeTClasses tcs1 ds
ps1 = mergeTClasses tcs2 ps
vs1 = concat (map bvars bss1)
vs2 = concat (map bvars bss2)
bs1 = concat (reverse bss1)
bs2 = concat (reverse bss2)
vss = concat [ ss | BSig ss _ <- bs1 ] \\ vs1
vs = vs1 ++ vs2
ks = ks1 ++ ks2
ts = ts1 ++ ts2
ws = ws1 ++ ws2
bs1' = oloadBinds vs ds1
bs2' = oloadBinds vs ps1
vs1' = bvars bs1'
vs2' = bvars bs2'
ks1' = ks1 \\ ts1
dks = ks \\ ts
dws1 = ws1 \\ concat [ ss | BSig ss _ <- bs1 ]
dws2 = ws2 \\ concat [ ss | BSig ss _ <- bs2 ]
dtcs1 = tcs1 \\ [ n | DRec False n _ _ _ <- ds ]
dtcs2 = tcs2 \\ [ n | DRec False n _ _ _ <- ps ]
badImpl = concat [ ws | BSig ss t <- bs1++bs2, not (null (ss `intersect` ws)), isWild t ]
kDups = duplicates ks
tDups = duplicates ts
sDups = duplicates (ss1 ++ ss2)
cDups = duplicates (cs1 ++ cs2)
wDups = duplicates ws
eDups = duplicates vs
tcDups = duplicates (tcs1++tcs2)
isWild (TQual t ps) = isWild t || any isWild [ t | PType t <- ps ]
isWild (TAp t t') = isWild t || isWild t'
isWild (TSub t t') = isWild t || isWild t'
isWild (TList t) = isWild t
isWild (TTup ts) = any isWild ts
isWild (TFun ts t) = any isWild (t:ts)
isWild TWild = True
isWild _ = False
mergeTClasses tcs (DRec isC n vs ts ss : ds) = DRec (isC || elem n tcs) n vs ts ss : mergeTClasses tcs ds
mergeTClasses tcs (DTClass _ : ds) = mergeTClasses tcs ds
mergeTClasses tcs (DBind _ : ds) = mergeTClasses tcs ds
mergeTClasses tcs (d : ds) = d : mergeTClasses tcs ds
mergeTClasses _ [] = []
renameD ks ts ss cs ws tcs is bss (DKSig c k : ds)
= renameD (c:ks) ts ss cs ws tcs is bss ds
renameD ks ts ss cs ws tcs is bss (DRec _ c _ _ sigs : ds)
= renameD ks (c:ts) (sels++ss) cs ws tcs is bss ds
where sels = concat [ vs | Sig vs t <- sigs ]
renameD ks ts ss cs ws tcs is bss (DData c _ _ cdefs : ds)
= renameD ks (c:ts) ss (cons++cs) ws tcs is bss ds
where cons = [ c | Constr c _ _ <- cdefs ]
renameD ks ts ss cs ws tcs is bss (DType c _ _ : ds)
= renameD ks (c:ts) ss cs ws tcs is bss ds
renameD ks ts ss cs ws tcs is bss (DInstance vs : ds)
= renameD ks ts ss cs (ws++vs) tcs is bss ds
renameD ks ts ss cs ws tcs is bss (DTClass vs : ds)
= renameD ks ts ss cs ws (tcs++vs) is bss ds
renameD ks ts ss cs ws tcs is bss (DDefault ps : ds)
= renameD ks ts ss cs ws tcs (is1 ++ is) bss ds
where is1 = [i | Derive i _ <- ps]
renameD ks ts ss cs ws tcs is bss (DBind bs : ds)
= renameD ks ts ss cs ws tcs is (bs : bss) ds
renameD ks ts ss cs ws tcs is bss []
= (ks, ts, ss, cs, ws, tcs, is, bss)
instance Rename Decl where
rename env d@(DKSig _ _) = return d
rename env (DData c vs ts cs) = do env' <- extRenT env vs
liftM2 (DData (renT env c) (map (renT env') vs)) (renameQTs env' ts) (rename env' cs)
rename env (DRec isC c vs ts ss) = do env' <- extRenT env vs
liftM2 (DRec isC (renT env c) (map (renT env') vs)) (renameQTs env' ts) (rename env' ss)
rename env (DType c vs t) = do env' <- extRenT env vs
liftM (DType (renT env c) (map (renT env') vs)) (rename env' t)
rename env (DInstance vs) = return (DInstance (map (renE env) vs))
rename env (DDefault ts) = liftM DDefault (rename env ts)
rename env (DBind bs) = liftM DBind (rename env bs)
instance Rename (Default Type) where
rename env (Default pub a b) = return (Default pub (renE env a) (renE env b))
rename env (Derive v t) = liftM (Derive (renE env v)) (renameQT env t)
instance Rename Constr where
rename env (Constr c ts ps) = do env' <- extRenT env (bvars ps')
liftM2 (Constr (renE env c)) (rename env' ts) (rename env' ps')
where ps' = completeP env ts ps
completeP env t ps
| not (null dups) = errorIds "Duplicate type variable abstractions" dups
| not (null dang) = errorIds "Dangling type variable abstractions" dang
| otherwise = ps ++ zipWith PKind implicit (repeat KWild)
where vs = tyvars t ++ tyvars ps
bvs = bvars ps
dups = duplicates bvs
dang = bvs \\ vs
implicit = nub vs \\ (tscope env ++ bvs)
renameQT env (TQual t ps) = rename env (TQual t (completeP env t ps))
renameQT env t
| null ps = rename env t
| otherwise = rename env (TQual t ps)
where ps = completeP env t []
renameQTs env ts = mapM (renameQT env) ts
instance Rename Sig where
rename env (Sig vs t) = liftM (Sig (map (renL env) vs)) (renameQT env t)
instance Rename Pred where
rename env (PType p) = liftM PType (rename env p)
rename env (PKind v k) = return (PKind (renT env v) k)
instance Rename Type where
rename env (TQual t ps) = do env' <- extRenT env (bvars ps)
liftM2 TQual (rename env' t) (rename env' ps)
rename env (TCon c) = return (TCon (renT env c))
rename env (TVar v) = return (TVar (renT env v))
rename env (TAp t1 t2) = liftM2 TAp (rename env t1) (rename env t2)
rename env (TSub t1 t2) = liftM2 TSub (rename env t1) (rename env t2)
rename env TWild = return TWild
rename env (TList ts) = liftM TList (rename env ts)
rename env (TTup ts) = liftM TTup (rename env ts)
rename env (TFun t1 t2) = liftM2 TFun (rename env t1) (rename env t2)
instance Rename Bind where
rename env (BEqn (LFun v ps) rh) = do env' <- extRenE env (pvars ps)
ps' <- rename env' ps
liftM (BEqn (LFun (renE env v) ps')) (rename env' rh)
rename env (BEqn (LPat p) rh) = do p' <- rename env p
liftM (BEqn (LPat p')) (rename env rh)
rename env (BSig vs t) = liftM (BSig (map (renE env) vs)) (renameQT env t)
instance Rename Exp where
rename env (EVar v)
| v `elem` void env = errorIds"Uninitialized state variable" [v]
| v `elem` stateVars env = return (EVar (renS env v))
| otherwise = return (EVar (renE env v))
rename env (ECon c) = return (ECon (renE env c))
rename env (ESel l) = return (ESel (renL env l))
rename env (EAp e1 e2) = liftM2 EAp (rename env e1) (rename env e2)
rename env (ELit l) = return (ELit l)
rename env (ETup ps) = liftM ETup (rename env ps)
rename env (EList es) = liftM EList (rename env es)
rename env EWild = return EWild
rename env (ESig e t) = liftM2 ESig (rename env e) (renameQT env t)
rename env (ERec m fs) = liftM (ERec (renRec env m)) (rename env fs)
rename env (ELam ps e) = do env' <- extRenE env (pvars ps)
liftM2 ELam (rename env' ps) (rename env' e)
rename env (ELet bs e) = do env' <- extRenE env (bvars bs)
bs' <- rename env' (shuffleB bs)
e' <- rename env' e
return (foldr ELet e' (groupBindsS bs'))
rename env (ECase e as) = liftM2 ECase (rename env e) (rename env as)
rename env (EIf e1 e2 e3) = liftM3 EIf (rename env e1) (rename env e2) (rename env e3)
rename env (ENeg e) = liftM ENeg (rename env e)
rename env (ESeq e1 e2 e3) = liftM3 ESeq (rename env e1) (rename env e2) (rename env e3)
rename env (EComp e qs) = do (qs,e) <- renameQ env qs e
return (EComp e qs)
rename env (ESectR e op) = liftM (flip ESectR (renE env op)) (rename env e)
rename env (ESectL op e) = liftM (ESectL (renE env op)) (rename env e)
rename env (ESelect e l) = liftM (flip ESelect (renL env l)) (rename env e)
rename env (EAct v ss) = liftM (EAct (fmap (renE env) v)) (renameS (unvoidAll env) (shuffleS ss))
rename env (EReq v ss) = liftM (EReq (fmap (renE env) v)) (renameS (unvoidAll env) (shuffleS ss))
rename env (EDo (Just v) Nothing ss)
= do env1 <- extRenSelf env v
liftM (EDo (Just (renE env1 v)) Nothing) (renameS (unvoidAll env1) (shuffleS ss))
rename env (ETempl (Just v) Nothing ss)
= do env1 <- extRenSelf env v
env2 <- setRenS env1 st
liftM (ETempl (Just (renE env2 v)) Nothing) (renameS env2 (shuffleS ss))
where st = assignedVars ss
rename env (EAfter e1 e2) = liftM2 EAfter (rename env e1) (rename env e2)
rename env (EBefore e1 e2) = liftM2 EBefore (rename env e1) (rename env e2)
rename env e@(EBStruct (Just c) ls bs)
= do let ls' = map (dropMod . annotGenerated) ls
env' <- extRenE env ls'
r <- rename env' (ERec (Just (c,True)) (map (\(s,s') -> Field s (EVar s')) (ls `zip` ls')))
bs' <- mapM (renSBind env' env) bs
return (foldr ELet r (groupBindsS bs'))
renRec env (Just (n, t)) = Just (renT env n, t)
renRec env Nothing = Nothing
renSBind envL envR (BEqn (LFun v ps) rh) = do envR' <- extRenE envR (pvars ps)
ps' <- rename envR' ps
liftM (BEqn (LFun (annotGenerated (renE envL v)) ps')) (rename envR' rh)
--renSBind envL envR (BEqn (LPat (EVar v)) rh)= liftM (BEqn (LPat (EVar (annotGenerated (renE envL v))))) (rename envR rh)
renSBind envL envR (BEqn (LPat p) rh) = do p' <- rename envL p
rh' <- rename envR rh
return (BEqn (LPat p') rh')
renSBind _ _ s@(BSig vs t) = errorTree "Signature in struct value" s
instance Rename Field where
rename env (Field l e) = liftM (Field (renL env l)) (rename env e)
instance Rename (Rhs Exp) where
rename env (RExp e) = liftM RExp (rename env e)
rename env (RGrd gs) = liftM RGrd (rename env gs)
rename env (RWhere e bs) = do env' <- extRenE env (bvars bs)
bs' <- rename env' (shuffleB bs)
e' <- rename env' e
return (foldr (flip RWhere) e' (groupBindsS bs'))
instance Rename (GExp Exp) where
rename env (GExp qs e) = do (qs,e) <- renameQ env qs e
return (GExp qs e)
renameQ env [] e0 = do e0 <- rename env e0
return ([], e0)
renameQ env (QExp e : qs) e0 = do e <- rename env e
(qs,e0) <- renameQ env qs e0
return (QExp e : qs, e0)
renameQ env (QGen p e : qs) e0 = do e <- rename env e
env' <- extRenE env (pvars p)
p <- rename env' p
(qs,e0) <- renameQ env' qs e0
return (QGen p e : qs, e0)
renameQ env (QLet bs : qs) e0 = do env' <- extRenE env (bvars bs)
bs <- rename env' bs
(qs,e0) <- renameQ env' qs e0
return (map QLet (groupBindsS bs) ++ qs, e0)
instance Rename (Alt Exp) where
rename env (Alt p rh) = do env' <- extRenE env (pvars p)
liftM2 Alt (rename env' p) (rename env' rh)
renameS env [] = return []
renameS env [SRet e] = liftM (:[]) (liftM SRet (rename env e))
renameS env (SExp e : ss) = liftM2 (:) (liftM SExp (rename env e)) (renameS env ss)
renameS env (SGen p e : ss) = do env' <- extRenE env (pvars p)
liftM2 (:) (liftM2 SGen (rename env' p) (rename env e)) (renameS env' ss)
renameS env (SBind bs : ss) = do env' <- extRenE env (bvars bs)
bs' <- rename env' bs
ss' <- renameS env' ss
return (map SBind (groupBindsS bs') ++ ss')
renameS env (SAss p e : ss)
| not (null illegal) = errorIds "Unknown state variables" illegal
| otherwise = liftM2 (:) (liftM2 SAss (rename (unvoidAll env) p) (rename env e)) (renameS (unvoid (pvars p) env) ss)
where illegal = pvars p \\ stateVars env
-- Signature shuffling -------------------------------------------------------------------------
shuffleB bs = shuffle [] bs
shuffle [] [] = []
shuffle sigs [] = errorIds "Dangling type signatures" (dom sigs)
shuffle sigs (BSig vs t : bs)
| not (null s_dups) = errorIds "Duplicate type signatures" s_dups
| otherwise = shuffle (vs `zip` repeat t ++ sigs) bs
where s_dups = duplicates vs ++ (vs `intersect` dom sigs)
shuffle sigs (b@(BEqn (LFun v _) _) : bs)
= case lookup v sigs of
Just t -> BSig [v] t : b : shuffle (prune sigs [v]) bs
Nothing -> b : shuffle sigs bs
shuffle sigs (BEqn (LPat p) rh : bs)
= BEqn (LPat p') rh : shuffle sigs' bs
where (sigs',p') = attach sigs p
shuffleS ss = shuffle' [] ss
shuffle' [] [] = []
shuffle' sigs [] = errorIds "Dangling type signatures for" (dom sigs)
shuffle' sigs (SBind bs : ss) = SBind (shuffle sigs1 bs1) : shuffle' ([ (v,t) | BSig [v] t <- bs2 ] ++ sigs2) ss
where (sigs1,sigs2) = partition ((`elem` vs) . fst) sigs
(bs1,bs2) = partition local (concatMap flat bs)
vs = bvars bs
local (BSig [v] _) = v `elem` vs
local _ = True
flat (BSig vs t) = [ BSig [v] t | v <- vs ]
flat b = [b]
shuffle' sigs (SGen p e : ss) = SGen p' e : shuffle' sigs' ss
where (sigs',p') = attach sigs p
shuffle' sigs (SAss p e : ss) = SAss p' e : shuffle' sigs2 ss
where (sigs',p') = attach sigs1 p
(sigs1,sigs2) = partition ((`elem` vs) . fst) sigs
vs = evars p
shuffle' sigs (s : ss) = s : shuffle' sigs ss
attach sigs e@(ESig (EVar v) t)
| v `elem` dom sigs = errorIds "Conflicting signatures for" [v]
| otherwise = (sigs, e)
attach sigs (EVar v) = case lookup v sigs of
Nothing -> (sigs, EVar v)
Just t -> (prune sigs [v], ESig (EVar v) t)
attach sigs (EAp p1 p2) = (sigs2, EAp p1' p2')
where (sigs1,p1') = attach sigs p1
(sigs2,p2') = attach sigs1 p2
attach sigs (ETup ps) = (sigs', ETup ps')
where (sigs',ps') = attachList sigs ps
attach sigs (EList ps) = (sigs', EList ps')
where (sigs',ps') = attachList sigs ps
attach sigs p = (sigs, p)
attachList sigs [] = (sigs, [])
attachList sigs (p:ps) = (sigs2, p':ps')
where (sigs1,p') = attach sigs p
(sigs2,ps') = attachList sigs1 ps