-- module FilePath where
import Data.Word (Word8)

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Error


import System (getArgs)
main = 
 do [s,t] <- getArgs 
    let p  = parsePath s
        p' = parsePath t
    putStrLn $ unixPathShow (pathExtend p "myextradirectory")
    putStrLn $ unixPathShow p'
    putStrLn $ unixPathShow $ unixPathCleanup (pathAppend p p')


data CharEncoding 
   = USASCII
   | ISO_8859_1
   | UnknownEncoding
 deriving (Eq,Ord,Show)

class (Show p) => Path p where
  isAbsolute :: p -> Bool
  isRelative  :: p -> Bool
  isRelative = not . isAbsolute
  basename :: p -> String
  parent :: p -> p
  pathAppend :: p -> p -> p
  pathExtend :: p -> String -> p
  pathSeparator :: p -> Char
  pathParser :: Parser p  
  parsePath :: String -> p
  parsePath x = 
     case parse pathParser "" x of
       Left e  -> error $ show e
       Right x -> x

-- unix path segments are arbitrary sequences of 
-- octects EXCEPT that they must not contain
-- any octets with value 0x2F (forward slash char)
type UnixPathSeg = [Word8]

-- path segments are stored stack-like, with
-- the root of the path at the end of the list
-- INVARIANT the path list is not empty
data UnixPath 
   = UnixAbsPath CharEncoding [UnixPathSeg]
   | UnixRelPath CharEncoding [UnixPathSeg]
 deriving (Eq,Ord)

unixPathSeparator :: Char
unixPathSeparator = '/'

unixCurrentDirSeg :: UnixPathSeg
unixCurrentDirSeg = map (fromIntegral . fromEnum) "."

unixParentDirSeg :: UnixPathSeg
unixParentDirSeg = map (fromIntegral . fromEnum) ".."

showUnixPathSeg :: CharEncoding -> UnixPathSeg -> String
showUnixPathSeg USASCII seg    = map (toEnum . fromIntegral) seg
showUnixPathSeg ISO_8859_1 seg = map (toEnum . fromIntegral) seg
showUnixPathSeg enc _ = error ("Cannot lineralize a UNIX path with encoding: "++(show enc))

unixPathShow :: UnixPath -> String
unixPathShow (UnixAbsPath enc segs) = foldl (\p s -> unixPathSeparator : (showUnixPathSeg enc s) ++ p) "" segs
unixPathShow (UnixRelPath enc segs) = tail $ foldl (\p s -> (unixPathSeparator : (showUnixPathSeg enc s)) ++ p) "" segs

unixPathIsAbsolute :: UnixPath -> Bool
unixPathIsAbsolute (UnixAbsPath _ _) = True
unixPathIsAbsolute _ = False

unixPathBasename :: UnixPath -> String
unixPathBasename (UnixAbsPath enc (s:_)) = showUnixPathSeg enc s
unixPathBasename (UnixRelPath enc (s:_)) = showUnixPathSeg enc s

unixPathParents :: Int -> UnixPath -> UnixPath

unixPathParents 0 x = x

-- relative paths
unixPathParents n (UnixRelPath enc [x])
    | x == unixParentDirSeg  = UnixRelPath enc (take (n+1) $ repeat unixParentDirSeg)
    | x == unixCurrentDirSeg = UnixRelPath enc (take n     $ repeat unixParentDirSeg)
    | n <= 1                 = UnixRelPath enc [unixCurrentDirSeg]
    | otherwise              = UnixRelPath enc (take (n-1) $ repeat unixParentDirSeg)
unixPathParents n (UnixRelPath enc (x:xs))
    | x == unixParentDirSeg  = unixPathParents (n+1) (UnixRelPath enc xs)
    | x == unixCurrentDirSeg = unixPathParents n     (UnixRelPath enc xs)
    | otherwise              = unixPathParents (n-1) (UnixRelPath enc xs)

-- absolute paths
unixPathParents n (UnixAbsPath enc [x]) = UnixRelPath enc [unixCurrentDirSeg]
unixPathParents n (UnixAbsPath enc (x:xs))
    | x == unixParentDirSeg  = unixPathParents (n+1) (UnixAbsPath enc xs)
    | x == unixCurrentDirSeg = unixPathParents n     (UnixAbsPath enc xs)
    | otherwise              = unixPathParents (n-1) (UnixAbsPath enc xs)     

unixPathAppend :: UnixPath -> UnixPath -> UnixPath
unixPathAppend (UnixAbsPath xenc xs) (UnixRelPath yenc ys)
  | xenc == yenc = UnixAbsPath xenc (ys++xs)
  | otherwise    = error $ "cannot append UNIX  paths with different encodings "++(show xenc)++", "++(show yenc)
unixPathAppend (UnixRelPath xenc xs) (UnixRelPath yenc ys)
  | xenc == yenc = UnixRelPath xenc (ys++xs)
  | otherwise    = error $ "cannot append UNIX  paths with different encodings "++(show xenc)++", "++(show yenc)
unixPathAppend _ (UnixAbsPath _ _) = error "cannot append an absolute path on the right"

unixPathParent :: UnixPath -> UnixPath
unixPathParent = unixPathParents 1

unixPathSegClean :: Bool -> Int -> [UnixPathSeg] -> [UnixPathSeg]
unixPathSegClean isAbs n l@(x:xs) =
  let l'  = if x == unixCurrentDirSeg
               then x : clean n xs
               else clean n l
      l'' = if null l' 
               then [unixCurrentDirSeg]
               else l'
  in l''

 where clean n [] = if isAbs 
		       then [] 
		       else take n $ repeat unixParentDirSeg
       clean n (x:xs)
        | x == unixCurrentDirSeg  = clean n     xs
        | x == unixParentDirSeg   = clean (n+1) xs
        | n > 0                   = clean (n-1) xs
        | otherwise               = x : clean n xs


unixPathCleanup :: UnixPath -> UnixPath
unixPathCleanup (UnixAbsPath enc l) = 
    UnixAbsPath enc (unixPathSegClean True 0 l)

unixPathCleanup (UnixRelPath enc l) = 
    UnixRelPath enc (unixPathSegClean False 0 l)


--unixPathOctetParser :: GenParser Word8 UnixPath

-- only works for single byte encodings (ascii and latin-1)
-- someday we will have real character encodings...
unixPathSegParser :: Parser UnixPathSeg
unixPathSegParser = do seg <- many (noneOf [unixPathSeparator])
                       return (map (fromIntegral . fromEnum) seg)

unixPathParser :: Parser UnixPath
unixPathParser =
  (do try (char unixPathSeparator)
      segs <- parseSegments
      return (UnixAbsPath USASCII (reverse segs))
  )
  <|>
  (do segs <- parseSegments 
      return (UnixRelPath USASCII (reverse segs)))

 where parseSegments 
	   = (flip sepBy1) (char unixPathSeparator) 
              (do seg <- unixPathSegParser
                  return $ if null seg then unixCurrentDirSeg else seg
	      )

unixPathAddSegment :: UnixPath -> UnixPathSeg -> UnixPath
unixPathAddSegment (UnixAbsPath enc l) s = UnixAbsPath enc (s:l)
unixPathAddSegment (UnixRelPath enc l) s = UnixRelPath enc (s:l)

unixPathExtend :: UnixPath -> String -> UnixPath
unixPathExtend p str =
  let seg = case parse unixPathSegParser "" str of
                  Left e  -> error (show e)
                  Right s -> s

  in unixPathAddSegment p seg

instance Show UnixPath where
  show = unixPathShow

instance Path UnixPath where
  isAbsolute      = unixPathIsAbsolute
  basename        = unixPathBasename
  parent          = unixPathParent   
  pathSeparator _ = unixPathSeparator
  pathParser      = unixPathParser  
  pathExtend      = unixPathExtend
  pathAppend      = unixPathAppend

--data FilePath 
--   = UnixPath UnixPath
--   | DOSPath DOSPath
--   | WinPath WinPath
--   | SMBPath SMBPath
-- deriving (Eq,Ord)