{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

-- |
-- 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  : kimiyuki95@gmail.com
-- 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
import Jikka.Common.Name

data Env = Env
  { Env -> Map VarName VarName
renameMapping :: M.Map VarName VarName,
    Env -> Set String
usedVars :: S.Set String
  }
  deriving (Env -> Env -> Bool
(Env -> Env -> Bool) -> (Env -> Env -> Bool) -> Eq Env
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Env -> Env -> Bool
$c/= :: Env -> Env -> Bool
== :: Env -> Env -> Bool
$c== :: Env -> Env -> Bool
Eq, Eq Env
Eq Env
-> (Env -> Env -> Ordering)
-> (Env -> Env -> Bool)
-> (Env -> Env -> Bool)
-> (Env -> Env -> Bool)
-> (Env -> Env -> Bool)
-> (Env -> Env -> Env)
-> (Env -> Env -> Env)
-> Ord Env
Env -> Env -> Bool
Env -> Env -> Ordering
Env -> Env -> Env
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Env -> Env -> Env
$cmin :: Env -> Env -> Env
max :: Env -> Env -> Env
$cmax :: Env -> Env -> Env
>= :: Env -> Env -> Bool
$c>= :: Env -> Env -> Bool
> :: Env -> Env -> Bool
$c> :: Env -> Env -> Bool
<= :: Env -> Env -> Bool
$c<= :: Env -> Env -> Bool
< :: Env -> Env -> Bool
$c< :: Env -> Env -> Bool
compare :: Env -> Env -> Ordering
$ccompare :: Env -> Env -> Ordering
$cp1Ord :: Eq Env
Ord, ReadPrec [Env]
ReadPrec Env
Int -> ReadS Env
ReadS [Env]
(Int -> ReadS Env)
-> ReadS [Env] -> ReadPrec Env -> ReadPrec [Env] -> Read Env
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Env]
$creadListPrec :: ReadPrec [Env]
readPrec :: ReadPrec Env
$creadPrec :: ReadPrec Env
readList :: ReadS [Env]
$creadList :: ReadS [Env]
readsPrec :: Int -> ReadS Env
$creadsPrec :: Int -> ReadS Env
Read, Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Env] -> ShowS
$cshowList :: [Env] -> ShowS
show :: Env -> String
$cshow :: Env -> String
showsPrec :: Int -> Env -> ShowS
$cshowsPrec :: Int -> Env -> ShowS
Show)

emptyEnv :: Env
emptyEnv :: Env
emptyEnv =
  Env :: Map VarName VarName -> Set String -> Env
Env
    { renameMapping :: Map VarName VarName
renameMapping = Map VarName VarName
forall k a. Map k a
M.empty,
      usedVars :: Set String
usedVars = Set String
forall a. Set a
S.empty
    }

fromNameHint :: Maybe NameHint -> String
fromNameHint :: Maybe NameHint -> String
fromNameHint = \case
  Maybe NameHint
Nothing -> String
"u"
  Just NameHint
LocalNameHint -> String
"x"
  Just NameHint
LocalArgumentNameHint -> String
"b"
  Just NameHint
LoopCounterNameHint -> String
"i"
  Just NameHint
ConstantNameHint -> String
"c"
  Just NameHint
FunctionNameHint -> String
"f"
  Just NameHint
ArgumentNameHint -> String
"a"
  Just (AdHocNameHint String
hint) -> String
hint

chooseOccName :: S.Set String -> VarName -> String
chooseOccName :: Set String -> VarName -> String
chooseOccName Set String
used (VarName OccName
occ NameFlavour
_ Maybe NameHint
kind) =
  let occ_workaround :: OccName
occ_workaround = (\String
s -> if Char
'$' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s then OccName
forall a. Maybe a
Nothing else String -> OccName
forall a. a -> Maybe a
Just String
s) (String -> OccName) -> OccName -> OccName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OccName
occ -- TODO: Remove this after Python stops using variables with `$`.
      base :: String
base = String -> OccName -> String
forall a. a -> Maybe a -> a
fromMaybe (Maybe NameHint -> String
fromNameHint Maybe NameHint
kind) OccName
occ_workaround
      occs :: [String]
occs = String
base String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i) [Integer
2 ..]
      occ' :: String
occ' = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set String
used) [String]
occs
   in String
occ'

rename :: MonadState Env m => VarName -> m VarName
rename :: VarName -> m VarName
rename VarName
x = do
  Maybe VarName
y <- (Env -> Maybe VarName) -> m (Maybe VarName)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Env -> Maybe VarName) -> m (Maybe VarName))
-> (Env -> Maybe VarName) -> m (Maybe VarName)
forall a b. (a -> b) -> a -> b
$ VarName -> Map VarName VarName -> Maybe VarName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VarName
x (Map VarName VarName -> Maybe VarName)
-> (Env -> Map VarName VarName) -> Env -> Maybe VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map VarName VarName
renameMapping
  case Maybe VarName
y of
    Just VarName
y -> VarName -> m VarName
forall (m :: * -> *) a. Monad m => a -> m a
return VarName
y
    Maybe VarName
Nothing -> do
      String
y' <- (Set String -> VarName -> String)
-> VarName -> Set String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Set String -> VarName -> String
chooseOccName VarName
x (Set String -> String) -> m (Set String) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> Set String) -> m (Set String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env -> Set String
usedVars
      let y :: VarName
y = OccName -> NameFlavour -> Maybe NameHint -> VarName
VarName (String -> OccName
forall a. a -> Maybe a
Just String
y') NameFlavour
forall a. Maybe a
Nothing Maybe NameHint
forall a. Maybe a
Nothing
      (Env -> Env) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Env -> Env) -> m ()) -> (Env -> Env) -> m ()
forall a b. (a -> b) -> a -> b
$ \Env
env ->
        Env
env
          { renameMapping :: Map VarName VarName
renameMapping = VarName -> VarName -> Map VarName VarName -> Map VarName VarName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VarName
x VarName
y (Env -> Map VarName VarName
renameMapping Env
env),
            usedVars :: Set String
usedVars = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
y' (Env -> Set String
usedVars Env
env)
          }
      VarName -> m VarName
forall (m :: * -> *) a. Monad m => a -> m a
return VarName
y

runProgram :: MonadState Env m => Program -> m Program
runProgram :: Program -> m Program
runProgram = (VarName -> m VarName) -> Program -> m Program
forall (m :: * -> *).
Monad m =>
(VarName -> m VarName) -> Program -> m Program
mapVarNameProgramM VarName -> m VarName
forall (m :: * -> *). MonadState Env m => VarName -> m VarName
rename

run :: (MonadAlpha m, MonadError Error m) => Program -> m Program
run :: Program -> m Program
run Program
prog = String -> m Program -> m Program
forall (m :: * -> *) a. MonadError Error m => String -> m a -> m a
wrapError' String
"Jikka.CPlusPlus.Convert.BurnFlavouredNames" (m Program -> m Program) -> m Program -> m Program
forall a b. (a -> b) -> a -> b
$ do
  StateT Env m Program -> Env -> m Program
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Program -> StateT Env m Program
forall (m :: * -> *). MonadState Env m => Program -> m Program
runProgram Program
prog) Env
emptyEnv