ES: transformations as-pat

Author: Anabra

grin/src/Transformations/ExtendedSyntax/Names.hs

@@ -126,7 +126,7 @@ mapNameDefExpM :: Monad m => (Name -> m Name) -> Exp -> m Exp
 mapNameDefExpM f = \case
   Def name args body          -> Def <$> f name <*> mapM f args <*> pure body
   EBind leftExp (VarPat var) rightExp -> do EBind leftExp <$> (VarPat <$> f var) <*> pure rightExp
-  EBind leftExp (AsPat var val) rightExp -> EBind leftExp <$> (AsPat <$> f var <*> mapNamesValM f val) <*> pure rightExp
+  EBind leftExp (AsPat tag args var) rightExp -> EBind leftExp <$> (AsPat tag <$> mapM f args <*> f var) <*> pure rightExp
   Alt cpat n body             -> Alt <$> mapNamesCPatM f cpat <*> f n <*> pure body
   exp                         -> pure exp
 

grin/src/Transformations/ExtendedSyntax/Optimising/CopyPropagation.hs

@@ -66,10 +66,9 @@ copyPropagation = flip evalState mempty . hyloM rmBlocks builder where
            pure $ project $ EBind (SReturn valWithOrigVars) bpat rightExp
 
       -- left unit law + eliminate redundant rebinds
-      EBind (SReturn (Var valVar)) (AsPat patVar asPat) rightExp
+      EBind (SReturn (Var valVar)) (AsPat patTag patArgs patVar) rightExp
         | origVar <- getAlias valVar aliases
         , origVal <- getOrigVal origVar origVals
-        , ConstTagNode patTag patArgs <- asPat
         , ConstTagNode valTag valArgs <- origVal
         , patTag == valTag -> do
           let aliases' = aliases <> (Map.fromList $ zip (patVar:patArgs) (origVar:valArgs))
@@ -79,10 +78,9 @@ copyPropagation = flip evalState mempty . hyloM rmBlocks builder where
 
       -- add the lhs value as an original value
       -- and eliminate redudant rebinds
-      EBind (SReturn val) (AsPat patVar asPat) rightExp
+      EBind (SReturn val) (AsPat patTag patArgs patVar) rightExp
         | isn't _Lit val
         , valWithOrigVars <- substNamesVal aliases val
-        , ConstTagNode patTag patArgs <- asPat
         , ConstTagNode valTag valArgs <- valWithOrigVars
         , patTag == valTag -> do
           let origVals' = Map.insert patVar valWithOrigVars origVals
@@ -91,10 +89,10 @@ copyPropagation = flip evalState mempty . hyloM rmBlocks builder where
           put newEnv
           pure $ project $ EBind (SReturn val) (VarPat patVar) rightExp
 
-      -- simplify as-pattern matching against the same basic value it binds
-      EBind (SReturn retVal) (AsPat var patVal) rightExp
-        | isBasicValue retVal
-        , retVal == patVal -> do
+      -- simplify as-pattern matching against the same node value it binds
+      EBind (SReturn retVal@(ConstTagNode retTag retArgs)) (AsPat patTag patArgs var) rightExp
+        | retTag  == patTag
+        , retArgs == patArgs -> do
           pure $ project $ EBind (SReturn retVal) (VarPat var) rightExp
 
       _ -> pure $ project exp'

grin/src/Transformations/ExtendedSyntax/Util.hs

@@ -72,8 +72,8 @@ mapNamesVal f = \case
 
 mapNamesBPat :: (Name -> Name) -> BPat -> BPat
 mapNamesBPat f = \case
-  VarPat v      -> VarPat (f v)
-  AsPat var val -> AsPat (f var) (mapNamesVal f val)
+  VarPat v         -> VarPat (f v)
+  AsPat tag vars v -> AsPat tag (map f vars) (f v)
 
 -- TODO: replace at use sites with
 -- mapValVal :: (Val -> Val) -> Val -> Val
@@ -130,7 +130,8 @@ cPatToVal = \case
   DefaultPat        -> Unit
 
 cPatToAsPat :: Name -> CPat -> BPat
-cPatToAsPat name cPat = AsPat name (cPatToVal cPat)
+cPatToAsPat name (NodePat tag args) = AsPat tag args name
+cPatToAsPat _ cPat = error $ "cPatToAsPat: cannot convert to as-pattern: " ++ show (PP cPat)
 
 -- monadic recursion schemes
 --  see: https://jtobin.io/monadic-recursion-schemes