{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

-- This module provides commonly used helper functions for other modules
module Misc
  ( numToHex,
    strToHex,
    hexToStr,
    hexToNum,
    withVoidRho,
    allPathsIn,
    ensuredFile,
    shuffle,
    pattern DataObject,
  )
where

import Ast
import Control.Exception
import Control.Monad
import Data.Binary.IEEE754
import Data.Bits (Bits (shiftL), (.|.))
import qualified Data.Bits as IOArray
import qualified Data.ByteString as B
import Data.ByteString.Builder (toLazyByteString, word64BE)
import Data.ByteString.Lazy (unpack)
import qualified Data.ByteString.Lazy.UTF8 as U
import Data.Char (chr, isPrint, ord)
import Data.List (intercalate)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as M
import Data.Word (Word64, Word8)
import Numeric (readHex)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.FilePath ((</>))
import System.Random.Stateful
import Text.Printf (printf)

data FsException
  = FileDoesNotExist {FsException -> [Char]
file :: FilePath}
  | DirectoryDoesNotExist {FsException -> [Char]
dir :: FilePath}
  deriving (Show FsException
Typeable FsException
(Typeable FsException, Show FsException) =>
(FsException -> SomeException)
-> (SomeException -> Maybe FsException)
-> (FsException -> [Char])
-> Exception FsException
SomeException -> Maybe FsException
FsException -> [Char]
FsException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> [Char]) -> Exception e
$ctoException :: FsException -> SomeException
toException :: FsException -> SomeException
$cfromException :: SomeException -> Maybe FsException
fromException :: SomeException -> Maybe FsException
$cdisplayException :: FsException -> [Char]
displayException :: FsException -> [Char]
Exception)

instance Show FsException where
  show :: FsException -> [Char]
show FileDoesNotExist {[Char]
file :: FsException -> [Char]
file :: [Char]
..} = [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"File '%s' does not exist" [Char]
file
  show DirectoryDoesNotExist {[Char]
dir :: FsException -> [Char]
dir :: [Char]
..} = [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"Directory '%s' does not exist" [Char]
dir

-- Minimal matcher function (required for view pattern)
matchDataoObject :: Expression -> Maybe (String, String)
matchDataoObject :: Expression -> Maybe ([Char], [Char])
matchDataoObject
  ( ExApplication
      (ExDispatch (ExDispatch (ExDispatch Expression
ExGlobal (AtLabel [Char]
"org")) (AtLabel [Char]
"eolang")) (AtLabel [Char]
label))
      ( BiTau
          (AtAlpha Integer
0)
          ( ExApplication
              (ExDispatch (ExDispatch (ExDispatch Expression
ExGlobal (AtLabel [Char]
"org")) (AtLabel [Char]
"eolang")) (AtLabel [Char]
"bytes"))
              ( BiTau
                  (AtAlpha Integer
0)
                  (ExFormation [BiDelta [Char]
bts, BiVoid Attribute
AtRho])
                )
            )
        )
    ) = ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
label, [Char]
bts)
matchDataoObject Expression
_ = Maybe ([Char], [Char])
forall a. Maybe a
Nothing

pattern DataObject :: String -> String -> Expression
pattern $mDataObject :: forall {r}.
Expression -> ([Char] -> [Char] -> r) -> ((# #) -> r) -> r
$bDataObject :: [Char] -> [Char] -> Expression
DataObject label bts <- (matchDataoObject -> Just (label, bts))
  where
    DataObject [Char]
label [Char]
bts =
      Expression -> Binding -> Expression
ExApplication
        (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExGlobal ([Char] -> Attribute
AtLabel [Char]
"org")) ([Char] -> Attribute
AtLabel [Char]
"eolang")) ([Char] -> Attribute
AtLabel [Char]
label))
        ( Attribute -> Expression -> Binding
BiTau
            (Integer -> Attribute
AtAlpha Integer
0)
            ( Expression -> Binding -> Expression
ExApplication
                (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExGlobal ([Char] -> Attribute
AtLabel [Char]
"org")) ([Char] -> Attribute
AtLabel [Char]
"eolang")) ([Char] -> Attribute
AtLabel [Char]
"bytes"))
                ( Attribute -> Expression -> Binding
BiTau
                    (Integer -> Attribute
AtAlpha Integer
0)
                    ([Binding] -> Expression
ExFormation [[Char] -> Binding
BiDelta [Char]
bts, Attribute -> Binding
BiVoid Attribute
AtRho])
                )
            )
        )

-- Add void rho binding to the end of the list of any rho binding is not present
withVoidRho :: [Binding] -> [Binding]
withVoidRho :: [Binding] -> [Binding]
withVoidRho [Binding]
bds = [Binding] -> Bool -> [Binding]
withVoidRho' [Binding]
bds Bool
False
  where
    withVoidRho' :: [Binding] -> Bool -> [Binding]
    withVoidRho' :: [Binding] -> Bool -> [Binding]
