{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
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
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