module DDC.Core.Flow.Transform.Annotate
        (Annotate (..))
where
import qualified DDC.Core.Exp.Annot             as A
import qualified DDC.Core.Flow.Exp.Simple.Exp   as S


-- | Convert the `Simple` version of the AST to the `Annot` version,
--   using a the provided default annotation value.
class Annotate  
        (c1 :: * -> * -> *) 
        (c2 :: * -> * -> *) | c1 -> c2 
 where
 annotate :: a -> c1 a n -> c2 a n


instance Annotate S.Exp A.Exp where
 annotate def xx
  = let down     = annotate def
    in case xx of
        S.XAnnot _ (S.XAnnot a x)       -> down (S.XAnnot a x)
        S.XAnnot a (S.XVar   u)         -> A.XVar      a u
        S.XAnnot a (S.XCon   dc)        -> A.XCon      a dc
        S.XAnnot a (S.XLAM   b x)       -> A.XLAM      a b   (down x)
        S.XAnnot a (S.XLam   b x)       -> A.XLam      a b   (down x)
        S.XAnnot a (S.XApp   x1 x2)     -> A.XApp      a     (down x1)  (down x2)
        S.XAnnot a (S.XLet   lts x)     -> A.XLet      a     (down lts) (down x)
        S.XAnnot a (S.XCase  x alts)    -> A.XCase     a     (down x)   (map down alts)
        S.XAnnot a (S.XCast  c x)       -> A.XCast     a     (down c)   (down x)
        S.XAnnot a (S.XType    t)       -> A.XType     a t
        S.XAnnot a (S.XWitness w)       -> A.XWitness  a (down w)

        S.XVar  u                       -> A.XVar      def u
        S.XCon  dc                      -> A.XCon      def dc
        S.XLAM  b x                     -> A.XLAM      def b (down x)
        S.XLam  b x                     -> A.XLam      def b (down x)
        S.XApp  x1 x2                   -> A.XApp      def   (down x1)  (down x2)
        S.XLet  lts x                   -> A.XLet      def   (down lts) (down x)
        S.XCase x alts                  -> A.XCase     def   (down x)   (map down alts)
        S.XCast c x                     -> A.XCast     def   (down c)   (down x)
        S.XType t                       -> A.XType     def t
        S.XWitness w                    -> A.XWitness  def (down w)


instance Annotate S.Cast A.Cast where
 annotate def cc
  = let down    = annotate def
    in case cc of
        S.CastWeakenEffect eff          -> A.CastWeakenEffect  eff
        S.CastPurify w                  -> A.CastPurify        (down w)
        S.CastBox                       -> A.CastBox
        S.CastRun                       -> A.CastRun


instance Annotate S.Lets A.Lets where
 annotate def lts
  = let down    = annotate def
    in case lts of
        S.LLet b x                      -> A.LLet b (down x)
        S.LRec bxs                      -> A.LRec [(b, down x) | (b, x) <- bxs]
        S.LPrivate bks mT bts           -> A.LPrivate bks mT bts


instance Annotate S.Alt A.Alt where
 annotate def alt
  = let down    = annotate def
    in case alt of
        S.AAlt S.PDefault x             -> A.AAlt  A.PDefault (down x)
        S.AAlt (S.PData dc bs) x        -> A.AAlt (A.PData dc bs) (down x)


instance Annotate S.Witness A.Witness where
 annotate def wit
  = let down    = annotate def
    in case wit of
        S.WAnnot _ (S.WAnnot a x)       -> down (S.WAnnot a x)
        S.WAnnot a (S.WVar  u)          -> A.WVar  a u
        S.WAnnot a (S.WCon  wc)         -> A.WCon  a wc
        S.WAnnot a (S.WApp  w1 w2)      -> A.WApp  a (down w1) (down w2)
        S.WAnnot a (S.WType t)          -> A.WType a t

        S.WVar  u                       -> A.WVar  def u
        S.WCon  dc                      -> A.WCon  def dc        
        S.WApp  x1 x2                   -> A.WApp  def (down x1) (down x2)
        S.WType t                       -> A.WType def t