withVoidRho' [] Bool
hasRho = [Attribute -> Binding
BiVoid Attribute
AtRho | Bool -> Bool
not Bool
hasRho]
    withVoidRho' (Binding
bd : [Binding]
bds) Bool
hasRho =
      case Binding
bd of
        BiMeta [Char]
_ -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds
        BiVoid (AtMeta [Char]
_) -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds
        BiTau (AtMeta [Char]
_) Expression
_ -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds
        BiVoid Attribute
AtRho -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> Bool -> [Binding]
withVoidRho' [Binding]
bds Bool
True
        BiTau Attribute
AtRho Expression
_ -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> Bool -> [Binding]
withVoidRho' [Binding]
bds Bool
True
        Binding
_ -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> Bool -> [Binding]
withVoidRho' [Binding]
bds Bool
hasRho

ensuredFile :: FilePath -> IO FilePath
ensuredFile :: [Char] -> IO [Char]
ensuredFile [Char]
pth = do
  Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
pth
  if Bool
exists then [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
pth else FsException -> IO [Char]
forall e a. Exception e => e -> IO a
throwIO ([Char] -> FsException
FileDoesNotExist [Char]
pth)

-- Recursively collect all file paths in provided directory
allPathsIn :: FilePath -> IO [FilePath]
allPathsIn :: [Char] -> IO [[Char]]
allPathsIn [Char]
dir = do
  Bool
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
dir
  [[Char]]
names <- if Bool
exists then [Char] -> IO [[Char]]
listDirectory [Char]
dir else FsException -> IO [[Char]]
forall e a. Exception e => e -> IO a
throwIO ([Char] -> FsException
DirectoryDoesNotExist [Char]
dir)
  let nested :: [[Char]]
nested = ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
dir [Char] -> ShowS
</>) [[Char]]
names
  [[[Char]]]
paths <-
    [[Char]] -> ([Char] -> IO [[Char]]) -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
      [[Char]]
nested
      ( \[Char]
path -> do
          Bool
isDir <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
          if Bool
isDir
            then [Char] -> IO [[Char]]
allPathsIn [Char]
path
            else [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]
path]
      )
  [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
paths)

-- >>> hexToBts "40-14-00-00-00-00-00-00"
-- [64,20,0,0,0,0,0,0]
-- >>> hexToBts "68-65-6C-6C-6F"
-- [104,101,108,108,111]
-- >>> hexToBts "01-01"
-- [1,1]
hexToBts :: String -> [Word8]
hexToBts :: [Char] -> [Word8]
hexToBts = ([Char] -> Word8) -> [[Char]] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Word8
forall {b}. Num b => [Char] -> b
readHexByte ([[Char]] -> [Word8]) -> ([Char] -> [[Char]]) -> [Char] -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
splitOnDash
  where
    splitOnDash :: [Char] -> [[Char]]
splitOnDash = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then Char
' ' else Char
c)
    readHexByte :: [Char] -> b
readHexByte [Char]
hx = case ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
hx of
      [(Integer
v, [Char]
"")] -> Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
v
      [(Integer, [Char])]
_ -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid hex byte: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
hx

btsToHex :: [Word8] -> String
btsToHex :: [Word8] -> [Char]
btsToHex [Word8]
bts = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" ((Word8 -> [Char]) -> [Word8] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Word8 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%02X") [Word8]
bts)

-- Convert hex string back to Double
-- >>> hexToNum "40-14-00-00-00-00-00-00"
-- Left 5
-- >>> hexToNum "BF-D0-00-00-00-00-00-00"
-- Right (-0.25)
-- >>> hexToNum "40-45-00-00-00-00-00-00"
-- Left 42
-- >>> hexToNum "40-45"
-- Expected 8 bytes for conversion, got 2
hexToNum :: String -> Either Integer Double
hexToNum :: [Char] -> Either Integer Double
hexToNum [Char]
hx =
  let bytes :: [Word8]
bytes = [Char] -> [Word8]
hexToBts [Char]
hx
   in if [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8
        then [Char] -> Either Integer Double
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either Integer Double)
-> [Char] -> Either Integer Double
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected 8 bytes for conversion, got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
bytes)
        else
          let word :: Word64
word = [Word8] -> Word64
toWord64BE [Word8]
bytes
              val :: Double
val = Word64 -> Double
wordToDouble Word64
word
           in case Double -> (Integer, Double)
