<commit_before>-----------------------------------------------------------------------------
-- $Id: DriverUtil.hs,v 1.41 2003/11/17 14:41:03 simonmar Exp $
--
-- Utils for the driver
--
-- (c) The University of Glasgow 2000
--
-----------------------------------------------------------------------------

module DriverUtil (
	getOptionsFromSource, softGetDirectoryContents,
	createDirectoryHierarchy, doesDirNameExist, prefixUnderscore,
	unknownFlagErr, unknownFlagsErr, missingArgErr, 
	later, handleDyn, handle,
	split, add, addNoDups, 
	Suffix, splitFilename, getFileSuffix,
	splitFilename3, remove_suffix, split_longest_prefix,
	replaceFilenameSuffix, directoryOf, replaceFilenameDirectory,
	remove_spaces, escapeSpaces,
  ) where

#include "../includes/config.h"
#include "HsVersions.h"

import Util
import Panic
import Config		( cLeadingUnderscore )

import EXCEPTION	( Exception(..), finally, throwDyn, catchDyn, throw )
import qualified EXCEPTION as Exception
import DYNAMIC
import DATA_IOREF	( IORef, readIORef, writeIORef )

import Directory
import IO
import List
import Char
import Monad

-----------------------------------------------------------------------------
-- Reading OPTIONS pragmas

getOptionsFromSource 
	:: String		-- input file
	-> IO [String]		-- options, if any
getOptionsFromSource file
  = do h <- openFile file ReadMode
       catchJust ioErrors (look h `finally` hClose h)
	  (\e -> if isEOFError e then return [] else ioError e)
  where

	look h = do
	    l' <- hGetLine h
	    let l = remove_spaces l'
	    case () of
		() | null l -> look h
		   | prefixMatch "#" l -> look h
		   | prefixMatch "{-# LINE" l -> look h   -- -}
		   | Just opts <- matchOptions l
			-> do rest <- look h
                              return (words opts ++ rest)
		   | otherwise -> return []

matchOptions s
  | Just s1 <- maybePrefixMatch "{-#" s, -- -}
    Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1),
    Just s3 <- maybePrefixMatch "}-#" (reverse s2)
  = Just (reverse s3)
  | otherwise
  = Nothing

-----------------------------------------------------------------------------
-- A version of getDirectoryContents that is non-fatal if the
-- directory doesn't exist.

softGetDirectoryContents d
   = IO.catch (getDirectoryContents d)
	  (\_ -> do hPutStrLn stderr 
		          ("WARNING: error while reading directory " ++ d)
		    return []
	  )

-----------------------------------------------------------------------------
-- Create a hierarchy of directories

createDirectoryHierarchy :: FilePath -> IO ()
createDirectoryHierarchy dir = do
  b <- doesDirectoryExist dir
  when (not b) $ do
	createDirectoryHierarchy (directoryOf dir)
	createDirectory dir

-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
-- 
doesDirNameExist :: FilePath -> IO Bool
doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)

-----------------------------------------------------------------------------
-- Prefixing underscore to linker-level names
prefixUnderscore :: String -> String
prefixUnderscore
 | cLeadingUnderscore == "YES" = ('_':)
 | otherwise                   = id

-----------------------------------------------------------------------------
-- Utils

unknownFlagErr :: String -> a
unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))

unknownFlagsErr :: [String] -> a
unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))

missingArgErr :: String -> a
missingArgErr f = throwDyn (UsageError ("missing argument for flag: " ++ f))

later = flip finally

handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
handleDyn = flip catchDyn

handle :: (Exception -> IO a) -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 501
handle = flip Exception.catchAllIO
#else
handle h f = f `Exception.catch` \e -> case e of
    ExitException _ -> throw e
    _               -> h e
#endif

split :: Char -> String -> [String]
split c s = case rest of
		[]     -> [chunk] 
		_:rest -> chunk : split c rest
  where (chunk, rest) = break (==c) s

add :: IORef [a] -> a -> IO ()
add var x = do
  xs <- readIORef var
  writeIORef var (x:xs)

addNoDups :: Eq a => IORef [a] -> a -> IO ()
addNoDups var x = do
  xs <- readIORef var
  unless (x `elem` xs) $ writeIORef var (x:xs)

------------------------------------------------------
--		Filename manipulation
------------------------------------------------------
		
type Suffix = String

splitFilename :: String -> (String,Suffix)
splitFilename f = split_longest_prefix f (=='.')

getFileSuffix :: String -> Suffix
getFileSuffix f = drop_longest_prefix f (=='.')

-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
splitFilenameDir :: String -> (String,String)
splitFilenameDir str
  = let (dir, rest) = split_longest_prefix str isPathSeparator
  	real_dir | null dir  = "."
		 | otherwise = dir
    in  (real_dir, rest)

-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
splitFilename3 :: String -> (String,String,Suffix)
splitFilename3 str
   = let (dir, rest) = split_longest_prefix str isPathSeparator
	 (name, ext) = splitFilename rest
	 real_dir | null dir  = "."
		  | otherwise = dir
     in  (real_dir, name, ext)

remove_suffix :: Char -> String -> Suffix
remove_suffix c s
  | null pre  = reverse suf
  | otherwise = reverse pre
  where (suf,pre) = break (==c) (reverse s)

drop_longest_prefix :: String -> (Char -> Bool) -> String
drop_longest_prefix s pred = reverse suf
  where (suf,_pre) = break pred (reverse s)

take_longest_prefix :: String -> (Char -> Bool) -> String<commit_msg>[project @ 2004-06-24 09:35:13 by simonmar] Tiny perf improvement<commit_after>-----------------------------------------------------------------------------
-- $Id: DriverUtil.hs,v 1.42 2004/06/24 09:35:13 simonmar Exp $
--
-- Utils for the driver
--
-- (c) The University of Glasgow 2000
--
-----------------------------------------------------------------------------

