Separate the function that deals with moving under binders

Tool/Variable/Common.hs

 {-# OPTIONS_GHC -Wall #-}
 
-module Variable.Common (getEnvType, getEnvFunctions, freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs) where
+module Variable.Common (getEnvType, getEnvFunctions, freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs, inhCtxsForSortName) where
 
 import Data.List
 import Data.Maybe
@@ -12,7 +12,7 @@ import Utility
 data ExternalFunctions = EF {
   paramForCtor :: ConstructorDef -> [Parameter],
   freeVarExprForVarCtor :: String -> Expression,
-  transformForAddAttr :: String -> [Expression] -> Expression,
+  applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression,
   includeBinders :: Bool
 }
 
@@ -123,7 +123,7 @@ freeVarFunctions (_, sd, _, _) ef =
             idensAndAttrs = attrsByIden ctor
             callList = concatMap (
               \(iden, iattrs) ->
-                let addedBinders = applyInhCtxsToAttrs ef sname ctor (iden, iattrs) ctxsBySname
+                let addedBinders = (applyInhCtxsToAttrs ef) sname ctor (iden, iattrs) ctxsBySname
                     sortNameOfIden = sortNameForIden iden ctor
                 in
                   if fromJust (lookup sortNameOfIden varAccessBySname)
@@ -199,7 +199,7 @@ mappingFunctions (_, sd, _, _) ef =
                   else FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders ++ [VarExpr iden])
               else VarExpr iden
           where
-            addedBinders = [applyInhCtxsToAttrs ef sortName ctor (iden, idenAttrs) ctxsBySname]
+            addedBinders = [(applyInhCtxsToAttrs ef) sortName ctor (iden, idenAttrs) ctxsBySname]
             sortNameOfIden = sortNameForIden iden ctor
 
             -- | Return a function reference for the processing functions
@@ -219,47 +219,3 @@ inhCtxsForSortName sname ctxsForSortName = [INH x y | INH x y <- ctxs]
 -- | In a list of tuples, converts the first elements to a list of variable parameters
 firstToVarParams :: [(String, String)] -> [Parameter]
 firstToVarParams = map (VarParam . fst)
-
--- | For every inherited context of a sort, apply nested modifiers to the
--- returned "c" variable
-applyInhCtxsToAttrs :: ExternalFunctions -> SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression
-applyInhCtxsToAttrs ef sname ctor (iden, idenAttrs) ctxsBySname
- = let inhCtxs = (inhCtxsForSortName (sortNameForIden iden ctor) ctxsBySname)
-   in foldr (\ctx rest -> fromMaybe rest (applyOneCtx ctx rest)) (VarExpr "c") inhCtxs
-  where
-    -- | Runs `applyOneAttr` if the identifier's attribute definitions
-    -- contain an assignment to an instance of the given context
-    applyOneCtx :: Context -> Expression -> Maybe Expression
-    applyOneCtx ctx param
-      | isJust attrForCtx = applyOneAttr (fromJust attrForCtx) [param]
-      | otherwise = Nothing
-      where
-        attrForCtx = find (\(left, _) -> linst left == xinst ctx) idenAttrs
-
-        -- | Apply the necessary wrap based on the attribute assignment type
-        applyOneAttr :: AttributeDef -> [Expression] -> Maybe Expression
-        applyOneAttr (_, RightLHS _) _ = Nothing
-        applyOneAttr (l, RightAdd expr _) params
-          = return (transformForAddAttr ef (xnamespace ctx) (nextStep ++ params))
-          where
-            nextStep = maybeToList (applyOneAttr (l, expr) [])
-        applyOneAttr (_, RightSub iden context) params
-          = if elem iden (map fst lists) || elem iden (map fst folds)
-              then if isJust attrsForIden
-                then return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" (VarExpr iden : nextStep) : params))
-                else return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" [VarExpr iden] : params))
-              else if isJust attrsForIden
-                then return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) ((VarExpr iden : nextStep) ++ params))
-                else return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) (VarExpr iden : params))
-          where
-            newAttrs = filter (\(left, _) ->
-                let iden = liden left
-                    ctxsForSort = fromJust (lookup sname ctxsBySname)
-                    ctxsForIdenSort = fromJust (lookup (sortNameForIden iden ctor) ctxsBySname)
-                in (iden == "" && any (\ctx -> linst left == xinst ctx) ctxsForSort) || any (\ctx -> linst left == xinst ctx) ctxsForIdenSort
-              ) (cattrs ctor)
-            attrsForIden = find (\(left, _) -> liden left == iden) newAttrs
-            nextStep = maybeToList (applyOneAttr (fromJust attrsForIden) [])
-            lists = clists ctor
-            folds = dropFold $ cfolds ctor
-            sorts = csorts ctor

Tool/Variable/DeBruijn.hs

@@ -204,9 +204,53 @@ _substExpr sname consName =
     (FnCall (sname ++ "shiftplus") [VarExpr "c", VarExpr "sub"])
     (ConstrInst consName [VarExpr "var"])
 
