Here is my first cut at this. The unix implementation mostly works, the
windows one just has some datatypes sketched out, but it typechecks.
-- 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)
import Data.Word (Word16)
-- Note : calls into the Win32 API using this
-- FilePath representation must use the unicode
-- versions of functions
-- everything in WCHAR unicode
-- cannot contain the characters
-- '<' '>' ':' '"' '/' '\' '|'
type WinPathSeg = [Word16]
-- type WinPathSeg = String -- would work if Haskell strings
-- _actually_ supported unicode
type GUID = WinPathSeg -- perhaps should be something else ?
data WinCommDevice
= CON | PRN | AUX | NUL
| COM1 | COM2 | COM3 | COM4
| COM5 | COM6 | COM7 | COM8
| COM9 | LPT1 | LPT2 | LPT3
| LPT4 | LPT5 | LPT6 | LPT7
| LPT8 | LPT9 | CLOCK_DOLLAR
deriving (Eq,Ord)
data MailslotDest
= MailslotDestLocalhost
| MailslotDestNamed WinPathSeg
| MailslotDestWildcard
deriving (Eq,Ord)
-- INVARIANT the path list is never empty
data WinPath -- drive path NTFS filestream name and type
= WinAbsPath (Maybe Char) [WinPathSeg] (Maybe (WinPathSeg,WinPathSeg))
| WinRelPath (Maybe Char) [WinPathSeg] (Maybe (WinPathSeg,WinPathSeg))
| WinPhysicalPath Int
| WinVolumePath (Either Char GUID)
| WinTapePath Int
| WinCommPath WinCommDevice
| WinMailslotPath MailslotDest [WinPathSeg]
| WinNamedPipePath WinPathSeg
deriving (Eq,Ord)
winPathSeparator :: Char
winPathSeparator = '\\'
winCurrentDirSeg :: WinPathSeg
winCurrentDirSeg = map (fromIntegral . fromEnum) "."
winParentDirSeg :: WinPathSeg
winParentDirSeg = map (fromIntegral . fromEnum) ".."
showWinCommDevice :: WinCommDevice -> String
showWinCommDevice CON = "CON"
showWinCommDevice PRN = "PRN"
showWinCommDevice AUX = "AUX"
showWinCommDevice NUL = "NUL"
showWinCommDevice COM1 = "COM1"
showWinCommDevice COM2 = "COM2"
showWinCommDevice COM3 = "COM3"
showWinCommDevice COM4 = "COM4"
showWinCommDevice COM5 = "COM5"
showWinCommDevice COM6 = "COM6"
showWinCommDevice COM7 = "COM7"
showWinCommDevice COM8 = "COM8"
showWinCommDevice COM9 = "COM9"
showWinCommDevice LPT1 = "LPT1"
showWinCommDevice LPT2 = "LPT2"
showWinCommDevice LPT3 = "LPT3"
showWinCommDevice LPT4 = "LPT4"
showWinCommDevice LPT5 = "LPT5"
showWinCommDevice LPT6 = "LPT6"
showWinCommDevice LPT7 = "LPT7"
showWinCommDevice LPT8 = "LPT8"
showWinCommDevice LPT9 = "LPT9"
showWinCommDevice CLOCK_DOLLAR = "CLOCK$"
showMailslotDest :: MailslotDest -> String
showMailslotDest MailslotDestLocalhost = "."
showMailslotDest MailslotDestWildcard = "*"
showMailslotDest (MailslotDestNamed x) = showWinPathSeg x
showWinPathSeg :: WinPathSeg -> String
showWinPathSeg = map (toEnum . fromIntegral)
showWinPath :: WinPath -> String
showWinPath (WinAbsPath drive segs streamname) =
let driveStr = case drive of
Nothing -> ""
Just c -> c : ":"
pathStr = foldl (\p s -> winPathSeparator : (showWinPathSeg s) ++ p) "" segs
streamStr = case streamname of
Nothing -> ""
Just (n,t) -> concat [":",showWinPathSeg n
,":",showWinPathSeg t]
in concat [driveStr,pathStr,streamStr]
showWinPath (WinRelPath drive segs streamname) =
let driveStr = case drive of
Nothing -> ""
Just c -> c : ":"
pathStr = tail $ foldl (\p s -> winPathSeparator : (showWinPathSeg s) ++ p) "" segs
streamStr = case streamname of
Nothing -> ""
Just (n,t) -> concat [":",showWinPathSeg n
,":",showWinPathSeg t]
in concat [driveStr,pathStr,streamStr]
showWinPath (WinPhysicalPath n)
= "\\\\.\\PHYSICALDRIVE"++(show n)
showWinPath (WinVolumePath (Left c))
= "\\\\.\\"++[c]++"\\"
showWinPath (WinVolumePath (Right guid))
= "\\\\?\\Volume{"++(showWinPathSeg guid)++"}\\"
showWinPath (WinTapePath n)
= "\\\\.\\TAPE"++(show n)
showWinPath (WinCommPath d) = show d
showWinPath (WinMailslotPath m segs) =
let path = foldl (\p s -> winPathSeparator : (showWinPathSeg s) ++ p) "" segs
in concat ["\\\\",show m,"\\mailslot",path]
showWinNamedPipePath (WinNamedPipePath p)
= "\\\\.\\pipe\\"++(showWinPathSeg p)
instance Show WinPath where show = showWinPath
instance Show WinCommDevice where show = showWinCommDevice
instance Show MailslotDest where show = showMailslotDest_______________________________________________
Haskell-Cafe mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/haskell-cafe
