refactor: Use (string, int) for names in C++

Jikka.cabal

@@ -58,6 +58,7 @@ library
       Jikka.Common.Location
       Jikka.Common.Matrix
       Jikka.Common.ModInt
+      Jikka.Common.Name
       Jikka.Common.Parse.JoinLines
       Jikka.Common.Parse.OffsideRule
       Jikka.Common.Parse.Read
@@ -115,6 +116,7 @@ library
       Jikka.CPlusPlus.Convert
       Jikka.CPlusPlus.Convert.AddMain
       Jikka.CPlusPlus.Convert.BundleRuntime
+      Jikka.CPlusPlus.Convert.BurnFlavouredNames
       Jikka.CPlusPlus.Convert.EmbedOriginalCode
       Jikka.CPlusPlus.Convert.FromCore
       Jikka.CPlusPlus.Convert.InlineSetAt

src/Jikka/CPlusPlus/Convert/AddMain.hs

@@ -38,15 +38,15 @@ runFormatExpr = \case
   F.At e i -> at <$> runFormatExpr e <*> (Var <$> lookup' i)
   F.Len e -> do
     e <- runFormatExpr e
-    return $ cast TyInt32 (Call MethodSize [e])
+    return $ cast TyInt32 (Call' MethodSize [e])
 
 runMainDeclare :: (MonadState (M.Map String VarName) m, MonadAlpha m, MonadError Error m) => F.IOFormat -> m [(S.Set VarName, Statement)]
 runMainDeclare format = go M.empty (F.inputTree format)
   where
     go sizes = \case
       F.Exp e -> do
         (x, indices) <- F.unpackSubscriptedVar e
-        y <- renameVarName LocalNameKind x
+        y <- renameVarName' LocalNameKind x
         modify' $ M.insert x y
         let lookupSize i = case M.lookup i sizes of
               Just e -> return e
@@ -78,7 +78,7 @@ runMainInput format decls = do
           (stmts', initialized) <- go initialized (F.Seq formats)
           return (stmts ++ stmts', initialized)
         F.Loop i n body -> do
-          j <- renameVarName LoopCounterNameKind i
+          j <- renameVarName' LoopCounterNameKind i
           modify' $ M.insert i j
           n <- runFormatExpr n
           (body, initialized) <- go initialized body
@@ -90,14 +90,14 @@ runMainInput format decls = do
 runMainSolve :: (MonadState (M.Map String VarName) m, MonadAlpha m, MonadError Error m) => F.IOFormat -> m Statement
 runMainSolve format = do
   args <- mapM lookup' (F.inputVariables format)
-  let solve = Call (Function "solve" []) (map Var args)
+  let solve = Call' (Function "solve" []) (map Var args)
   case F.outputVariables format of
     Left x -> do
-      y <- renameVarName LocalNameKind x
+      y <- renameVarName' LocalNameKind x
       modify' $ M.insert x y
       return $ Declare TyAuto y (DeclareCopy solve)
     Right xs -> do
-      ys <- mapM (renameVarName LocalNameKind) xs
+      ys <- mapM (renameVarName' LocalNameKind) xs
       modify' $ \env -> foldl (\env (x, y) -> M.insert x y env) env (zip xs ys)
       return $ DeclareDestructure ys solve
 
@@ -111,7 +111,7 @@ runMainOutput format = go (F.outputTree format)
       F.Newline -> return [coutStatement (Lit (LitChar '\n'))]
       F.Seq formats -> concat <$> mapM go formats
       F.Loop i n body -> do
-        j <- renameVarName LoopCounterNameKind i
+        j <- renameVarName' LoopCounterNameKind i
         modify' $ M.insert i j
         n <- runFormatExpr n
         body <- go body

src/Jikka/CPlusPlus/Convert/BurnFlavouredNames.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+-- |
+-- Module      : Jikka.CPlusPlus.Convert.BurnFlavouredNames
+-- Description : remove unique numbers from names as a preprocess to emit the result source code. / 結果のソースコードを出力する前処理として、名前に付けられた一意な整数を解決します。
+-- Copyright   : (c) Kimiyuki Onaka, 2020
+-- License     : Apache License 2.0
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : portable
+module Jikka.CPlusPlus.Convert.BurnFlavouredNames
+  ( run,
+  )
+where
+
+import Control.Monad.State.Strict
+import qualified Data.Map as M
+import Data.Maybe
+import qualified Data.Set as S
+import Jikka.CPlusPlus.Language.Expr
+import Jikka.CPlusPlus.Language.Util
+import Jikka.Common.Alpha
+import Jikka.Common.Error
+
+data Env = Env
+  { renameMapping :: M.Map VarName VarName,
+    usedVars :: S.Set String
+  }
+  deriving (Eq, Ord, Read, Show)
+
+emptyEnv :: Env
+emptyEnv =
+  Env
+    { renameMapping = M.empty,
+      usedVars = S.empty
+    }
+
+fromNameKind :: Maybe NameKind -> String
+fromNameKind = \case
+  Nothing -> "u"
+  Just LocalNameKind -> "x"
+  Just LocalArgumentNameKind -> "b"
+  Just LoopCounterNameKind -> "i"
+  Just ConstantNameKind -> "c"
+  Just FunctionNameKind -> "f"
+  Just ArgumentNameKind -> "a"
+
+chooseOccName :: S.Set String -> VarName -> String
+chooseOccName used (VarName occ _ kind) =
+  let occ_workaround = (\s -> if '$' `elem` s then Nothing else Just s) =<< occ -- TODO: Remove this after Python stops using variables with `$`.
+      base = fromMaybe (fromNameKind kind) occ_workaround
+      occs = base : map (\i -> base ++ show i) [2 ..]
+      occ' = head $ filter (`S.notMember` used) occs
+   in occ'
+
+rename :: MonadState Env m => VarName -> m VarName
+rename x = do
+  y <- gets $ M.lookup x . renameMapping
+  case y of
+    Just y -> return y
+    Nothing -> do
+      y' <- flip chooseOccName x <$> gets usedVars
+      let y = VarName (Just y') Nothing Nothing
+      modify $ \env ->
+        env
+          { renameMapping = M.insert x y (renameMapping env),
+            usedVars = S.insert y' (usedVars env)
+          }
+      return y
+
+mapVarNameExprStatementGenericM :: forall m a. Monad m => ((Expr -> m Expr) -> (Statement -> m [Statement]) -> a) -> (VarName -> m VarName) -> a
+mapVarNameExprStatementGenericM mapExprStatementM f = mapExprStatementM goE (fmap (: []) . goS)
+  where
+    goE :: Monad m => Expr -> m Expr
+    goE = \case
+      Var x -> Var <$> f x
+      Lam args ret body -> Lam <$> mapM (\(t, x) -> (t,) <$> f x) args <*> pure ret <*> pure body
+      e -> return e
+    goS :: Monad m => Statement -> m Statement
+    goS = \case
+      For t x init pred incr body -> (\x -> For t x init pred incr body) <$> f x
+      ForEach t x e body -> ForEach t <$> f x <*> pure e <*> pure body
+      Declare t x init -> Declare t <$> f x <*> pure init
+      DeclareDestructure xs e -> DeclareDestructure <$> mapM f xs <*> pure e
+      Assign e -> do
+        let go = \case
+              LeftVar x -> LeftVar <$> f x
+              LeftAt e1 e2 -> LeftAt <$> go e1 <*> pure e2
+              LeftGet n e -> LeftGet n <$> go e
+        Assign <$> case e of
+          AssignExpr op e1 e2 -> AssignExpr op <$> go e1 <*> pure e2
+          AssignIncr e -> AssignIncr <$> go e
+          AssignDecr e -> AssignDecr <$> go e
+      stmt -> return stmt
+
+mapVarNameToplevelStatementM :: Monad m => (VarName -> m VarName) -> ToplevelStatement -> m ToplevelStatement
+mapVarNameToplevelStatementM f stmt = do
+  stmt <- case stmt of
+    VarDef t x e -> VarDef t <$> f x <*> pure e
+    FunDef ret g args body -> FunDef ret g <$> mapM (\(t, x) -> (t,) <$> f x) args <*> pure body
+    _ -> return stmt
+  mapVarNameExprStatementGenericM mapExprStatementToplevelStatementM f stmt
+
+mapVarNameProgramM :: Monad m => (VarName -> m VarName) -> Program -> m Program
+mapVarNameProgramM f = mapToplevelStatementProgramM (fmap (: []) . mapVarNameToplevelStatementM f)
+
+runProgram :: MonadState Env m => Program -> m Program
+runProgram = mapVarNameProgramM rename
+
+run :: (MonadAlpha m, MonadError Error m) => Program -> m Program
+run prog = wrapError' "Jikka.CPlusPlus.Convert.BurnFlavouredNames" $ do
+  evalStateT (runProgram prog) emptyEnv