module Language.Haskell.Brittany.Internal.Obfuscation
  ( obfuscate
  )
where



#include "prelude.inc"

import           Data.Char
import           System.Random



obfuscate :: Text -> IO Text
obfuscate :: Text -> IO Text
obfuscate Text
input = do
  let predi :: Char -> Bool
predi Char
x = Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"_'"
  let groups :: [[Char]]
groups = (Char -> Char -> Bool) -> [Char] -> [[Char]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
List.groupBy (\Char
a Char
b -> Char -> Bool
predi Char
a Bool -> Bool -> Bool
&& Char -> Bool
predi Char
b) (Text -> [Char]
Text.unpack Text
input)
  let idents :: [[Char]]
idents = Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList (Set [Char] -> [[Char]]) -> Set [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList ([[Char]] -> Set [Char]) -> [[Char]] -> Set [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
predi) [[Char]]
groups
  let exceptionFilter :: [Char] -> Bool
exceptionFilter [Char]
x | [Char]
x [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
keywords = Bool
False
      exceptionFilter [Char]
x | [Char]
x [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
extraKWs = Bool
False
      exceptionFilter [Char]
x                     = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
x
  let filtered :: [[Char]]
filtered = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
exceptionFilter [[Char]]
idents
  Map [Char] [Char]
mappings <- ([([Char], [Char])] -> Map [Char] [Char])
-> IO [([Char], [Char])] -> IO (Map [Char] [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([Char], [Char])] -> Map [Char] [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (IO [([Char], [Char])] -> IO (Map [Char] [Char]))
-> IO [([Char], [Char])] -> IO (Map [Char] [Char])
forall a b. (a -> b) -> a -> b
$ [[Char]]
filtered [[Char]]
-> ([Char] -> IO ([Char], [Char])) -> IO [([Char], [Char])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
`forM` \[Char]
x -> do
    [Char]
r <- [Char] -> IO [Char]
createAlias [Char]
x
    ([Char], [Char]) -> IO ([Char], [Char])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
x, [Char]
r)
  let groups' :: [[Char]]
groups' = [[Char]]
groups [[Char]] -> ([Char] -> [Char]) -> [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Char]
w -> [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
w ([Char] -> Map [Char] [Char] -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
w Map [Char] [Char]
mappings)
  Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Char] -> Text) -> [[Char]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
Text.pack [[Char]]
groups'

keywords :: [String]
keywords :: [[Char]]
keywords =
  [ [Char]
"case"
  , [Char]
"class"
  , [Char]
"data"
  , [Char]
"default"
  , [Char]
"deriving"
  , [Char]
"do"
  , [Char]
"mdo"
  , [Char]
"else"
  , [Char]
"forall"
  , [Char]
"if"
  , [Char]
"import"
  , [Char]
"in"
  , [Char]
"infix"
  , [Char]
"infixl"
  , [Char]
"infixr"
  , [Char]
"instance"
  , [Char]
"let"
  , [Char]
"module"
  , [Char]
"newtype"
  , [Char]
"of"
  , [Char]
"qualified"
  , [Char]
"then"
  , [Char]
"type"
  , [Char]
"where"
  , [Char]
"_"
  , [Char]
"foreign"
  , [Char]
"ccall"
  , [Char]
"as"
  , [Char]
"safe"
  , [Char]
"unsafe"
  , [Char]
"hiding"
  , [Char]
"proc"
  , [Char]
"rec"
  , [Char]
"family"
  ]

extraKWs :: [String]
extraKWs :: [[Char]]
extraKWs = [[Char]
"return", [Char]
"pure", [Char]
"Int", [Char]
"True", [Char]
"False", [Char]
"otherwise"]

createAlias :: String -> IO String
createAlias :: [Char] -> IO [Char]
createAlias [Char]
xs = Hint -> [Char] -> IO [Char]
go Hint
NoHint [Char]
xs
 where
  go :: Hint -> [Char] -> IO [Char]
go Hint
_hint [Char]
""       = [Char] -> IO [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
  go Hint
hint (Char
c : [Char]
cr)  = do
    Char
c' <- case Hint
hint of
      Hint
VocalHint | Char -> Bool
isUpper Char
c -> [Char] -> IO Char
forall a. Random a => [a] -> IO a
randomFrom ([Char] -> IO Char) -> [Char] -> IO Char
forall a b. (a -> b) -> a -> b
$ [Char]
"AAAEEEOOOIIIUUU" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z']
      Hint
_ | Char -> Bool
isUpper Char
c         -> [Char] -> IO Char
forall a. Random a => [a] -> IO a
randomFrom [Char
'A' .. Char
'Z']
      Hint
VocalHint | Char -> Bool
isLower Char
c -> [Char] -> IO Char
forall a. Random a => [a] -> IO a
randomFrom ([Char] -> IO Char) -> [Char] -> IO Char
forall a b. (a -> b) -> a -> b
$ [Char]
"aaaeeeoooiiiuuu" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'a' .. Char
'z']
      Hint
_ | Char -> Bool
isLower Char
c         -> [Char] -> IO Char
forall a. Random a => [a] -> IO a
randomFrom [Char
'a' .. Char
'z']
      Hint
_                     -> Char -> IO Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
    [Char]
cr' <- Hint -> [Char] -> IO [Char]
go (if Char
c' Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"aeuioAEUIO" then Hint
NoVocalHint else Hint
VocalHint) [Char]
cr
    [Char] -> IO [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
c' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cr')

data Hint = NoHint | VocalHint | NoVocalHint

_randomRange :: Random a => a -> a -> IO a
_randomRange :: a -> a -> IO a
_randomRange a
lo a
hi = do
  StdGen
gen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
getStdGen
  let (a
x, StdGen
gen') = (a, a) -> StdGen -> (a, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (a
lo, a
hi) StdGen
gen
  StdGen -> IO ()
forall (m :: * -> *). MonadIO m => StdGen -> m ()
setStdGen StdGen
gen'
  a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

randomFrom :: Random a => [a] -> IO a
randomFrom :: [a] -> IO a
randomFrom [a]
l = do
  let hi :: Int
hi = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  StdGen
gen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
getStdGen
  let (Int
x, StdGen
gen') = (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
hi) StdGen
gen
  StdGen -> IO ()
forall (m :: * -> *). MonadIO m => StdGen -> m ()
setStdGen StdGen
gen'
  a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ [a]
l [a] -> Int -> a
forall a. [a] -> Int -> a
List.!! Int
x