module DDC.Type.Transform.Rename
( Rename(..)
, Sub(..)
, BindStack(..)
, pushBind
, pushBinds
, substBound
, bind1, bind1s, bind0, bind0s
, use1, use0)
where
import DDC.Type.Compounds
import DDC.Type.Exp
import Data.List
import Data.Set (Set)
import qualified DDC.Type.Sum as Sum
import qualified Data.Set as Set
class Rename (c :: * -> *) where
renameWith :: Ord n => Sub n -> c n -> c n
instance Rename Type where
renameWith sub tt
=
let down = renameWith
in case tt of
TVar u -> TVar (use1 sub u)
TCon{} -> tt
TForall b t
-> let (sub1, b') = bind1 sub b
t' = down sub1 t
in TForall b' t'
TApp t1 t2 -> TApp (down sub t1) (down sub t2)
TSum ts -> TSum (down sub ts)
instance Rename TypeSum where
renameWith sub ts
= Sum.fromList (Sum.kindOfSum ts)
$ map (renameWith sub)
$ Sum.toList ts
instance Rename Bind where
renameWith sub bb
= replaceTypeOfBind (renameWith sub (typeOfBind bb)) bb
data Sub n
= Sub
{
subBound :: !(Bound n)
, subShadow0 :: !Bool
, subConflict1 :: !(Set n)
, subConflict0 :: !(Set n)
, subStack1 :: !(BindStack n)
, subStack0 :: !(BindStack n) }
data BindStack n
= BindStack
{
stackBinds :: ![Bind n]
, stackAll :: ![Bind n]
, stackAnons :: !Int
, stackNamed :: !Int }
pushBinds :: Ord n => Set n -> BindStack n -> [Bind n] -> (BindStack n, [Bind n])
pushBinds fns stack bs
= mapAccumL (pushBind fns) stack bs
pushBind
:: Ord n
=> Set n
-> BindStack n
-> Bind n
-> (BindStack n, Bind n)
pushBind fns bs@(BindStack stack env dAnon dName) bb
= case bb of
BAnon t
-> ( BindStack (BAnon t : stack) (BAnon t : env) (dAnon + 1) dName
, BAnon t)
BName n t
| Set.member n fns
-> ( BindStack (BName n t : stack) (BAnon t : env) dAnon (dName + 1)
, BAnon t)
| otherwise
-> ( BindStack stack (BName n t : env) dAnon dName
, bb)
_ -> (bs, bb)
substBound
:: Ord n
=> BindStack n
-> Bound n
-> Bound n
-> Either
(Bound n)
Int
substBound (BindStack binds _ dAnon dName) u u'
| UName n1 <- u
, UName n2 <- u'
, n1 == n2
= Right (dAnon + dName)
| UIx i1 <- u
, UIx i2 <- u'
, i1 + dAnon == i2
= Right (dAnon + dName)
| UName _ <- u'
, Just ix <- findIndex (boundMatchesBind u') binds
= Left $ UIx ix
| UIx i2 <- u'
, i2 > dAnon
, cutOffset <- case u of
UIx{} -> 1
_ -> 0
= Left $ UIx (i2 + dName cutOffset)
| otherwise
= Left u'
bind1 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n)
bind1 sub b
= let (stackT', b') = pushBind (subConflict1 sub) (subStack1 sub) b
in (sub { subStack1 = stackT' }, b')
bind1s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n])
bind1s = mapAccumL bind1
bind0 :: Ord n => Sub n -> Bind n -> (Sub n, Bind n)
bind0 sub b
= let b1 = renameWith sub b
(stackX', b2) = pushBind (subConflict0 sub) (subStack0 sub) b1
in ( sub { subStack0 = stackX'
, subShadow0 = subShadow0 sub
|| namedBoundMatchesBind (subBound sub) b2 }
, b2)
bind0s :: Ord n => Sub n -> [Bind n] -> (Sub n, [Bind n])
bind0s = mapAccumL bind0
use1 :: Ord n => Sub n -> Bound n -> Bound n
use1 sub u
| UName _ <- u
, BindStack binds _ _ _ <- subStack1 sub
, Just ix <- findIndex (boundMatchesBind u) binds
= UIx ix
| otherwise
= u
use0 :: Ord n => Sub n -> Bound n -> Bound n
use0 sub u
| UName _ <- u
, BindStack binds _ _ _ <- subStack0 sub
, Just ix <- findIndex (boundMatchesBind u) binds
= UIx ix
| otherwise
= u