-- Determine whether a file name is a valid Windows file name.  Doesn't check
-- for a name clash caused by Windows' case-insensitivity.
--
-- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
--
-- This code is in the public domain.

import List ( findIndex, find )
import Maybe ( isJust )
import Char ( toLower, ord )

type ErrorReason = String

-- Pass in the file name (*not* the full path).  If the function returns
-- 'Just s', then the file name violates one of Windows' file naming rules
-- and the string 's' contains a short description of what's wrong with
-- the string.

checkWindowsFileName :: String -> Maybe ErrorReason
checkWindowsFileName n = result
	where
		-- Run all the checking functions and store their results in a list.
		results = map ($ n) checkFuncs
		-- Then, take the first error off the list.
		result = findDef isJust Nothing results

checkFuncs :: [String -> Maybe ErrorReason]
checkFuncs = [checkForBadChars, checkForReservedName, checkTrailingChar]

-- Find a value in a list (if not found, return the default value)

findDef :: (a -> Bool) -> a -> [a] -> a
findDef pred def []   = def
findDef pred def (e:es) = if pred e then e else findDef pred def es

-- Check for bad characters

isValidChar :: Char -> Bool
isValidChar c = (ord c >= 31) && not (c `elem` "<>:\"/\\|")

checkForBadChars n =
	case findIndex (not . isValidChar) n of
		Nothing -> Nothing
		Just i -> Just $ "file name contains an invalid character ("++[n!!i]++") at index "++(show i)

-- Check for one of the reserved device names

reservedNames = ["con", "prn", "aux", "nul",
				     "com1", "com2", "com3", "com4", "com5", "com6", "com7", "com8", "com9",
				     "lpt1", "lpt2", "lpt3", "lpt4", "lpt5", "lpt6", "lpt7", "lpt8", "lpt9",
					  "clock$" ]

checkForReservedName n =
	if lcased `elem` reservedNames
		then Just "file name clashes with a Windows reserved file name"
		else Nothing
	where
		-- Take everything up to the first '.'
		front = takeWhile (/= '.') n
		-- Remove trailing spaces
		trimmed = reverse (dropWhile (== ' ') $ reverse front)
		-- Convert to lower case for device name comparison
		lcased = map toLower trimmed

-- Make sure it doesn't end in a space or dot

checkTrailingChar n = case reverse n of
	[] -> Just "file name cannot be zero-length"
	last:_ -> if last == ' ' || last == '.'
		then Just "file name cannot end in a space or dot"
		else Nothing