module Main(main) where import System.Console.GetOpt import System.Environment import System.Directory import System.Exit import System.Cmd import System.FilePath import System.Random import System.IO import Control.Monad import Data.Maybe import Data.List import Data.Char import Data.Int {- WHAT TO DERIVE: To derive something we must write: data Foo = Foo deriving (Eq, Ord {-! Functor, Binary !-} ) Or if we don't want to derive other stuff: data Foo = Foo deriving ({-! Binary !-}) The (brackets) must be present, commas in derive list are required only to separate elements, but are permitted before or after. CONSOLE OPTIONS: -o file, which file should the code go in - no file defaults to the console -import, should an import statement be added -module name, should a module statement be added, and if so with what name -append, append the code to the current file (overrides all other flags) And a list of files to execute upon -} data Flag = Version | Help | Output String | Import String | Module String | Append | Derive [String] | KeepTemp | NoOpts deriving (Eq, Show) options :: [OptDescr Flag] options = [ Option "v" ["version"] (NoArg Version) "show version number" , Option "h?" ["help"] (NoArg Help) "show help message" , Option "o" ["output"] (ReqArg Output "FILE") "output FILE" , Option "i" ["import"] (OptArg (Import . fromMaybe "") "MODULE") "add an import statement" , Option "m" ["module"] (ReqArg Module "MODULE") "add a module MODULE where statement" , Option "a" ["append"] (NoArg Append) "append the result to the file" , Option "d" ["derive"] (ReqArg splt "DERIVES") "things to derive for all types" , Option "k" ["keep"] (NoArg KeepTemp) "keep temporary file" , Option "n" ["no-opts"] (NoArg NoOpts) "ignore the file options" ] where splt = Derive . words . map (\x -> if x == ',' then ' ' else x) getOpts :: IO ([Flag], [String]) getOpts = do args <- getArgs case getOpt Permute options args of (o,n,[] ) | Version `elem` o -> putStrLn "Derive 0.1, (C) Neil Mitchell & Stefan O'Rear 2006-2007" >> exitSuccess | Help `elem` o -> putStr useage >> exitSuccess | null n -> putStr ("no files specified\n" ++ useage) >> exitSuccess | otherwise -> return (o, n) (_,_,errs) -> putStr (concat errs ++ useage) >> exitFailure where useage = usageInfo "Usage: derive [OPTION...] files..." options exitSuccess = exitWith ExitSuccess main :: IO () main = do (flags,files) <- getOpts fles <- mapM pickFile files mapM_ (mainFile flags) (catMaybes fles) when (any isNothing fles) exitFailure pickFile :: FilePath -> IO (Maybe FilePath) pickFile orig = f [orig, orig <.> "hs", orig <.> "lhs"] where f [] = putStrLn ("Error, file not found: " ++ orig) >> return Nothing f (x:xs) = do b <- doesFileExist x if b then return $ Just x else f xs appendMsg :: String appendMsg = "--------------------------------------------------------\n" ++ "-- DERIVES GENERATED CODE\n" ++ "-- DO NOT MODIFY BELOW THIS LINE\n" ++ "-- CHECKSUM: " -- delete the end of a file with the appendMsg and a correct hash -- make sure there are at least 4 blank lines at the end -- return True for warning dropAppend :: String -> (String,Bool) dropAppend xs = f 0 xs where f i ys | appendMsg `isPrefixOf` ys = if hashString (filter (/= '\r') rest) == chk then f i [] else (ys ++ "\n\n\n\n", True) where (chk, rest) = span isDigit $ drop (length appendMsg) ys f i [] = (replicate (4 - i) '\n', False) f i ('\n':ys) = add '\n' (f (i+1) ys) f _ (y:ys) = add y (f 0 ys) add c ~(cs,b) = (c:cs,b) -- note: need to be careful that on Windows we don't convert \n files into -- \r\n files mainFile :: [Flag] -> FilePath -> IO () mainFile flags file = do file <- canonicalizePath file (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )" | (ctor,cls) <- reqs] let hscode x = "{-# OPTIONS_GHC -fth -fglasgow-exts -w #-}\n" ++ unlines pragmas ++ "module " ++ modname ++ " where\n" ++ "import Data.DeriveTH\n" ++ "import Data.Derive.All\n" ++ datas ++ "\n" ++ "main = Prelude.writeFile " ++ show x ++ " $\n" ++ " Prelude.unlines [" ++ concat (intersperse ", " devs) ++ "]\n" -- note: Wrong on Hugs on Windows tmpdir <- getTemporaryDirectory b <- doesDirectoryExist tmpdir tmpdr <- return $ if b && KeepTemp `notElem` flags then tmpdir else "" (hsfile, hshndl) <- openTempFileLocal tmpdr "Temp.hs" (txfile, txhndl) <- openTempFileLocal tmpdr "Temp.txt" hClose txhndl hPutStr hshndl $ hscode txfile hClose hshndl let incdir = dropTrailingPathSeparator $ joinPath $ reverse $ drop (1 + length (filter (== '.') modname)) $ reverse $ splitPath file cmd = "ghc -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile code <- system cmd when (code /= ExitSuccess) $ do putStrLn "Failed to generate the code" exitWith code res <- readFile' txfile when (KeepTemp `notElem` flags) $ do removeFile hsfile removeFile txfile flgs <- return $ fileflags ++ flags if Append `elem` flgs then do src <- readFileBinary file let (src2,c) = dropAppend src ans = (if '\r' `elem` src then windowsNewLine else id) (src2 ++ if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res) when c $ putStrLn "Warning, Checksum does not match, please edit the file manually" writeFileBinary file ans else do let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flgs] impline = unlines ["import " ++ if null i then modname else i | Import i <- flgs] answer = modline ++ impline ++ res case [x | Output x <- flgs] of [] -> putStr answer (x:_) -> writeFile x answer -- return the flags, a string that is the data structures only (including Typeable, Data) -- and a set of derivation names with types -- first disguard blank lines and lines which are -- comments -- next find all lines which start a section, i.e. have something in column 0 -- group lines so every line starts at column 1 -- look for newtype, data etc. -- look for deriving parseFile :: [Flag] -> FilePath -> IO ([Flag], [String], String, String, [(String,String)]) parseFile flags file = do src <- liftM lines $ readFile file optns <- if NoOpts `elem` flags then return [] else parseOptions src pragmas <- return $ parsePragmas src modname <- parseModname src let deriv = concat [x | Derive x <- flags ++ optns] (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $ map dropComments $ filter (not . isBlank) src return (optns, pragmas, modname, unlines decl, concat req) where parsePragmas (x:xs) | "{-#" `isPrefixOf` x2 && "#-}" `isSuffixOf` x2 = x2 : parsePragmas xs | null x2 = parsePragmas xs where x2 = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace x parsePragmas _ = [] parseOptions (x:xs) | "{-# OPTIONS_DERIVE " `isPrefixOf` x = do a <- readOptions $ takeWhile (/= '#') $ drop 19 x b <- parseOptions xs return $ a ++ b | "{-# OPTIONS" `isPrefixOf` x = parseOptions xs parseOptions _ = return [] readOptions x = case getOpt Permute options (words x) of (a,_,ns) -> mapM_ putStr ns >> return a parseModname (x:_) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x where f y = not (isSpace y) && y `notElem` "(" parseModname (_:ys) = parseModname ys parseModname [] = putStrLn "Error, module name not detected" >> return "Main" isBlank x = null x2 || "--" `isPrefixOf` x2 where x2 = dropWhile isSpace x dropComments ('-':'-':_) = [] dropComments (x:xs) = x : dropComments xs dropComments [] = [] joinLines (x1:x2:xs) | col1 x1 && not (col1 x2) = joinLines ((x1 ++ x2) : xs) where col1 = null . takeWhile isSpace joinLines (x:xs) = x : joinLines xs joinLines [] = [] checkData extra x | keyword `elem` ["data","newtype"] = [(x, map ((,) name) req)] | keyword `elem` ["type","import"] = [(x,[])] | otherwise = [] where keyword = takeWhile (not . isSpace) x name = parseName $ drop (length keyword) x req = nub $ extra ++ parseDeriving x -- which derivings have been requested -- find all things inside {-! !-} and 'words' them parseDeriving :: String -> [String] parseDeriving x = words $ f False x where f _ ('{':'-':'!':xs) = ' ' : f True xs f _ ('!':'-':'}':xs) = ' ' : f False xs f b (y:ys) = [if y == ',' then ' ' else y | b] ++ f b ys f _ [] = [] -- if there is a =>, its just after that -- if there isn't, then its right now -- if the => is after =, then ignore parseName x = if "=>" `isPrefixOf` b then parseName (drop 2 b) else head (words a) where (a,b) = break (== '=') x hashString :: String -> String hashString = show . abs . foldl f 0 . filter (not . isSpace) where f :: Int32 -> Char -> Int32 f x y = x * 31 + fromIntegral (ord y) -- Note: openTempFile is not available on Hugs, which sucks openTempFileLocal :: FilePath -> String -> IO (FilePath, Handle) openTempFileLocal dir template = do i <- randomRIO (1000::Int,9999) let (file,ext) = splitExtension template s = dir (file ++ show i) <.> ext b <- doesFileExist s if b then openTempFileLocal dir template else do h <- openFile s ReadWriteMode return (s, h) readFile' :: FilePath -> IO String readFile' file = do h <- openFile file ReadMode res <- hGetContents h length res `seq` return () hClose h return res readFileBinary :: FilePath -> IO String readFileBinary file = do h <- openBinaryFile file ReadMode hGetContents h writeFileBinary :: FilePath -> String -> IO () writeFileBinary file s = do h <- openBinaryFile file WriteMode hPutStr h s hClose h windowsNewLine :: String -> String windowsNewLine ('\r':'\n':xs) = '\r':'\n': windowsNewLine xs windowsNewLine ('\n':xs) = '\r':'\n': windowsNewLine xs windowsNewLine (x:xs) = x : windowsNewLine xs windowsNewLine [] = []