forall b. Integral b => Double -> (b, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
val of
                (Integer
n, Double
0.0) -> Integer -> Either Integer Double
forall a b. a -> Either a b
Left Integer
n
                (Integer, Double)
_ -> Double -> Either Integer Double
forall a b. b -> Either a b
Right Double
val
  where
    toWord64BE :: [Word8] -> Word64
    toWord64BE :: [Word8] -> Word64
toWord64BE [Word8
a, Word8
b, Word8
c, Word8
d, Word8
e, Word8
f, Word8
g, Word8
h] =
      Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
56
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
48
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
40
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
e Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
24
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
f Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
8
        Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h
    toWord64BE [Word8]
_ = [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"Expected 8 bytes for Double"

-- >>> numToHex 0.0
-- "00-00-00-00-00-00-00-00"
-- >>> numToHex 42
-- "40-45-00-00-00-00-00-00"
-- >>> numToHex (-0.25)
-- "BF-D0-00-00-00-00-00-00"
-- >>> numToHex 5
-- "40-14-00-00-00-00-00-00"
numToHex :: Double -> String
numToHex :: Double -> [Char]
numToHex Double
num = [Word8] -> [Char]
btsToHex (ByteString -> [Word8]
unpack (Builder -> ByteString
toLazyByteString (Word64 -> Builder
word64BE (Double -> Word64
doubleToWord Double
num))))

-- >>> strToHex "hello"
-- "68-65-6C-6C-6F"
-- >>> strToHex "world"
-- "77-6F-72-6C-64"
-- >>> strToHex ""
-- "--"
-- >>> strToHex "h"
-- "68-"
-- >>> strToHex "h\""
-- "68-22"
-- >>> strToHex "\x01\x01"
-- "01-01"
strToHex :: String -> String
strToHex :: ShowS
strToHex [Char]
"" = [Char]
"--"
strToHex [Char
ch] = [Word8] -> [Char]
btsToHex (ByteString -> [Word8]
unpack ([Char] -> ByteString
U.fromString [Char
ch])) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-"
strToHex [Char]
str = [Word8] -> [Char]
btsToHex (ByteString -> [Word8]
unpack ([Char] -> ByteString
U.fromString [Char]
str))

-- Convert hex string like "68-65-6C-6C-6F" to "hello"
-- >>> hexToStr "68-65-6C-6C-6F"
-- "hello"
-- >>> hexToStr "--"
-- ""
-- >>> hexToStr "68-"
-- "h"
-- >>> hexToStr "77-6F-72-6C-64"
-- "world"
-- >>> hexToStr ""
-- ""
-- >>> hexToStr "68-22"
-- "h\\\""
-- >>> hexToStr "01-02"
-- "\\x01\\x02"
hexToStr :: String -> String
hexToStr :: ShowS
hexToStr [Char]
"--" = [Char]
""
hexToStr [] = [Char]
""
hexToStr [Char]
hx = ShowS
escapeStr (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack ([Char] -> [Word8]
hexToBts [Char]
cleaned))
  where
    -- Remove trailing dash if present (from single-char case)
    cleaned :: String
    cleaned :: [Char]
cleaned = if Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
hx) Bool -> Bool -> Bool
&& [Char] -> Char
forall a. HasCallStack => [a] -> a
last [Char]
hx Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then ShowS
forall a. HasCallStack => [a] -> [a]
init [Char]
hx else [Char]
hx

    escapeStr :: String -> String
    escapeStr :: ShowS
escapeStr = (Char -> [Char]) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
escapeChar
      where
        escapeChar :: Char -> [Char]
escapeChar Char
'"' = [Char]
"\\\""
        escapeChar Char
'\\' = [Char]
"\\\\"
        escapeChar Char
'\n' = [Char]
"\\n"
        escapeChar Char
'\t' = [Char]
"\\t"
        escapeChar Char
c
          | Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' = [Char
c]
          | Bool
otherwise = [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"\\x%02x" (Char -> Int
ord Char
c)

-- Fast Fisher-Yates with mutable vectors.
-- The function is generated by ChatGPT and claimed as
-- fastest approach comparing to usage IOArray.
-- >>> shuffle [1..20]
-- [12,15,5,14,1,7,17,10,9,16,13,11,6,4,18,2,19,20,3,8]
shuffle :: [a] -> IO [a]
shuffle :: forall a. [a] -> IO [a]
shuffle [a]
xs = do
  IOGenM StdGen
gen <- StdGen -> IO (IOGenM StdGen)
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM (StdGen -> IO (IOGenM StdGen)) -> IO StdGen -> IO (IOGenM StdGen)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
  let n :: Int
n = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  MVector RealWorld a
v <- Vector a -> IO (MVector (PrimState IO) a)
forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.thaw ([a] -> Vector a
forall a. [a] -> Vector a
V.fromList [a]
xs) -- Mutable copy
  [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Int
j <- (Int, Int) -> IOGenM StdGen -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
0, Int
i) IOGenM StdGen
gen
    MVector (PrimState IO) a -> Int -> Int -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> Int -> m ()
M.swap MVector RealWorld a
MVector (PrimState IO) a
v Int
i Int
j
  Vector a -> [a]
forall a. Vector a -> [a]
V.toList (Vector a -> [a]) -> IO (Vector a) -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) a -> IO (Vector a)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.freeze MVector RealWorld a
MVector (PrimState IO) a
v