phino-0.0.0.4: src/Misc.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}

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

-- This module provides commonly used helper functions for other modules
module Misc where

import Ast
import Control.Exception
import Control.Monad
import Data.Binary.IEEE754
import qualified Data.Bits as IOArray
import Data.ByteString.Builder (toLazyByteString, word64BE)
import Data.ByteString.Lazy (unpack)
import qualified Data.ByteString.Lazy.UTF8 as U
import Data.List (intercalate)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as M
import Data.Word (Word8)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.FilePath ((</>))
import System.Random.Stateful
import Text.Printf (printf)

data FsException
  = FileDoesNotExist {file :: FilePath}
  | DirectoryDoesNotExist {dir :: FilePath}
  deriving (Exception)

instance Show FsException where
  show FileDoesNotExist {..} = printf "File '%s' does not exist" file
  show DirectoryDoesNotExist {..} = printf "Directory '%s' does not exist" dir

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

ensuredFile :: FilePath -> IO FilePath
ensuredFile pth = do
  exists <- doesFileExist pth
  if exists then pure pth else throwIO (FileDoesNotExist pth)

-- Recursively collect all file paths in provided directory
allPathsIn :: FilePath -> IO [FilePath]
allPathsIn dir = do
  exists <- doesDirectoryExist dir
  names <- if exists then listDirectory dir else throwIO (DirectoryDoesNotExist dir)
  let nested = map (dir </>) names
  paths <-
    forM
      nested
      ( \path -> do
          isDir <- doesDirectoryExist path
          if isDir
            then allPathsIn path
            else return [path]
      )
  return (concat paths)

btsToHex :: [Word8] -> String
btsToHex bts = intercalate "-" (map (printf "%02X") bts)

-- >>> 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 num = btsToHex (unpack (toLazyByteString (word64BE (doubleToWord num))))

-- >>> strToHex "hello"
-- "68-65-6C-6C-6F"
-- >>> strToHex "world"
-- "77-6F-72-6C-64"
strToHex :: String -> String
strToHex str = btsToHex (unpack (U.fromString str))

-- Fast Fisher-Yates with mutable vectors.
-- The function is generated by ChatGPT and claimed as
-- fastest approach comparing to usage IOArray.
-- >>> shuffle [1..20]
-- [20,5,6,1,12,10,7,8,9,11,14,15,13,2,4,16,3,19,18,17]
shuffle :: [a] -> IO [a]
shuffle xs = do
  gen <- newIOGenM =<< newStdGen
  let n = length xs
  v <- V.thaw (V.fromList xs) -- Mutable copy
  forM_ [n - 1, n - 2 .. 1] $ \i -> do
    j <- uniformRM (0, i) gen
    M.swap v i j
  V.toList <$> V.freeze v