------------------------------------------------------------------------------ --- The main module of currypp, the Curry Preprocessor --- =================================================== --- --- The Curry Preprocessor transforms the source code of Curry programs. --- Currently, only the translation of foreign code integrated in Curry code --- is supported (option `foreigncode`, see module `Translator`). --- --- @author Michael Hanus --- @version November 2021 ------------------------------------------------------------------------------ import Control.Monad ( when ) import Data.Char ( digitToInt ) import Data.List import System.Directory ( copyFile, renameFile ) import System.FilePath import AbstractCurry.Types import AbstractCurry.Files ( readCurry, readUntypedCurry ) import AbstractCurry.Pretty ( showCProg ) import System.CurryPath ( stripCurrySuffix ) import System.CPUTime ( getCPUTime ) import System.Environment ( getEnv, getArgs, setEnv ) import System.Process ( exitWith ) import CPP.DefaultRules ( translateDefaultRulesAndDetOps ) import CPP.Contracts ( translateContracts ) import TransICode ( translateIntCode ) cppBanner :: String cppBanner = unlines [bannerLine,bannerText,bannerLine] where bannerText = "Curry Preprocessor (version of 01/11/2021)" bannerLine = take (length bannerText) (repeat '=') --- Preprocessor targets, i.e., kind of entities to be preprocessed: data PPTarget = ForeignCode | DefaultRules | Contracts deriving Eq parseTarget :: String -> Maybe PPTarget parseTarget t | t == "foreigncode" = Just ForeignCode | t == "defaultrules" = Just DefaultRules | t == "contracts" = Just Contracts | otherwise = Nothing --- Preprocessor options: data PPOpts = PPOpts { optHelp :: Bool , optSave :: Bool -- save the transformed program? , optVerb :: Int -- verbosity , optTgts :: [PPTarget] -- targets of the preprocessor , optModel :: String -- model for the SQL preprocessor , optDefRules :: [String] -- options for DefaultRules , optContracts :: [String] -- options for Contracts } initOpts :: PPOpts initOpts = PPOpts { optHelp = False , optSave = False , optVerb = 1 , optTgts = [] , optModel = "" , optDefRules = [] , optContracts = [] } --- The main function of the Curry Preprocessor. main :: IO () main = do args <- getArgs case args of (orgSourceFile:inFile:outFile:options) -> maybe (showUsage args) (\opts -> if optHelp opts then putStrLn (cppBanner ++ usageText) >> exitWith 1 else do cpath <- getEnv "CURRYPATH" let (mbdir, modname) = pathToModName cpath orgSourceFile when (optVerb opts > 1) $ putStr cppBanner when (optVerb opts > 2) $ putStr $ unlines ["CURRYPATH : " ++ cpath ,"Module name : " ++ modname ,"Original file name : " ++ orgSourceFile ,"Input file name : " ++ inFile ,"Output file name : " ++ outFile ] addDir2CurryPath opts cpath mbdir $ preprocess opts modname orgSourceFile inFile outFile when (optSave opts) $ saveFile orgSourceFile outFile when (optVerb opts > 3) $ do putStrLn "TRANSFORMED PROGRAM:" putStrLn "====================" readFile outFile >>= putStrLn putStrLn "--------------------" ) (processOptions initOpts options) _ -> maybe (showUsage args) (\opts -> if optHelp opts then putStrLn (cppBanner ++ usageText) else showUsage args) (processOptions initOpts args) where -- extend CURRYPATH with a directory (if necessary) and execute last argument addDir2CurryPath _ _ Nothing act = act addDir2CurryPath opts cpath (Just dir) act | dir == "." = act | otherwise = do when (optVerb opts > 2) $ putStrLn $ "Adding directory '" ++ dir ++ "' to CURRYPATH" let newcpath = if null cpath then dir else dir ++ [searchPathSeparator] ++ cpath setEnv "CURRYPATH" newcpath act setEnv "CURRYPATH" cpath saveFile orgSourceFile outFile = do let sFile = orgSourceFile++".CURRYPP" copyFile outFile sFile putStrLn $ "Translated Curry file written to '" ++ sFile ++ "'" processOptions :: PPOpts -> [String] -> Maybe PPOpts processOptions opts optargs = case optargs of [] -> Just opts ("-h":_) -> Just opts { optHelp = True} ("-?":_) -> Just opts { optHelp = True} ("-o":os) -> processOptions opts { optSave = True } os ("-v":os) -> processOptions opts { optVerb = 2 } os (['-','v',vl]:os) -> if isDigit vl then processOptions opts { optVerb = digitToInt vl } os else Nothing (('-':'-':ts):os) -> if isPrefixOf "model:" ts then processOptions opts {optModel = tail (dropWhile (/=':') ts) } os else Nothing (o:os) -> if o `elem` ["-e","-t"] then processOptions opts {optContracts = optContracts opts ++ [o]} os else if o `elem` ["nodupscheme","specscheme"] then processOptions opts {optDefRules = optDefRules opts ++ [o]} os else maybe Nothing (\t -> processOptions opts {optTgts = t : optTgts opts} os) (parseTarget o) showUsage :: [String] -> IO () showUsage args = do putStr cppBanner putStrLn $ "\nERROR: Illegal arguments: " ++ unwords args ++ "\n" putStrLn usageText exitWith 1 usageText :: String usageText = unlines $ [ "" , "Usage: currypp \n" , " : name of original program source file" , " : name of the actual input file" , ": name of the file where output should be written\n" , "where contain preprocessing targets" , "(if no target is given, 'foreigncode defaultrules contracts' are used)\n" , "foreigncode : translate foreign code pieces in the source file" , "--model:_UniSQLCode.info :" , " data model to translate embedded SQL statements" , "defaultrules : implement default rules" , "contracts : implement dynamic contract checking" , "" , "and optional settings:" , "-o : store output also in file .CURRYPP" , "-v : same as -v2" , "-v : show more information about the preprocessor:" , " =0 : quiet" , " =1 : show some information (default)" , " =2 : show more information, e.g., version, timing" , " =3 : show much more information, e.g., used file names" , " =4 : show also transformed Curry program" , "-h|-? : show help message and quit" , "" , "For target 'defaultrules':" , "specscheme : default translation scheme (as in PADL'16 paper)" , "nodupscheme : translation scheme without checking conditions twice" , "" , "For target 'contracts':" , "-e : encapsulate nondeterminism of assertions" , "-t : assert contracts only to top-level (not recursive) calls" ] -- Start the Curry preprocessor: preprocess :: PPOpts -> String -> String -> String -> String -> IO () preprocess opts modname orgfile infile outfile | null pptargets = -- no target specified: apply all reasonable transformations preprocess opts { optTgts = [ForeignCode, DefaultRules, Contracts] } modname orgfile infile outfile | otherwise = do let savefile = orgfile++".SAVEPPORG" starttime <- getCPUTime renameFile orgfile savefile srcprog <- readFile (if orgfile==infile then savefile else infile) >>= return . replaceOptionsLine -- remove currypp option to avoid recursive preprocessor calls: writeFile orgfile srcprog outtxt <- catch (callPreprocessors opts (optionLines srcprog) modname srcprog orgfile) (\err -> renameFile savefile orgfile >> ioError err) writeFile outfile outtxt renameFile savefile orgfile stoptime <- getCPUTime when (optVerb opts > 1) $ putStrLn ("Transformation time: " ++ show (stoptime-starttime) ++ " ms") where pptargets = optTgts opts -- Invoke the various preprocessors. The arguments are: -- * the preprocessor options -- * the parser options lines to be added if the source text is written -- * the name of the module -- * the source text of the module (maybe modified by the code integrator) -- * the file name of the original module (to overwrite it by some pass) callPreprocessors :: PPOpts -> String -> String -> String -> String -> IO String callPreprocessors opts optlines modname srcprog orgfile | ForeignCode `elem` pptargets = do icouttxt <- translateIntCode verb (optModel opts) orgfile srcprog if null (intersect [DefaultRules, Contracts] pptargets) then return icouttxt -- no further preprocessors else do writeFile orgfile icouttxt let rpptargets = delete ForeignCode pptargets callPreprocessors opts {optTgts = rpptargets} optlines modname icouttxt orgfile | DefaultRules `elem` pptargets = do -- specific handling since DefaultRules requires and process -- untyped Curry but Contracts requires typed Curry: mbdefprog <- readUntypedCurry modname >>= translateDefaultRulesAndDetOps verb defopts srcprog let newsrcprog = maybe srcprog showCProg mbdefprog if Contracts `elem` pptargets then do maybe (return ()) (\defprog -> writeFile orgfile (optlines ++ showCProg defprog)) mbdefprog readCurry modname >>= translateContracts verb contopts modname srcprog >>= return . maybe newsrcprog showCProg else return newsrcprog | Contracts `elem` pptargets = readCurry modname >>= translateContracts verb contopts modname srcprog >>= return . maybe srcprog showCProg | otherwise = error "currypp internal error during dispatching" where pptargets = optTgts opts verb = optVerb opts defopts = optDefRules opts contopts = optContracts opts --- Transforms a file path name for a module back into a hierarchical module --- name since only the file path of a module is passed to the preprocessor. --- This is done if the file path name is prefixed by a directory in the --- `currypath`, otherwise the directory of the path is returned in --- the first result component and the plain base name in the second. --- This might be wrong for a hierachical module not occurring in the --- `currypath`, but in this case it is difficult to reconstruct --- the original module name from the file path without looking inside the --- module. pathToModName :: String -> String -> (Maybe String, String) pathToModName currypath psf = tryRemovePathPrefix (prefixLast (splitSearchPath currypath)) where pp = stripCurrySuffix psf tryRemovePathPrefix [] = let (dir,bname) = splitFileName pp in (Just (dropTrailingPathSeparator dir), bname) tryRemovePathPrefix (dir:dirs) | dir `isPrefixOf` pp = (Nothing, dirPath2mod $ drop (length dir + 1) pp) | otherwise = tryRemovePathPrefix dirs -- transform dir-path name into hierarchical module name dirPath2mod = intercalate "." . splitDirectories -- move directories which are prefixed by another one in the path -- before the other ones, e.g., -- prefixLast ["src","aaa","src/ab"] == ["src/ab","src","aaa"] prefixLast [] = [] prefixLast (x:xs) = let (longer,rest) = partition (x `isPrefixOf`) xs in if null longer then x : prefixLast xs else prefixLast (filter (/=x) longer ++ x : rest) -- Replace OPTIONS_FRONTEND / OPTIONS_CYMAKE line containing currypp call -- in a source text by blank line (to avoid recursive calls): replaceOptionsLine :: String -> String replaceOptionsLine = unlines . map replOptLine . lines where replOptLine s = if isOptionLine s && "currypp" `isInfixOf` s then " " else s -- Is this an OPTIONS_FRONTEND or OPTIONS_CYMAKE comment line? isOptionLine :: String -> Bool isOptionLine s = "{-# OPTIONS_CYMAKE " `isPrefixOf` dropWhile isSpace s || "{-# OPTIONS_FRONTEND " `isPrefixOf` dropWhile isSpace s -- -} -- Extract all OPTIONS_FRONTEND / OPTIONS_CYMAKE lines: optionLines :: String -> String optionLines = unlines . filter isOptionLine . lines ------------------------------------------------------------------------------