PPHelpers.hs

-----------------------------------------------------------
-- |
-- Module      :  PPHelpers
-- Copyright   :  HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
-- License     :  BSD-style
--
-- Maintainer  :  haskelldb-users@lists.sourceforge.net
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Various functions used when pretty printing stuff
--
--
-----------------------------------------------------------
module Database.HaskellDB.DBSpec.PPHelpers where
-- no explicit export, we want ALL of it

import Data.Char (toLower, toUpper, isAlpha, isAlphaNum, )
import Text.PrettyPrint.HughesPJ

newline = char '\n'

-----------------------------------------------------------
-- Comment that looks like this
-----------------------------------------------------------
ppComment txt
	= commentLine $$ vcat (map commentText txt) $$ commentLine
	where
	  commentLine	= text (replicate 75 '-')
	  commentText s	= text ("-- " ++ s)

-----------------------------------------------------------
-- Create valid Names
-----------------------------------------------------------
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"

{- |
Generalization of 'words' and 'lines' to any separating character set.
-}
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 -- isDigit?

checkLowerDef _ ""      = ""
checkLowerDef d s@(x:xs)
			| isAlpha x	= toLower x : xs
			| otherwise	= d : s -- isDigit?