{-# OPTIONS -fglasgow-exts #-}
-- We need an instance String

module Stringalike (Stringalike(..)) where

import Numeric ( readHex )
import Data.Char ( chr, isHexDigit )
import FileName ( FileName, ps2fn, fp2fn )
import FastPackedString ( PackedString, packString, unpackPS,
                          nilPS, nullPS, lengthPS, reversePS, indexPS,
                          appendPS, concatPS, headPS, tailPS, initPS, lastPS,
                          takePS, dropPS, dropWhilePS, dropWhitePS,
                          breakPS, breakFirstPS, breakLastPS, breakOnPS,
                          breakWhitePS, readIntPS, fromHex2PS, )

class Stringalike s where
    sal_empty :: s
    sal_null :: s -> Bool
    sal_head :: s -> Char
    sal_last :: s -> Char
    sal_tail :: s -> s
    sal_take :: Int -> s -> s
    sal_drop :: Int -> s -> s
    sal_reverse :: s -> s
    sal_concat :: [s] -> s
    sal_length :: s -> Int
    sal_index :: s -> Int -> Char
    sal_dropWhile :: (Char -> Bool) -> s -> s
    sal_dropWhite :: s -> s
    sal_breakWhite :: s -> (s, s)
    sal_readInt :: s -> Maybe (Int, s)
    sal_break :: (Char -> Bool) -> s -> (s, s)
    sal_breakFirst :: Char -> s -> Maybe (s, s)
    sal_breakFirst c xs = case sal_breakOn c xs of
                              (ys, zs)
                               | sal_null zs -> Nothing
                               | otherwise -> Just (ys, sal_tail zs)
    sal_breakLast :: Char -> s -> Maybe (s, s)
    sal_breakLast c xs = case sal_breakFirst c (sal_reverse xs) of
                             Nothing -> Nothing
                             Just (ys, zs) ->
                                 Just (sal_reverse zs, sal_reverse ys)
    sal_breakOn :: Char -> s -> (s, s)
    sal_breakOn c = sal_break (c ==)
    sal_to_string :: s -> String
    sal_to_PS :: s -> PackedString
    sal_fromHex :: s -> s
    sal_to_fn :: s -> FileName

instance Stringalike String where
    sal_empty = ""
    sal_null = null
    sal_head = head
    sal_last = last
    sal_tail = tail
    sal_take = take
    sal_drop = drop
    sal_reverse = reverse
    sal_concat = concat
    sal_length = length
    sal_index = (!!)
    sal_dropWhile = dropWhile
    sal_dropWhite = dropWhile (`elem` " \n\t\r")
    sal_breakWhite = break (`elem` " \n\t\r")
    sal_readInt xs = case reads xs of
                         [(n, s')] -> Just (n, s')
                         _ -> Nothing
    sal_break = break
    sal_to_string = id
    sal_to_PS = packString
    sal_fromHex "" = ""
    sal_fromHex [_] = "" -- Should this be an error?
    sal_fromHex all_cs@(c1:c2:cs)
        = case readHex [c1, c2] of
              [(n, "")] -> chr n:sal_fromHex cs
              _ -> error ("Bad hex characters: " ++ all_cs)
    sal_to_fn = fp2fn

instance Stringalike PackedString where
    sal_empty = nilPS
    sal_null = nullPS
    sal_head = headPS
    sal_last = lastPS
    sal_tail = tailPS
    sal_take = takePS
    sal_drop = dropPS
    sal_reverse = reversePS
    sal_concat = concatPS
    sal_length = lengthPS
    sal_index = indexPS
    sal_dropWhile = dropWhilePS
    sal_dropWhite = dropWhitePS
    sal_breakWhite = breakWhitePS
    sal_readInt = readIntPS
    sal_break = breakPS
    sal_breakFirst = breakFirstPS
    sal_breakLast = breakLastPS
    sal_breakOn = breakOnPS
    sal_to_string = unpackPS
    sal_to_PS = id
    sal_fromHex = fromHex2PS
    sal_to_fn = ps2fn

-- Invariant: nullPS `notElem`
instance Stringalike [PackedString] where
    sal_empty = []
    sal_null = null
    sal_head (ps:_) = headPS ps
    sal_head [] = error "sal_head []"
    sal_last (ps:pss)
     | null pss = lastPS ps
     | otherwise = sal_last pss
    sal_last [] = error "sal_last []"
    sal_tail (ps:pss)
     | lengthPS ps == 1 = pss
     | otherwise = tailPS ps:pss
    sal_tail [] = error "sal_tail []"
    sal_take _ [] = []
    sal_take 0 _ = []
    sal_take n (ps:pss)
     | n <= lengthPS ps = [takePS n ps]
     | otherwise = ps:sal_take (n - lengthPS ps) pss
    sal_drop _ [] = []
    sal_drop n (ps:pss)
     | n == lengthPS ps = pss
     | n < lengthPS ps = dropPS n ps:pss
     | otherwise = sal_drop (n - lengthPS ps) pss
    sal_reverse = reverse . map reversePS
    sal_concat = concat
    sal_length = sum . map lengthPS
    sal_index [] _ = error "sal_index []"
    sal_index (ps:pss) n
     | n < lengthPS ps = indexPS ps n
     | otherwise = sal_index pss (n - lengthPS ps)
    sal_dropWhile _ [] = []
    sal_dropWhile f (ps:pss) = let ps' = dropWhilePS f ps
                               in if nullPS ps'
                                  then sal_dropWhile f pss
                                  else ps':pss
    sal_dropWhite [] = []
    sal_dropWhite (ps:pss) = let ps' = dropWhitePS ps
                             in if nullPS ps'
                                then sal_dropWhite pss
                                else ps':pss
    sal_breakWhite [] = ([], [])
    sal_breakWhite (ps:pss) = case breakWhitePS ps of
                              (xs, ys)
                               | nullPS ys -> case sal_breakWhite pss of
                                              (xs', ys') -> (xs:xs', ys')
                               | nullPS xs -> ([], ys:pss)
                               | otherwise -> ([xs], ys:pss)
    sal_readInt pss = case sal_break f $ sal_dropWhite pss of
                      (xs, ys) -> case readIntPS (concatPS (xs ++ [nulPS])) of
                                  Just (n, ys')
                                   | len == 0 -> error "readIntPS lost NUL!"
                                   | len == 1 -> Just (n, ys)
                                   | otherwise -> Just (n, initPS ys':ys)
                                      where len = lengthPS ys'
                                  Nothing -> Nothing
        where f c | isHexDigit c = False
              f '+' = False
              f '-' = False
              f 'x' = False
              f _ = True
              nulPS = packString "\NUL"
    sal_break _ [] = ([], [])
    sal_break f (ps:pss) = case breakPS f ps of
                           (xs, ys)
                            | nullPS ys -> case sal_break f pss of
                                           (xs', ys') -> (xs:xs', ys')
                            | nullPS xs -> ([], ys:pss)
                            | otherwise -> ([xs], ys:pss)
    sal_to_string = concat . map unpackPS
    sal_to_PS = concatPS
    sal_fromHex [] = []
    sal_fromHex [ps]
     | lengthPS ps == 1 = [] -- Should this be an error?
    sal_fromHex (ps1:ps2:pss)
     | lengthPS ps1 == 1 = sal_fromHex (appendPS ps1 ps2):pss
    sal_fromHex (ps:pss)
     | odd (lengthPS ps) = sal_fromHex (initPS ps:packString [lastPS ps]:pss)
     | otherwise = fromHex2PS ps:sal_fromHex pss
    sal_to_fn = ps2fn . concatPS