module Database.HaskellDB.DBSpec.PPHelpers where
import Data.Char (toLower, toUpper, isAlpha, isAlphaNum, )
import Text.PrettyPrint.HughesPJ
newline = char '\n'
ppComment txt
= commentLine $$ vcat (map commentText txt) $$ commentLine
where
commentLine = text (replicate 75 '-')
commentText s = text ("-- " ++ s)
fileName name | not (elem '.' baseName) = name ++ ".hs"
| otherwise = name
where
baseName = reverse (takeWhile (/='\\') (reverse name))
data MakeIdentifiers =
MakeIdentifiers
{ moduleName, identifier, toType :: String -> String }
mkIdentPreserving =
MakeIdentifiers
{
moduleName = checkChars . checkUpper,
identifier = checkChars . checkKeyword . checkLower,
toType = checkChars . checkKeyword . checkUpper
}
mkIdentCamelCase =
MakeIdentifiers
{
moduleName = checkChars . toUpperCamelCase,
identifier = checkChars . checkKeyword . toLowerCamelCase,
toType = checkChars . checkKeyword . toUpperCamelCase
}
toLowerCamelCase s@(_:_) =
let (h : rest) = split ('_'==) $ dropWhile ('_'==) $ map toLower s
in concat $ checkLower h : map (checkUpperDef '_') rest
toLowerCamelCase [] =
error "toLowerCamelCase: identifier must be non-empty"
toUpperCamelCase s@(_:_) =
let (h : rest) = split ('_'==) $ dropWhile ('_'==) $ map toLower s
in concat $ checkUpper h : map (checkUpperDef '_') rest
toUpperCamelCase [] =
error "toUpperCamelCase: identifier must be non-empty"
split :: Eq a => (a -> Bool) -> [a] -> [[a]]
split p =
foldr (\ x yt@ ~(y:ys) -> (if p x then ([]:yt) else ((x:y):ys)) ) [[]]
checkChars s = map replace s
where
replace c | isAlphaNum c = c
| otherwise = '_'
checkKeyword s | elem s keywords = 'x' : s
| otherwise = s
where
keywords = [ "module", "where", "import"
, "infix", "infixr", "infixl"
, "type", "newtype", "data"
, "deriving"
, "class", "instance"
, "do", "return"
, "let", "in"
, "case", "of"
, "if", "then", "else"
, "id", "zip","baseTable"
]
checkUpper "" = error "Empty name from database?"
checkUpper s = checkUpperDef 'X' s
checkLower "" = error "Empty name from database?"
checkLower s = checkLowerDef 'x' s
checkUpperDef _ "" = ""
checkUpperDef d s@(x:xs)
| isAlpha x = toUpper x : xs
| otherwise = d : s
checkLowerDef _ "" = ""
checkLowerDef d s@(x:xs)
| isAlpha x = toLower x : xs
| otherwise = d : s