+-- | For every inherited context of a sort, apply nested modifiers to the
+-- returned "c" variable
+_applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression
+_applyInhCtxsToAttrs sname ctor (iden, idenAttrs) ctxsBySname
+ = let inhCtxs = (inhCtxsForSortName (sortNameForIden iden ctor) ctxsBySname)
+   in foldr (\ctx rest -> fromMaybe rest (applyOneCtx ctx rest)) (VarExpr "c") inhCtxs
+  where
+    -- | Runs `applyOneAttr` if the identifier's attribute definitions
+    -- contain an assignment to an instance of the given context
+    applyOneCtx :: Context -> Expression -> Maybe Expression
+    applyOneCtx ctx param
+      | isJust attrForCtx = applyOneAttr (fromJust attrForCtx) [param]
+      | otherwise = Nothing
+      where
+        attrForCtx = find (\(left, _) -> linst left == xinst ctx) idenAttrs
+
+        -- | Apply the necessary wrap based on the attribute assignment type
+        applyOneAttr :: AttributeDef -> [Expression] -> Maybe Expression
+        applyOneAttr (_, RightLHS _) _ = Nothing
+        applyOneAttr (l, RightAdd expr _) params
+          = return (_oneDeeper (xnamespace ctx) (nextStep ++ params))
+          where
+            nextStep = maybeToList (applyOneAttr (l, expr) [])
+        applyOneAttr (_, RightSub iden context) params
+          = if elem iden (map fst lists) || elem iden (map fst folds)
+              then if isJust attrsForIden
+                then return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" (VarExpr iden : nextStep) : params))
+                else return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" [VarExpr iden] : params))
+              else if isJust attrsForIden
+                then return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) ((VarExpr iden : nextStep) ++ params))
+                else return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) (VarExpr iden : params))
+          where
+            newAttrs = filter (\(left, _) ->
+                let iden = liden left
+                    ctxsForSort = fromJust (lookup sname ctxsBySname)
+                    ctxsForIdenSort = fromJust (lookup (sortNameForIden iden ctor) ctxsBySname)
+                in (iden == "" && any (\ctx -> linst left == xinst ctx) ctxsForSort) || any (\ctx -> linst left == xinst ctx) ctxsForIdenSort
+              ) (cattrs ctor)
+            attrsForIden = find (\(left, _) -> liden left == iden) newAttrs
+            nextStep = maybeToList (applyOneAttr (fromJust attrsForIden) [])
+            lists = clists ctor
+            folds = dropFold $ cfolds ctor
+            sorts = csorts ctor
+
 ef = EF {
   paramForCtor = _getCtorParams,
   freeVarExprForVarCtor = _varCtorFreeVar,
-  transformForAddAttr = _oneDeeper,
+  applyInhCtxsToAttrs = _applyInhCtxsToAttrs,
   includeBinders = False
 }

Tool/Variable/String.hs

@@ -70,10 +70,52 @@ _substExpr sname consName =
 
 _oneDeeper namespace expr = FnCall "concat" [ListExpr (ListExpr [VarExpr "b"] : expr)]
 
+_applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression
+_applyInhCtxsToAttrs sname ctor (iden, idenAttrs) ctxsBySname
+ = let inhCtxs = (inhCtxsForSortName (sortNameForIden iden ctor) ctxsBySname)
+   in foldr (\ctx rest -> fromMaybe rest (applyOneCtx ctx rest)) (VarExpr "c") inhCtxs
+  where
+    -- | Runs `applyOneAttr` if the identifier's attribute definitions
+    -- contain an assignment to an instance of the given context
+    applyOneCtx :: Context -> Expression -> Maybe Expression
+    applyOneCtx ctx param
+      | isJust attrForCtx = applyOneAttr (fromJust attrForCtx) [param]
+      | otherwise = Nothing
+      where
+        attrForCtx = find (\(left, _) -> linst left == xinst ctx) idenAttrs
+
+        -- | Apply the necessary wrap based on the attribute assignment type
+        applyOneAttr :: AttributeDef -> [Expression] -> Maybe Expression
+        applyOneAttr (_, RightLHS _) _ = Nothing
+        applyOneAttr (l, RightAdd expr _) params
+          = return (_oneDeeper (xnamespace ctx) (nextStep ++ params))
+          where
+            nextStep = maybeToList (applyOneAttr (l, expr) [])
+        applyOneAttr (_, RightSub iden context) params
+          = if elem iden (map fst lists) || elem iden (map fst folds)
+              then if isJust attrsForIden
+                then return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" (VarExpr iden : nextStep) : params))
+                else return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" [VarExpr iden] : params))
+              else if isJust attrsForIden
+                then return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) ((VarExpr iden : nextStep) ++ params))
+                else return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) (VarExpr iden : params))
+          where
+            newAttrs = filter (\(left, _) ->
+                let iden = liden left
+                    ctxsForSort = fromJust (lookup sname ctxsBySname)
+                    ctxsForIdenSort = fromJust (lookup (sortNameForIden iden ctor) ctxsBySname)
+                in (iden == "" && any (\ctx -> linst left == xinst ctx) ctxsForSort) || any (\ctx -> linst left == xinst ctx) ctxsForIdenSort
+              ) (cattrs ctor)
+            attrsForIden = find (\(left, _) -> liden left == iden) newAttrs
+            nextStep = maybeToList (applyOneAttr (fromJust attrsForIden) [])
+            lists = clists ctor
+            folds = dropFold $ cfolds ctor
+            sorts = csorts ctor
+
 ef = EF {
   paramForCtor = _getCtorParams,
   freeVarExprForVarCtor = _varCtorFreeVar,
-  transformForAddAttr = _oneDeeper,
+  applyInhCtxsToAttrs = _applyInhCtxsToAttrs,
   includeBinders = True
 }