{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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
  ( numToBts,
    strToBts,
    bytesToBts,
    btsToStr,
    btsToNum,
    withVoidRho,
    allPathsIn,
    ensuredFile,
    shuffle,
    btsToUnescapedStr,
    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, word8)
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 -> String
file :: FilePath}
  | DirectoryDoesNotExist {FsException -> String
dir :: FilePath}
  deriving (Show FsException
Typeable FsException
(Typeable FsException, Show FsException) =>
(FsException -> SomeException)
-> (SomeException -> Maybe FsException)
-> (FsException -> String)
-> Exception FsException
SomeException -> Maybe FsException
FsException -> String
FsException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: FsException -> SomeException
toException :: FsException -> SomeException
$cfromException :: SomeException -> Maybe FsException
fromException :: SomeException -> Maybe FsException
$cdisplayException :: FsException -> String
displayException :: FsException -> String
Exception)

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

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

pattern DataObject :: String -> Bytes -> Expression
pattern $mDataObject :: forall {r}.
Expression -> (String -> Bytes -> r) -> ((# #) -> r) -> r
$bDataObject :: String -> Bytes -> Expression
DataObject label bts <- (matchDataoObject -> Just (label, bts))
  where
    DataObject String
label Bytes
bts =
      Expression -> Binding -> Expression
ExApplication
        (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExGlobal (String -> Attribute
AtLabel String
"org")) (String -> Attribute
AtLabel String
"eolang")) (String -> Attribute
AtLabel String
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 (String -> Attribute
AtLabel String
"org")) (String -> Attribute
AtLabel String
"eolang")) (String -> Attribute
AtLabel String
"bytes"))
                ( Attribute -> Expression -> Binding
BiTau
                    (Integer -> Attribute
AtAlpha Integer
0)
                    ([Binding] -> Expression
ExFormation [Bytes -> Binding
BiDelta Bytes
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 String
_ -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds
        BiVoid (AtMeta String
_) -> Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds
        BiTau (AtMeta String
_) 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 :: String -> IO String
ensuredFile String
pth = do
  Bool
exists <- String -> IO Bool
doesFileExist String
pth
  if Bool
exists then String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
pth else FsException -> IO String
forall e a. Exception e => e -> IO a
throwIO (String -> FsException
FileDoesNotExist String
pth)

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

-- >>> btsToWord8 BtEmpty
-- []
-- >>> btsToWord8 (BtOne "01")
-- [1]
-- >>> btsToWord8 (BtMany [])
-- []
-- >>> btsToWord8 (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"])
-- [64,20,0,0,0,0,0,0]
btsToWord8 :: Bytes -> [Word8]
btsToWord8 :: Bytes -> [Word8]
btsToWord8 Bytes
BtEmpty = []
btsToWord8 (BtOne String
bt) = case ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex String
bt of
  [(Integer
hex, String
"")] -> [Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
hex]
  [(Integer, String)]
_ -> String -> [Word8]
forall a. HasCallStack => String -> a
error (String -> [Word8]) -> String -> [Word8]
forall a b. (a -> b) -> a -> b
$ String
"Invalid hex byte; " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
bt
btsToWord8 (BtMany []) = []
btsToWord8 (BtMany (String
bt : [String]
bts)) =
  let [Word8
next] = Bytes -> [Word8]
btsToWord8 (String -> Bytes
BtOne String
bt)
   in Word8
next Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Bytes -> [Word8]
btsToWord8 ([String] -> Bytes
BtMany [String]
bts)

-- >>> word8ToBytes [64, 20, 0]
-- BtMany ["40","14","00"]
word8ToBytes :: [Word8] -> Bytes
word8ToBytes :: [Word8] -> Bytes
word8ToBytes [] = Bytes
BtEmpty
word8ToBytes [Word8
w8] = String -> Bytes
BtOne (String -> Word8 -> String
forall r. PrintfType r => String -> r
printf String
"%02X" Word8
w8)
word8ToBytes [Word8]
bts = [String] -> Bytes
BtMany ((Word8 -> String) -> [Word8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Word8 -> String
forall r. PrintfType r => String -> r
printf String
"%02X") [Word8]
bts)

-- Convert Bytes back to Double
-- >>> btsToNum (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"])
-- Left 5
-- >>> btsToNum (BtMany ["BF", "D0", "00", "00", "00", "00", "00", "00"])
-- Right (-0.25)
-- >>> btsToNum (BtMany ["40", "45", "00", "00", "00", "00", "00", "00"])
-- Left 42
-- >>> btsToNum (BtMany ["40", "45"])
-- Expected 8 bytes for conversion, got 2
btsToNum :: Bytes -> Either Integer Double
btsToNum :: Bytes -> Either Integer Double
btsToNum Bytes
hx =
  let bytes :: [Word8]
bytes = Bytes -> [Word8]
btsToWord8 Bytes
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 String -> Either Integer Double
forall a. HasCallStack => String -> a
error (String -> Either Integer Double)
-> String -> Either Integer Double
forall a b. (a -> b) -> a -> b
$ String
"Expected 8 bytes for conversion, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
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]
_ = String -> Word64
forall a. HasCallStack => String -> a
error String
"Expected 8 bytes for Double"

-- >>> numToBts 0.0
-- BtMany ["00","00","00","00","00","00","00","00"]
-- >>> numToBts 42
-- BtMany ["40","45","00","00","00","00","00","00"]
-- >>> numToBts (-0.25)
-- BtMany ["BF","D0","00","00","00","00","00","00"]
-- >>> numToBts 5
-- BtMany ["40","14","00","00","00","00","00","00"]
numToBts :: Double -> Bytes
numToBts :: Double -> Bytes
numToBts Double
num = [Word8] -> Bytes
word8ToBytes (ByteString -> [Word8]
unpack (Builder -> ByteString
toLazyByteString (Word64 -> Builder
word64BE (Double -> Word64
doubleToWord Double
num))))

-- >>> strToBts "hello"
-- BtMany ["68","65","6C","6C","6F"]
-- >>> strToBts "world"
-- BtMany ["77","6F","72","6C","64"]
-- >>> strToBts ""
-- BtEmpty
-- >>> strToBts "h"
-- BtOne "68"
-- >>> strToBts "h\""
-- BtMany ["68","22"]
-- >>> strToBts "\x01\x01"
-- BtMany ["01","01"]
strToBts :: String -> Bytes
strToBts :: String -> Bytes
strToBts String
"" = Bytes
BtEmpty
strToBts [Char
ch] = [Word8] -> Bytes
word8ToBytes (ByteString -> [Word8]
unpack (String -> ByteString
U.fromString [Char
ch]))
strToBts String
str = [Word8] -> Bytes
word8ToBytes (ByteString -> [Word8]
unpack (String -> ByteString
U.fromString String
str))

-- >>> bytesToBts "--"
-- BtEmpty
-- >>> bytesToBts "77-6F"
-- BtMany ["77","6F"]
-- >>> bytesToBts "01-"
-- BtOne "01"
bytesToBts :: String -> Bytes
bytesToBts :: String -> Bytes
bytesToBts String
"--" = Bytes
BtEmpty
bytesToBts String
str =
  if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
last String
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
    then String -> Bytes
BtOne (ShowS
forall a. HasCallStack => [a] -> [a]
init String
str)
    else [String] -> Bytes
BtMany ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"-" (String -> Text
T.pack String
str)))

-- Convert hex string like "68-65-6C-6C-6F" to "hello"
-- >>> btsToStr (BtMany ["68", "65", "6C", "6C", "6F"])
-- "hello"
-- >>> btsToStr (BtOne "68")
-- "h"
-- >>> btsToStr (BtMany ["77", "6F", "72", "6C", "64"])
-- "world"
-- >>> btsToStr BtEmpty
-- ""
-- >>> btsToStr (BtMany ["68", "22"])
-- "h\\\""
-- >>> btsToStr (BtMany ["01", "02"])
-- "\\x01\\x02"
btsToStr :: Bytes -> String
btsToStr :: Bytes -> String
btsToStr Bytes
BtEmpty = String
""
btsToStr Bytes
bytes = ShowS
escapeStr (Bytes -> String
btsToUnescapedStr Bytes
bytes)
  where
    escapeStr :: String -> String
    escapeStr :: ShowS
escapeStr = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeChar
      where
        escapeChar :: Char -> String
escapeChar Char
'"' = String
"\\\""
        escapeChar Char
'\\' = String
"\\\\"
        escapeChar Char
'\n' = String
"\\n"
        escapeChar Char
'\t' = String
"\\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 = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"\\x%02x" (Char -> Int
ord Char
c)

-- >>> btsToUnescapedStr (BtMany ["01", "02"])
-- "\SOH\STX"
-- >>> btsToUnescapedStr (BtMany ["77", "6F", "72", "6C", "64"])
-- "world"
-- >>> btsToUnescapedStr (BtMany ["68", "22"])
-- "h\""
btsToUnescapedStr :: Bytes -> String
btsToUnescapedStr :: Bytes -> String
btsToUnescapedStr Bytes
bytes = Text -> String
T.unpack (ByteString -> Text
T.decodeUtf8 ([Word8] -> ByteString
B.pack (Bytes -> [Word8]
btsToWord8 Bytes
bytes)))

-- Fast Fisher-Yates with mutable vectors.
-- The function is generated by ChatGPT and claimed as
-- fastest approach comparing to usage IOArray.
-- >>> shuffle [1..20]
-- [7,15,5,18,13,19,3,11,20,2,1,8,14,16,17,12,9,10,6,4]
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