module DriverUtil (
	getOptionsFromSource, softGetDirectoryContents,
	createDirectoryHierarchy, doesDirNameExist, prefixUnderscore,
	unknownFlagErr, unknownFlagsErr, missingArgErr, 
	later, handleDyn, handle,
	split, add, addNoDups, 
	Suffix, splitFilename, getFileSuffix,
	splitFilename3, remove_suffix, split_longest_prefix,
	replaceFilenameSuffix, directoryOf, replaceFilenameDirectory,
	remove_spaces, escapeSpaces,
  ) where

#include "../includes/config.h"
#include "HsVersions.h"

import Util
import Panic
import Config		( cLeadingUnderscore )

import EXCEPTION	( Exception(..), finally, throwDyn, catchDyn, throw )
import qualified EXCEPTION as Exception
import DYNAMIC
import DATA_IOREF	( IORef, readIORef, writeIORef )

import Directory
import IO
import List
import Char
import Monad

-----------------------------------------------------------------------------
-- Reading OPTIONS pragmas

getOptionsFromSource 
	:: String		-- input file
	-> IO [String]		-- options, if any
getOptionsFromSource file
  = do h <- openFile file ReadMode
       catchJust ioErrors (look h `finally` hClose h)
	  (\e -> if isEOFError e then return [] else ioError e)
  where

	look h = do
	    l' <- hGetLine h
	    let l = remove_spaces l'
	    case () of
		() | null l -> look h
		   | prefixMatch "#" l -> look h
		   | prefixMatch "{-# LINE" l -> look h   -- -}
		   | Just opts <- matchOptions l
			-> do rest <- look h
                              return (words opts ++ rest)
		   | otherwise -> return []

matchOptions s
  | Just s1 <- maybePrefixMatch "{-#" s, -- -}
    Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1),
    Just s3 <- maybePrefixMatch "}-#" (reverse s2)
  = Just (reverse s3)
  | otherwise
  = Nothing

-----------------------------------------------------------------------------
-- A version of getDirectoryContents that is non-fatal if the
-- directory doesn't exist.

softGetDirectoryContents d
   = IO.catch (getDirectoryContents d)
	  (\_ -> do hPutStrLn stderr 
		          ("WARNING: error while reading directory " ++ d)
		    return []
	  )

-----------------------------------------------------------------------------
-- Create a hierarchy of directories

createDirectoryHierarchy :: FilePath -> IO ()
createDirectoryHierarchy dir = do
  b <- doesDirectoryExist dir
  when (not b) $ do
	createDirectoryHierarchy (directoryOf dir)
	createDirectory dir

-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
-- 
doesDirNameExist :: FilePath -> IO Bool
doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)

-----------------------------------------------------------------------------
-- Prefixing underscore to linker-level names
prefixUnderscore :: String -> String
prefixUnderscore
 | cLeadingUnderscore == "YES" = ('_':)
 | otherwise                   = id

-----------------------------------------------------------------------------
-- Utils

unknownFlagErr :: String -> a
unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))

unknownFlagsErr :: [String] -> a
unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))

missingArgErr :: String -> a
missingArgErr f = throwDyn (UsageError ("missing argument for flag: " ++ f))

later = flip finally

handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
handleDyn = flip catchDyn

handle :: (Exception -> IO a) -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 501
handle = flip Exception.catchAllIO
#else
handle h f = f `Exception.catch` \e -> case e of
    ExitException _ -> throw e
    _               -> h e
#endif

split :: Char -> String -> [String]
split c s = case rest of
		[]     -> [chunk] 
		_:rest -> chunk : split c rest
  where (chunk, rest) = break (==c) s

add :: IORef [a] -> a -> IO ()
add var x = do
  xs <- readIORef var
  writeIORef var (x:xs)

addNoDups :: Eq a => IORef [a] -> a -> IO ()
addNoDups var x = do
  xs <- readIORef var
  unless (x `elem` xs) $ writeIORef var (x:xs)

------------------------------------------------------
--		Filename manipulation
------------------------------------------------------
		
type Suffix = String

splitFilename :: String -> (String,Suffix)
splitFilename f = split_longest_prefix f (=='.')

getFileSuffix :: String -> Suffix
getFileSuffix f = drop_longest_prefix f (=='.')

-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
splitFilenameDir :: String -> (String,String)
splitFilenameDir str
  = let (dir, rest) = split_longest_prefix str isPathSeparator
  	real_dir | null dir  = "."
		 | otherwise = dir
    in  (real_dir, rest)

-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
splitFilename3 :: String -> (String,String,Suffix)
splitFilename3 str
   = let (dir, rest) = split_longest_prefix str isPathSeparator
	 (name, ext) = splitFilename rest
	 real_dir | null dir  = "."
		  | otherwise = dir
     in  (real_dir, name, ext)

remove_suffix :: Char -> String -> Suffix
remove_suffix c s
  | null pre  = s
  | otherwise = reverse pre
  where (suf,pre) = break (==c) (reverse s)

drop_longest_prefix :: String -> (Char -> Bool) -> String
drop_longest_prefix s pred = reverse suf
  where (suf,_pre) = break pred (reverse s)

take_longest_prefix :: String -> (Char -> Bool) -> String
{'fraction_non_alphanumeric': 0.23307268526746047, 'fraction_numerical': 0.007108583614714768, 'mean_word_length': 1.9933510638297873, 'pattern_counts': {'":': 0, '<': 25, '<?xml version=': 0, '>': 97, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6177889', 'n_tokens_mistral': 3426, 'n_tokens_neox': 3208, 'n_words': 1029}