Tools.hs

module Yavie.Tools (

  const2
, const3
, const4
, const5
, addIfMinus

, ctrl2strN
, ctrl2str
, tab2spaceN
, tab2space

, inFromMToN
, zeroToN
, intoMToN
, intoNToM

, intoLargerEq

, strIndices

, lastIndex

, reverseXY
, findIndexXY
, takeXY
, dropXY

, opfs

, normalizeTwoDot
, mkAbsoluteFilePath

) where

import Data.List        ( isPrefixOf, isInfixOf, findIndex )
import Data.Char        ( isControl, ord )
import System.FilePath  ( normalise, combine )
import System.Directory ( getCurrentDirectory )
import Numeric          ( showHex )
import Text.RegexPR     ( gsubRegexPR )

const2 :: a -> b -> c -> a
const2 = const . const

const3 :: a -> b -> c -> d -> a
const3 = const . const . const

const4 :: a -> b -> c -> d -> e -> a
const4 = const . const . const . const

const5 :: a -> b -> c -> d -> e -> f -> a
const5 = const . const . const . const . const

addIfMinus :: ( Num a, Ord a ) => a -> a -> a
addIfMinus a x | x < 0     = x + a
               | otherwise = x


isCtrl :: Char -> Bool
isCtrl c = isControl c && ( c /= '\t' )

ctrl2str :: String -> String
ctrl2str ""     = ""
ctrl2str ( c : cs )
  | isCtrl c  = '\\' : showHex2 ( ord c ) ++ ctrl2str cs
  | otherwise = c : ctrl2str cs
  where
  showHex2 n = let s = showHex n "" in replicate ( 2 - length s ) '0' ++ s

ctrl2strN :: String -> Int -> Int
ctrl2strN _          0 = 0
ctrl2strN ""         n = n
ctrl2strN ( c : cs ) n
  | isCtrl c  = 3 + ctrl2strN cs ( n - 1 )
  | otherwise = 1 + ctrl2strN cs ( n - 1 )

tab2spaceN :: String -> Int -> Int
tab2spaceN = t2sn 8

t2sn :: Int -> String -> Int -> Int
t2sn _ _             0 = 0
t2sn _ ""            n = n
t2sn i ( '\t' : cs ) n = i + t2sn 8 cs ( n - 1 )
t2sn i ( _    : cs ) n
  | i > 1     = 1 + t2sn ( i - 1 ) cs ( n - 1 )
  | otherwise = 1 + t2sn 8         cs ( n - 1 )

tab2space :: String -> String
tab2space = t2s 8

t2s :: Int -> String -> String
t2s _ ""            = ""
t2s i ( '\t' : cs ) = replicate i ' ' ++ t2s 8 cs
t2s i ( c    : cs )
  | i > 1           = c : t2s ( i - 1 ) cs
  | otherwise       = c : t2s 8         cs

zeroToN :: ( Num a, Ord a ) => a -> a -> a
zeroToN n x | x < 0 && 0 <= n          = 0
            |          0 <= n && n < x = n
            | x < n && n <  0          = n
            |          n <  0 && 0 < x = 0
            | otherwise = x

intoMToN :: ( Num a, Ord a ) => a -> a -> a -> a
intoMToN = intoNToM

intoNToM :: ( Num a, Ord a ) => a -> a -> a -> a
intoNToM n m x | x < n && n <= m          = n
               |          n <= m && m < x = m
               | x < m && m <  n          = m
               |          m <  n && n < x = n
               | otherwise                = x

intoLargerEq :: Ord a => a -> a -> a
intoLargerEq m n | n < m     = m
                 | otherwise = n

strIndices :: Eq a => [ a ] -> [ a ] -> [ Int ]
strIndices _   [ ]                = [ ]
strIndices str field@( _ : next )
  | str `isPrefixOf` field        = 0 : map (+ 1) ( strIndices str next )
  | otherwise                     =     map (+ 1) ( strIndices str next )

inFromMToN :: ( Num a, Ord a ) => a -> a -> a -> a
inFromMToN m n x
  |          m <= n && n < x = n
  | x < m && m <= n          = m
  |          m <= n          = x
  | otherwise                = error "inFromMToN: need m <= n"

lastIndex :: [ a ] -> Int
lastIndex = (+ (-1)) . length

reverseXY :: [ [ a ] ] -> [ [ a ] ]
reverseXY = map reverse . reverse

findIndexXY :: ( a -> Bool ) -> [ [ a ] ] -> Maybe ( Int, Int )
findIndexXY _ [ ]          = Nothing
findIndexXY p ( ln : lns ) =
  case ( findIndex p ln, findIndexXY p lns ) of
       ( Just i, _             ) -> Just ( i, 0     )
       ( _     , Just ( x, y ) ) -> Just ( x, y + 1 )
       _                         -> Nothing

takeXY, dropXY :: Int -> Int -> [ [ a ] ] -> [ [ a ] ]
takeXY xx yy ll = take yy ll ++ [ take xx ( ll !! yy ) ]
dropXY xx yy ll = drop xx ( ll !! yy ) : drop ( yy + 1 ) ll

opfs ::
  ( a -> b -> c ) -> ( a' -> b' -> c' ) -> ( a, a' ) -> ( b, b' ) -> ( c, c' )
opfs opf ops ( x, y ) ( x', y' ) = ( x `opf` x', y `ops` y' )

normalizeTwoDot :: FilePath -> FilePath
normalizeTwoDot fp 
  | ".." `isInfixOf` fp = normalizeTwoDot $ gsubRegexPR "/[^/]+/\\.\\./" "/" fp
  | otherwise           = fp

mkAbsoluteFilePath :: FilePath -> IO FilePath
mkAbsoluteFilePath fp = do
  cd <- getCurrentDirectory
  return $ normalizeTwoDot $ normalise $ cd `combine` fp