haskell-tools-cli 0.8.0.0 → 0.9.0.0
raw patch · 59 files changed
+395/−2496 lines, 59 filesdep +Globdep +haskell-tools-builtin-refactoringsdep +haskell-tools-daemondep −haskell-tools-astdep −haskell-tools-prettyprintdep ~filepathdep ~haskell-tools-clidep ~haskell-tools-refactor
Dependencies added: Glob, haskell-tools-builtin-refactorings, haskell-tools-daemon, optparse-applicative
Dependencies removed: haskell-tools-ast, haskell-tools-prettyprint
Dependency ranges changed: filepath, haskell-tools-cli, haskell-tools-refactor
Files
- Language/Haskell/Tools/Refactor/CLI.hs +111/−195
- bench-tests/empty.txt +0/−1
- bench-tests/full-1.txt +0/−10
- bench-tests/full-2.txt +0/−5
- bench-tests/full-3.txt +0/−16
- bench-tests/selects.txt +0/−10
- bench-tests/three-gen-sigs.txt +0/−5
- benchmark/Main.hs +42/−60
- examples/CppHs/Language/Preprocessor/Cpphs.hs +0/−34
- examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs +0/−416
- examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs +0/−129
- examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs +0/−184
- examples/CppHs/Language/Preprocessor/Cpphs/Options.hs +0/−156
- examples/CppHs/Language/Preprocessor/Cpphs/Position.hs +0/−106
- examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs +0/−55
- examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs +0/−82
- examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs +0/−92
- examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs +0/−281
- examples/CppHs/Language/Preprocessor/Unlit.hs +0/−72
- examples/Project/cpp-opt/A.hs +0/−6
- examples/Project/cpp-opt/some-test-package.cabal +0/−19
- examples/Project/has-cabal/A.hs +0/−3
- examples/Project/has-cabal/some-test-package.cabal +0/−18
- examples/Project/multi-packages-flags/package1/A.hs +0/−3
- examples/Project/multi-packages-flags/package1/package1.cabal +0/−19
- examples/Project/multi-packages-flags/package2/B.hs +0/−3
- examples/Project/multi-packages-flags/package2/package2.cabal +0/−19
- examples/Project/multi-packages/package1/A.hs +0/−3
- examples/Project/multi-packages/package1/package1.cabal +0/−18
- examples/Project/multi-packages/package2/B.hs +0/−3
- examples/Project/multi-packages/package2/package2.cabal +0/−18
- examples/Project/no-cabal/A.hs +0/−3
- examples/Project/reloading/A.hs +0/−5
- examples/Project/reloading/B.hs +0/−5
- examples/Project/reloading/C.hs +0/−3
- examples/Project/selection/B.hs +0/−5
- examples/Project/selection/C.hs +0/−3
- examples/Project/source-dir-outside/some-test-package.cabal +0/−19
- examples/Project/source-dir/some-test-package.cabal +0/−19
- examples/Project/source-dir/src/A.hs +0/−3
- examples/Project/src/A.hs +0/−3
- examples/Project/with-main-renamed/A.hs +0/−3
- examples/Project/with-main-renamed/some-test-package.cabal +0/−18
- examples/Project/with-main/Main.hs +0/−3
- examples/Project/with-main/some-test-package.cabal +0/−18
- examples/Project/with-multi-main/A.hs +0/−5
- examples/Project/with-multi-main/B.hs +0/−3
- examples/Project/with-multi-main/Main.hs +0/−3
- examples/Project/with-multi-main/some-test-package.cabal +0/−24
- examples/Project/with-other-executable/A.hs +0/−3
- examples/Project/with-other-executable/some-test-package.cabal +0/−19
- examples/Project/working-dir/data.txt +0/−0
- examples/Project/working-dir/some-test-package.cabal +0/−19
- examples/Project/working-dir/src/A.hs +0/−7
- examples/example-project/Demo.hs +3/−0
- exe/Main.hs +56/−6
- haskell-tools-cli.cabal +30/−50
- test-stackage/Main.hs +115/−67
- test/Main.hs +38/−139
Language/Haskell/Tools/Refactor/CLI.hs view
@@ -1,218 +1,134 @@ {-# LANGUAGE LambdaCase , TupleSections , FlexibleContexts - , TemplateHaskell , TypeFamilies , StandaloneDeriving + , RecordWildCards #-} -module Language.Haskell.Tools.Refactor.CLI (refactorSession, tryOut) where +-- | The command line interface for Haskell-tools. It uses the Haskell-tools daemon package starting +-- the daemon in the same process and communicating with it through a channel. +-- It can be used in a one-shot mode, listing all actions in a command-line parameter or using its +-- standard input to perform a series of refactorings. +module Language.Haskell.Tools.Refactor.CLI + (refactorSession, normalRefactorSession, CLIOptions(..)) where -import Control.Applicative ((<|>)) -import Control.Exception (displayException) +import Control.Concurrent import Control.Monad.State.Strict -import Control.Reference import Data.List import Data.List.Split import Data.Maybe -import Data.Char +import Data.Version (showVersion) import System.Directory -import System.Exit import System.IO -import System.FilePath -import Data.Version (showVersion) -import DynFlags as GHC -import ErrUtils -import GHC -import GHC.Paths ( libdir ) -import HscTypes as GHC -import Outputable -import Packages - -import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor as HT -import Language.Haskell.Tools.Refactor.GetModules -import Language.Haskell.Tools.Refactor.Perform -import Language.Haskell.Tools.Refactor.Session +import Language.Haskell.Tools.Daemon +import Language.Haskell.Tools.Daemon.Mode (channelMode) +import Language.Haskell.Tools.Daemon.Protocol +import Language.Haskell.Tools.Refactor import Paths_haskell_tools_cli (version) - -type CLIRefactorSession = StateT CLISessionState Ghc - -data CLISessionState = - CLISessionState { _refactState :: RefactorSessionState - , _actualMod :: Maybe SourceFileKey - , _exiting :: Bool - , _dryMode :: Bool - } - -makeReferences ''CLISessionState - -deriving instance Show PkgConfRef - -tryOut :: IO () -tryOut = void $ refactorSession stdin stdout - [ "-dry-run", "-one-shot", "-module-name=Language.Haskell.Tools.AST", "-refactoring=OrganizeImports" - , "src/ast", "src/backend-ghc", "src/prettyprint", "src/rewrite", "src/refactor"] - -refactorSession :: Handle -> Handle -> [String] -> IO Bool -refactorSession _ _ args | "-v" `elem` args = do putStrLn $ showVersion version - return True -refactorSession input output args = runGhc (Just libdir) $ handleSourceError printSrcErrors - $ flip evalStateT initSession $ - do lift $ initGhcFlags - workingDirsAndHtFlags <- lift $ useFlags args - let (htFlags, workingDirs) = partition (\case ('-':_) -> True; _ -> False) workingDirsAndHtFlags - if null workingDirs then do liftIO $ hPutStrLn output usageMessage - return False - else do initSuccess <- initializeSession output workingDirs htFlags - when initSuccess $ runSession input output htFlags - return initSuccess - - where printSrcErrors err = do dfs <- getSessionDynFlags - liftIO $ printBagOfErrors dfs (srcErrorMessages err) - return False - - initializeSession :: Handle -> [FilePath] -> [String] -> CLIRefactorSession Bool - initializeSession output workingDirs flags = do - liftIO $ hSetBuffering output NoBuffering - liftIO $ hPutStrLn output "Compiling modules. This may take some time. Please wait." - res <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) (const $ return ()) (\_ _ -> return []) workingDirs - case res of - Right _ -> do - liftIO . hPutStrLn output $ if ("-one-shot" `elem` flags) - then "All modules loaded." - else "All modules loaded. Use 'SelectModule module-name' to select a module." - when ("-dry-run" `elem` flags) $ modify (dryMode .= True) - return True - Left err -> liftIO $ do hPutStrLn output (displayException err) - return False - - runSession :: Handle -> Handle -> [String] -> CLIRefactorSession () - runSession _ output flags | "-one-shot" `elem` flags - = let modName = catMaybes $ map (\f -> case splitOn "=" f of ["-module-name", mod] -> Just mod; _ -> Nothing) flags - refactoring = catMaybes $ map (\f -> case splitOn "=" f of ["-refactoring", ref] -> Just ref; _ -> Nothing) flags - in case (modName, refactoring) of - ([modName],[refactoring]) -> - do performSessionCommand output (LoadModule modName) - command <- readSessionCommand output (takeWhile (/='"') $ dropWhile (=='"') $ refactoring) - void $ performSessionCommand output command - ([],["ProjectOrganizeImports"]) -> - void $ performSessionCommand output (RefactorCommand ProjectOrganizeImports) - _ -> liftIO $ hPutStrLn output "-module-name or -refactoring flag not specified correctly. Not doing any refactoring." - runSession input output _ = runSessionLoop input output - - runSessionLoop :: Handle -> Handle -> CLIRefactorSession () - runSessionLoop input output = do - actualMod <- gets (^. actualMod) - liftIO $ hPutStr output (maybe "no-module-selected> " (\sfk -> (sfk ^. sfkModuleName) ++ "> ") actualMod) - cmd <- liftIO $ hGetLine input - sessionComm <- readSessionCommand output cmd - changedMods <- performSessionCommand output sessionComm - void $ reloadChangedModules (hPutStrLn output . ("Re-loaded module: " ++) . modSumName) (const $ return ()) - (\ms -> keyFromMS ms `elem` changedMods) - doExit <- gets (^. exiting) - when (not doExit) (void (runSessionLoop input output)) - - usageMessage = "Usage: ht-refact [ht-flags, ghc-flags] package-pathes\n" - ++ "ht-flags: -dry-run -one-shot -module-name=modulename -refactoring=\"refactoring\"" +-- | Normal entry point of the cli. +normalRefactorSession :: [RefactoringChoice IdDom] -> Handle -> Handle -> CLIOptions -> IO Bool +normalRefactorSession refactorings input output options@CLIOptions{..} + = do hSetBuffering stdout LineBuffering -- to synch our output with GHC's + hSetBuffering stderr LineBuffering -- to synch our output with GHC's + refactorSession refactorings + (\st -> void $ forkIO $ runDaemon refactorings channelMode st + (DaemonOptions False 0 (not cliVerbose) cliNoWatch cliWatchExe)) + input output options -data RefactorSessionCommand - = LoadModule String - | Skip - | Exit - | RefactorCommand RefactorCommand - deriving Show +-- | Command-line options for the Haskell-tools CLI +data CLIOptions = CLIOptions { displayVersion :: Bool + , cliVerbose :: Bool + , executeCommands :: Maybe String + , cliNoWatch :: Bool + , cliWatchExe :: Maybe FilePath + , ghcFlags :: Maybe [String] + , packageRoots :: [FilePath] + } -readSessionCommand :: Handle -> String -> CLIRefactorSession RefactorSessionCommand -readSessionCommand output cmd = case (splitOn " " cmd) of - ["SelectModule", mod] -> return $ LoadModule mod - ["Exit"] -> return Exit- cm | head cm `elem` refactorCommands - -> do actualMod <- gets (^. actualMod)- case readCommand cmd of- Right cmd -> - case actualMod of Just _ -> return $ RefactorCommand cmd - Nothing -> do liftIO $ hPutStrLn output "Set the actual module first" - return Skip- Left err -> do liftIO $ hPutStrLn output err - return Skip - _ -> do liftIO $ hPutStrLn output $ "'" ++ cmd ++ "' is not a known command. Commands are: SelectModule, Exit, " - ++ intercalate ", " refactorCommands - return Skip +-- | Entry point with configurable initialization. Mainly for testing, call 'normalRefactorSession' +-- to use the command-line. +refactorSession :: [RefactoringChoice IdDom] -> ServerInit -> Handle -> Handle -> CLIOptions -> IO Bool +refactorSession _ _ _ output CLIOptions{..} | displayVersion + = do hPutStrLn output $ showVersion version + return True +refactorSession refactorings init input output CLIOptions{..} = do + connStore <- newEmptyMVar + init connStore + (recv,send) <- takeMVar connStore -- wait for the server to establish connection + wd <- getCurrentDirectory + writeChan send (SetWorkingDir wd) + case ghcFlags of Just flags -> writeChan send (SetGHCFlags flags) + Nothing -> return () + writeChan send (AddPackages packageRoots) + case executeCommands of + Just cmds -> performCmdOptions refactorings output send (splitOn ";" cmds) + Nothing -> return () + when (isNothing executeCommands) (void $ forkIO $ processUserInput refactorings input output send) + readFromSocket (isJust executeCommands) output recv -performSessionCommand :: Handle -> RefactorSessionCommand -> CLIRefactorSession [SourceFileKey] -performSessionCommand output (LoadModule modName) = do - files <- HT.findModule modName - mcs <- gets (^. refSessMCs) - case nub files of - [] -> liftIO $ hPutStrLn output ("Cannot find module: " ++ modName) - [fileName] -> do - mod <- gets (lookupModInSCs (SourceFileKey fileName modName) . (^. refSessMCs)) - modify $ actualMod .= fmap fst mod - _ -> liftIO $ hPutStrLn output ("Ambiguous module: " ++ modName ++ " found: " ++ show files ++ " " ++ show mcs) - return [] -performSessionCommand _ Skip = return [] -performSessionCommand _ Exit = do modify $ exiting .= True - return [] -performSessionCommand output (RefactorCommand cmd) - = do actMod <- gets (^. actualMod) - (actualMod, otherMods) <- getMods actMod - res <- case actualMod of - Just mod -> lift $ performCommand cmd mod otherMods - -- WALKAROUND: support running refactors that need no module selected - Nothing -> case otherMods of (hd:rest) -> lift $ performCommand cmd hd rest - [] -> return (Right []) - inDryMode <- gets (^. dryMode) - case res of Left err -> do liftIO $ hPutStrLn output err - return [] - Right resMods -> performChanges output inDryMode resMods +-- | An initialization action for the daemon. +type ServerInit = MVar (Chan ResponseMsg, Chan ClientMessage) -> IO () - where performChanges :: HasModuleInfo dom => Handle -> Bool -> [RefactorChange dom] -> CLIRefactorSession [SourceFileKey] - performChanges output False resMods = - forM resMods $ \case - ModuleCreated n m otherM -> do - Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) - let Just otherMS = otherMR ^? modRecMS +-- | Reads commands from standard input and executes them. +processUserInput :: [RefactoringChoice IdDom] -> Handle -> Handle -> Chan ClientMessage -> IO () +processUserInput refactorings input output chan = do + cmd <- hGetLine input + continue <- processCommand False refactorings output chan cmd + when continue $ processUserInput refactorings input output chan - otherSrcDir <- liftIO $ getSourceDir otherMS - let loc = srcDirFromRoot otherSrcDir n - liftIO $ withBinaryFile loc WriteMode $ \handle -> do - hSetEncoding handle utf8 - hPutStr handle (prettyPrint m) - return (SourceFileKey n (sourceFileModule (loc `makeRelative` n))) - ContentChanged (n,m) -> do - let file = n ^. sfkFileName - liftIO $ withBinaryFile file WriteMode $ \handle -> do - hSetEncoding handle utf8 - hPutStr handle (prettyPrint m) - return n - ModuleRemoved mod -> do - Just (_,m) <- gets (lookupSourceFileInSCs mod . (^. refSessMCs)) - case ( fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule) - , fmap isBootModule (m ^? typedRecModule) <|> fmap isBootModule (m ^? renamedRecModule)) of - (Just modName, Just isBoot) -> do - ms <- getModSummary modName isBoot - let file = fromJust $ ml_hs_file $ ms_location ms - modify $ (refSessMCs .- removeModule mod) - liftIO $ removeFile file - return (SourceFileKey file mod) - _ -> do liftIO $ hPutStrLn output ("Module " ++ mod ++ " could not be removed.") - return (SourceFileKey "" mod) +-- | Perform a command received from the user. The resulting boolean states if the user may continue +-- (True), or the session is over (False). +processCommand :: Bool -> [RefactoringChoice IdDom] -> Handle -> Chan ClientMessage -> String -> IO Bool +processCommand shutdown refactorings output chan cmd = do + case splitOn " " cmd of + ["Exit"] -> writeChan chan Disconnect >> return False + ["Undo"] -> writeChan chan UndoLast >> return True + ref : rest | let modPath:selection:details = rest ++ (replicate (2 - length rest) "") + , ref `elem` refactorCommands refactorings + -> do writeChan chan (PerformRefactoring ref modPath selection details shutdown False) + return (not shutdown) + "Try" : ref : rest | let modPath:selection:details = rest ++ (replicate (2 - length rest) "") + , ref `elem` refactorCommands refactorings + -> do writeChan chan (PerformRefactoring ref modPath selection details shutdown True) + return (not shutdown) + _ -> do liftIO $ hPutStrLn output $ "'" ++ cmd ++ "' is not a known command. Commands are: Exit, " + ++ intercalate ", " (refactorCommands refactorings) + return True - performChanges output True resMods = do - forM_ resMods (liftIO . \case - ContentChanged (n,m) -> do - hPutStrLn output $ "### Module changed: " ++ (n ^. sfkModuleName) ++ "\n### new content:\n" ++ prettyPrint m - ModuleRemoved mod -> - hPutStrLn output $ "### Module removed: " ++ mod - ModuleCreated n m _ -> - hPutStrLn output $ "### Module created: " ++ n ++ "\n### new content:\n" ++ prettyPrint m) - return [] +-- | Read the responses of the daemon. The result states if the session exited normally or in an +-- erronous way. +readFromSocket :: Bool -> Handle -> Chan ResponseMsg -> IO Bool +readFromSocket pedantic output recv = do + continue <- readChan recv >>= processMessage pedantic output + maybe (readFromSocket pedantic output recv) return continue -- repeate if not stopping - getModSummary name boot - = do allMods <- lift getModuleGraph - return $ fromJust $ find (\ms -> ms_mod ms == name && (ms_hsc_src ms == HsSrcFile) /= boot) allMods +-- | Receives a single response from daemon. Returns Nothing if the execution should continue, +-- Just False on erronous termination and Just True on normal termination. +processMessage :: Bool -> Handle -> ResponseMsg -> IO (Maybe Bool) +processMessage _ output (ErrorMessage msg) = hPutStrLn output msg >> return (Just False) +processMessage pedantic output (CompilationProblem marks) + = do hPutStrLn output (show marks) + return (if pedantic then Just False else Nothing) +processMessage _ output (LoadedModules mods) + = do mapM (\(fp,name) -> hPutStrLn output $ "Loaded module: " ++ name ++ "( " ++ fp ++ ") ") mods + return Nothing +processMessage _ output (DiffInfo diff) + = do putStrLn diff + return Nothing +processMessage _ output (UnusedFlags flags) + = if not $ null flags + then do hPutStrLn output $ "Error: The following ghc-flags are not recognized: " + ++ intercalate " " flags + return $ Just False + else return Nothing +processMessage _ _ Disconnected = return (Just True) +processMessage _ _ _ = return Nothing -instance IsRefactSessionState CLISessionState where - refSessMCs = refactState & _refSessMCs - initSession = CLISessionState initSession Nothing False False +-- | Perform the commands specified by the user as a command line argument. +performCmdOptions :: [RefactoringChoice IdDom] -> Handle -> Chan ClientMessage -> [String] -> IO () +performCmdOptions refactorings output chan cmds = do + continue <- mapM (\(shutdown, cmd) -> processCommand shutdown refactorings output chan cmd) + (zip lastIsShutdown cmds) + when (and continue) $ writeChan chan Disconnect + where lastIsShutdown = replicate (length cmds - 1) False ++ [True]
− bench-tests/empty.txt
@@ -1,1 +0,0 @@-Exit
− bench-tests/full-1.txt
@@ -1,10 +0,0 @@-SelectModule Language.Preprocessor.Cpphs.CppIfdef -ExtractBinding 182:8-182:36 parseResult -RenameDefinition 181:1 gDefined -GenerateSignature 51:5-51:5 -GenerateSignature 50:5-50:5 -GenerateSignature 49:5-49:5 -ExtractBinding 47:46-47:64 linesFixed -RenameDefinition 46:1 cppIfDef -OrganizeImports -Exit
− bench-tests/full-2.txt
@@ -1,5 +0,0 @@-SelectModule Language.Preprocessor.Cpphs.MacroPass -ExtractBinding 96:29-96:47 tokenizeTT -ExtractBinding 90:11-90:67 fun -OrganizeImports -Exit
− bench-tests/full-3.txt
@@ -1,16 +0,0 @@-SelectModule Language.Preprocessor.Cpphs.CppIfdef -ExtractBinding 182:8-182:36 parseResult -RenameDefinition 181:1 gDefined -SelectModule Language.Preprocessor.Cpphs.MacroPass -ExtractBinding 96:29-96:47 tokenizeTT -SelectModule Language.Preprocessor.Cpphs.CppIfdef -GenerateSignature 51:5-51:5 -GenerateSignature 50:5-50:5 -GenerateSignature 49:5-49:5 -SelectModule Language.Preprocessor.Cpphs.MacroPass -ExtractBinding 90:11-90:67 fun -SelectModule Language.Preprocessor.Cpphs.CppIfdef -ExtractBinding 47:46-47:64 linesFixed -RenameDefinition 46:1 cppIfDef -OrganizeImports -Exit
− bench-tests/selects.txt
@@ -1,10 +0,0 @@-SelectModule Language.Preprocessor.Cpphs.CppIfdef -SelectModule Language.Preprocessor.Cpphs.MacroPass -SelectModule Language.Preprocessor.Cpphs.CppIfdef -SelectModule Language.Preprocessor.Cpphs.MacroPass -SelectModule Language.Preprocessor.Cpphs.CppIfdef -SelectModule Language.Preprocessor.Cpphs.MacroPass -SelectModule Language.Preprocessor.Cpphs.CppIfdef -SelectModule Language.Preprocessor.Cpphs.MacroPass -SelectModule Language.Preprocessor.Cpphs.CppIfdef -Exit
− bench-tests/three-gen-sigs.txt
@@ -1,5 +0,0 @@-SelectModule Language.Preprocessor.Cpphs.CppIfdef -GenerateSignature 51:5-51:5 -GenerateSignature 50:5-50:5 -GenerateSignature 49:5-49:5 -Exit
benchmark/Main.hs view
@@ -10,22 +10,23 @@ import Criterion.Measurement hiding (runBenchmark) import Criterion.Types hiding(measure) -import qualified Data.ByteString.Lazy.Char8 as LazyBS (pack, unpack) -import qualified Data.ByteString.Char8 as BS (pack, unpack) -import Data.Aeson -import Data.Knob -import GHC.Generics -import System.FilePath -import System.Directory -import System.IO +import Control.Exception (finally) import Control.Monad -import Control.Exception -import System.Environment +import Data.Aeson (ToJSON, FromJSON, encode) +import qualified Data.ByteString.Char8 as BS (pack) +import qualified Data.ByteString.Lazy.Char8 as LazyBS (unpack) +import Data.Knob (newKnob, newFileHandle) import Data.List -import Data.List.Split -import Data.Time.Clock -import Data.Time.Calendar +import Data.List.Split (chunksOf) +import Data.Time.Calendar (toGregorian) +import Data.Time.Clock (UTCTime(..), getCurrentTime) +import GHC.Generics (Generic) +import System.Directory +import System.Environment (getArgs) +import System.FilePath (FilePath, (</>)) +import System.IO +import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) import Language.Haskell.Tools.Refactor.CLI rootDir = "examples" @@ -35,7 +36,7 @@ args <- getArgs (year, month, day) <- date cases <- bms2Mcases (Date {..}) bms - case args of + case args of [file] -> writeFile file (show $ encode cases) _ -> putStrLn $ LazyBS.unpack $ encode cases putStrLn "Execution times (cycles):" @@ -72,59 +73,39 @@ bms :: [BM] bms = [ BM { bmId = "full-1", workingDir = rootDir </> "CppHs", refactors = [ - "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "ExtractBinding 182:8-182:36 parseResult" - , "RenameDefinition 181:1 gDefined" - , "GenerateSignature 51:5-51:5" - , "GenerateSignature 50:5-50:5" - , "GenerateSignature 49:5-49:5" - , "ExtractBinding 47:46-47:64 linesFixed" - , "RenameDefinition 46:1 cppIfDef" - , "OrganizeImports" + "ExtractBinding Language.Preprocessor.Cpphs.CppIfdef 182:8-182:36 parseResult" + , "RenameDefinition Language.Preprocessor.Cpphs.CppIfdef 181:1 gDefined" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 51:5-51:5" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 50:5-50:5" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 49:5-49:5" + , "ExtractBinding Language.Preprocessor.Cpphs.CppIfdef 47:46-47:64 linesFixed" + , "RenameDefinition Language.Preprocessor.Cpphs.CppIfdef 46:1 cppIfDef" + , "OrganizeImports Language.Preprocessor.Cpphs.CppIfdef" , "Exit" ] } , BM { bmId = "full-2", workingDir = rootDir </> "CppHs", refactors = [ - "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "ExtractBinding 96:29-96:47 tokenizeTT" - , "ExtractBinding 90:11-90:67 fun" - , "OrganizeImports" + "ExtractBinding Language.Preprocessor.Cpphs.MacroPass 96:29-96:47 tokenizeTT" + , "ExtractBinding Language.Preprocessor.Cpphs.MacroPass 90:11-90:67 fun" + , "OrganizeImports Language.Preprocessor.Cpphs.MacroPass" , "Exit" ] } , BM { bmId = "full-3", workingDir = rootDir </> "CppHs", refactors = [ - "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "ExtractBinding 182:8-182:36 parseResult" - , "RenameDefinition 181:1 gDefined" - , "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "ExtractBinding 96:29-96:47 tokenizeTT" - , "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "GenerateSignature 51:5-51:5" - , "GenerateSignature 50:5-50:5" - , "GenerateSignature 49:5-49:5" - , "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "ExtractBinding 90:11-90:67 fun" - , "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "ExtractBinding 47:46-47:64 linesFixed" - , "RenameDefinition 46:1 cppIfDef" - , "OrganizeImports" + "ExtractBinding Language.Preprocessor.Cpphs.CppIfdef 182:8-182:36 parseResult" + , "RenameDefinition Language.Preprocessor.Cpphs.CppIfdef 181:1 gDefined" + , "ExtractBinding Language.Preprocessor.Cpphs.MacroPass 96:29-96:47 tokenizeTT" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 51:5-51:5" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 50:5-50:5" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 49:5-49:5" + , "ExtractBinding Language.Preprocessor.Cpphs.MacroPass 90:11-90:67 fun" + , "ExtractBinding Language.Preprocessor.Cpphs.CppIfdef 47:46-47:64 linesFixed" + , "RenameDefinition Language.Preprocessor.Cpphs.CppIfdef 46:1 cppIfDef" + , "OrganizeImports Language.Preprocessor.Cpphs.CppIfdef" , "Exit" ] } , BM { bmId = "3xGenerateTypeSignature", workingDir = rootDir </> "CppHs", refactors = [ - "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "GenerateSignature 51:5-51:5" - , "GenerateSignature 50:5-50:5" - , "GenerateSignature 49:5-49:5" - , "Exit" - ] } - , BM { bmId ="selects", workingDir = rootDir </> "CppHs", refactors = [ - "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "SelectModule Language.Preprocessor.Cpphs.CppIfdef" - , "SelectModule Language.Preprocessor.Cpphs.MacroPass" - , "SelectModule Language.Preprocessor.Cpphs.CppIfdef" + "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 51:5-51:5" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 50:5-50:5" + , "GenerateSignature Language.Preprocessor.Cpphs.CppIfdef 49:5-49:5" , "Exit" ] } , BM { bmId ="empty", workingDir = rootDir </> "CppHs", refactors = [ "Exit" ] } @@ -149,13 +130,14 @@ makeCliTest wd rfs makeCliTest :: String -> [String] -> IO () -makeCliTest wd rfs = do +makeCliTest wd rfs = do copyDir wd (wd ++ "_orig") inKnob <- newKnob (BS.pack $ unlines rfs) inHandle <- newFileHandle inKnob "<input>" ReadMode outKnob <- newKnob (BS.pack []) outHandle <- newFileHandle outKnob "<output>" WriteMode - void $ refactorSession inHandle outHandle [wd] + void $ normalRefactorSession builtinRefactorings inHandle outHandle + (CLIOptions False Nothing True Nothing Nothing [wd]) `finally` do removeDirectoryRecursive wd renameDirectory (wd ++ "_orig") wd
− examples/CppHs/Language/Preprocessor/Cpphs.hs
@@ -1,34 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : Language.Preprocessor.Cpphs --- Copyright : 2000-2006 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- Include the interface that is exported ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs - ( runCpphs, runCpphsPass1, runCpphsPass2, runCpphsReturningSymTab - , cppIfdef, tokenise, WordStyle(..) - , macroPass, macroPassReturningSymTab - , CpphsOptions(..), BoolOptions(..) - , parseOptions, defaultCpphsOptions, defaultBoolOptions - , module Language.Preprocessor.Cpphs.Position - ) where - -import Language.Preprocessor.Cpphs.CppIfdef(cppIfdef) -import Language.Preprocessor.Cpphs.MacroPass(macroPass - ,macroPassReturningSymTab) -import Language.Preprocessor.Cpphs.RunCpphs(runCpphs - ,runCpphsPass1 - ,runCpphsPass2 - ,runCpphsReturningSymTab) -import Language.Preprocessor.Cpphs.Options - (CpphsOptions(..), BoolOptions(..), parseOptions - ,defaultCpphsOptions,defaultBoolOptions) -import Language.Preprocessor.Cpphs.Position -import Language.Preprocessor.Cpphs.Tokenise
− examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs
@@ -1,416 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : CppIfdef --- Copyright : 1999-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All - --- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's. --- and \#include's. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.CppIfdef - ( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options - -- -> String -> IO [(Posn,String)] - ) where - - -import Text.Parse -import Language.Preprocessor.Cpphs.SymTab -import Language.Preprocessor.Cpphs.Position (Posn,newfile,newline,newlines - ,cppline,cpp2hask,newpos) -import Language.Preprocessor.Cpphs.ReadFirst (readFirst) -import Language.Preprocessor.Cpphs.Tokenise (linesCpp,reslash) -import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) -import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine - ,expandMacro) -import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro) -import Data.Char (isDigit,isSpace,isAlphaNum) -import Data.List (intercalate,isPrefixOf) -import Numeric (readHex,readOct,readDec) -import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO (hPutStrLn,stderr) -import Control.Monad (when) - --- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's, --- whilst taking account of \#define's and \#undef's as we encounter them. -cppIfdef :: FilePath -- ^ File for error reports - -> [(String,String)] -- ^ Pre-defined symbols and their values - -> [String] -- ^ Search path for \#includes - -> BoolOptions -- ^ Options controlling output style - -> String -- ^ The input file content - -> IO [(Posn,String)] -- ^ The file after processing (in lines) -cppIfdef fp syms search options = - cpp posn defs search options (Keep []) . initial . linesCpp - where - posn = newfile fp - defs = preDefine options syms - initial = if literate options then id else (cppline posn:) --- Previous versions had a very simple symbol table mapping strings --- to strings. Now the #ifdef pass uses a more elaborate table, in --- particular to deal with parameterised macros in conditionals. - - --- | Internal state for whether lines are being kept or dropped. --- In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether --- we have already succeeded in keeping some lines in a chain of --- @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts, --- used for error messages in case EOF is reached too soon. -data KeepState = Keep [Posn] | Drop Int Bool [Posn] - --- | Return just the list of lines that the real cpp would decide to keep. -cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState - -> [String] -> IO [(Posn,String)] - -cpp _ _ _ _ (Keep ps) [] | not (null ps) = do - hPutStrLn stderr $ "Unmatched #if: positions of open context are:\n"++ - unlines (map show ps) - return [] -cpp _ _ _ _ _ [] = return [] - -cpp p syms path options (Keep ps) (l@('#':x):xs) = - let ws = words x - cmd = if null ws then "" else head ws - line = tail ws - sym = head (tail ws) - rest = tail (tail ws) - def = defineMacro options (sym++" "++ maybe "1" id (un rest)) - un v = if null v then Nothing else Just (unwords v) - keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps) - skipn syms' retain ud xs' = - let n = 1 + length (filter (=='\n') l) in - (if macros options && retain then emitOne (p,reslash l) - else emitMany (replicate n (p,""))) $ - cpp (newlines n p) syms' path options ud xs' - in case cmd of - "define" -> skipn (insertST def syms) True (Keep ps) xs - "undef" -> skipn (deleteST sym syms) True (Keep ps) xs - "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs - "ifdef" -> skipn syms False (keepIf (definedST sym syms)) xs - "if" -> do b <- gatherDefined p syms (unwords line) - skipn syms False (keepIf b) xs - "else" -> skipn syms False (Drop 1 False ps) xs - "elif" -> skipn syms False (Drop 1 True ps) xs - "endif" | null ps -> - do hPutStrLn stderr $ "Unmatched #endif at "++show p - return [] - "endif" -> skipn syms False (Keep (tail ps)) xs - "pragma" -> skipn syms True (Keep ps) xs - ('!':_) -> skipn syms False (Keep ps) xs -- \#!runhs scripts - "include"-> do (inc,content) <- readFirst (file syms (unwords line)) - p path - (warnings options) - cpp p syms path options (Keep ps) - (("#line 1 "++show inc): linesCpp content - ++ cppline (newline p): xs) - "warning"-> if warnings options then - do hPutStrLn stderr (l++"\nin "++show p) - skipn syms False (Keep ps) xs - else skipn syms False (Keep ps) xs - "error" -> error (l++"\nin "++show p) - "line" | all isDigit sym - -> (if locations options && hashline options then emitOne (p,l) - else if locations options then emitOne (p,cpp2hask l) - else id) $ - cpp (newpos (read sym) (un rest) p) - syms path options (Keep ps) xs - n | all isDigit n && not (null n) - -> (if locations options && hashline options then emitOne (p,l) - else if locations options then emitOne (p,cpp2hask l) - else id) $ - cpp (newpos (read n) (un (tail ws)) p) - syms path options (Keep ps) xs - | otherwise - -> do when (warnings options) $ - hPutStrLn stderr ("Warning: unknown directive #"++n - ++"\nin "++show p) - emitOne (p,l) $ - cpp (newline p) syms path options (Keep ps) xs - -cpp p syms path options (Drop n b ps) (('#':x):xs) = - let ws = words x - cmd = if null ws then "" else head ws - delse | n==1 && b = Drop 1 b ps - | n==1 = Keep ps - | otherwise = Drop n b ps - dend | n==1 = Keep (tail ps) - | otherwise = Drop (n-1) b (tail ps) - delif v | n==1 && not b && v - = Keep ps - | otherwise = Drop n b ps - skipn ud xs' = - let n' = 1 + length (filter (=='\n') x) in - emitMany (replicate n' (p,"")) $ - cpp (newlines n' p) syms path options ud xs' - in - if cmd == "ifndef" || - cmd == "if" || - cmd == "ifdef" then skipn (Drop (n+1) b (p:ps)) xs - else if cmd == "elif" then do v <- gatherDefined p syms (unwords (tail ws)) - skipn (delif v) xs - else if cmd == "else" then skipn delse xs - else if cmd == "endif" then - if null ps then do hPutStrLn stderr $ "Unmatched #endif at "++show p - return [] - else skipn dend xs - else skipn (Drop n b ps) xs - -- define, undef, include, error, warning, pragma, line - -cpp p syms path options (Keep ps) (x:xs) = - let p' = newline p in seq p' $ - emitOne (p,x) $ cpp p' syms path options (Keep ps) xs -cpp p syms path options d@(Drop _ _ _) (_:xs) = - let p' = newline p in seq p' $ - emitOne (p,"") $ cpp p' syms path options d xs - - --- | Auxiliary IO functions -emitOne :: a -> IO [a] -> IO [a] -emitMany :: [a] -> IO [a] -> IO [a] -emitOne x io = do ys <- unsafeInterleaveIO io - return (x:ys) -emitMany xs io = do ys <- unsafeInterleaveIO io - return (xs++ys) - - ----- -gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool -gatherDefined p st inp = - case runParser (preExpand st) inp of - (Left msg, _) -> error ("Cannot expand #if directive in file "++show p - ++":\n "++msg) - (Right s, xs) -> do --- hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n "++s - when (any (not . isSpace) xs) $ - hPutStrLn stderr ("Warning: trailing characters after #if" - ++" macro expansion in file "++show p++": "++xs) - - case runParser parseBoolExp s of - (Left msg, _) -> error ("Cannot parse #if directive in file "++show p - ++":\n "++msg) - (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $ - hPutStrLn stderr - ("Warning: trailing characters after #if" - ++" directive in file "++show p++": "++xs) - return b - -notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace - - --- | The preprocessor must expand all macros (recursively) before evaluating --- the conditional. -preExpand :: SymTab HashDefine -> TextParser String -preExpand st = - do eof - return "" - <|> - do a <- many1 (satisfy notIdent) - commit $ pure (a++) `apply` preExpand st - <|> - do b <- expandSymOrCall st - commit $ pure (b++) `apply` preExpand st - --- | Expansion of symbols. -expandSymOrCall :: SymTab HashDefine -> TextParser String -expandSymOrCall st = - do sym <- parseSym - if sym=="defined" then do arg <- skip parseSym; convert sym [arg] - <|> - do arg <- skip $ parenthesis (do x <- skip parseSym; - skip (return x)) - convert sym [arg] - <|> convert sym [] - else - ( do args <- parenthesis (commit $ fragment `sepBy` skip (isWord ",")) - args' <- flip mapM args $ \arg-> - case runParser (preExpand st) arg of - (Left msg, _) -> fail msg - (Right s, _) -> return s - convert sym args' - <|> convert sym [] - ) - where - fragment = many1 (satisfy (`notElem`",)")) - convert "defined" [arg] = - case lookupST arg st of - Nothing | all isDigit arg -> return arg - Nothing -> return "0" - Just (a@AntiDefined{}) -> return "0" - Just (a@SymbolReplacement{}) -> return "1" - Just (a@MacroExpansion{}) -> return "1" - convert sym args = - case lookupST sym st of - Nothing -> if null args then return sym - else return "0" - -- else fail (disp sym args++" is not a defined macro") - Just (a@SymbolReplacement{}) -> do reparse (replacement a) - return "" - Just (a@MacroExpansion{}) -> do reparse (expandMacro a args False) - return "" - Just (a@AntiDefined{}) -> - if null args then return sym - else return "0" - -- else fail (disp sym args++" explicitly undefined with -U") - disp sym args = let len = length args - chars = map (:[]) ['a'..'z'] - in sym ++ if null args then "" - else "("++intercalate "," (take len chars)++")" - -parseBoolExp :: TextParser Bool -parseBoolExp = - do a <- parseExp1 - bs <- many (do skip (isWord "||") - commit $ skip parseBoolExp) - return $ foldr (||) a bs - -parseExp1 :: TextParser Bool -parseExp1 = - do a <- parseExp0 - bs <- many (do skip (isWord "&&") - commit $ skip parseExp1) - return $ foldr (&&) a bs - -parseExp0 :: TextParser Bool -parseExp0 = - do skip (isWord "!") - a <- commit $ parseExp0 - return (not a) - <|> - do val1 <- parseArithExp1 - op <- parseCmpOp - val2 <- parseArithExp1 - return (val1 `op` val2) - <|> - do sym <- parseArithExp1 - case sym of - 0 -> return False - _ -> return True - <|> - do parenthesis (commit parseBoolExp) - -parseArithExp1 :: TextParser Integer -parseArithExp1 = - do val1 <- parseArithExp0 - ( do op <- parseArithOp1 - val2 <- parseArithExp1 - return (val1 `op` val2) - <|> return val1 ) - <|> - do parenthesis parseArithExp1 - -parseArithExp0 :: TextParser Integer -parseArithExp0 = - do val1 <- parseNumber - ( do op <- parseArithOp0 - val2 <- parseArithExp0 - return (val1 `op` val2) - <|> return val1 ) - <|> - do parenthesis parseArithExp0 - -parseNumber :: TextParser Integer -parseNumber = fmap safeRead $ skip parseSym - where - safeRead s = - case s of - '0':'x':s' -> number readHex s' - '0':'o':s' -> number readOct s' - _ -> number readDec s - number rd s = - case rd s of - [] -> 0 :: Integer - ((n,_):_) -> n :: Integer - -parseCmpOp :: TextParser (Integer -> Integer -> Bool) -parseCmpOp = - do skip (isWord ">=") - return (>=) - <|> - do skip (isWord ">") - return (>) - <|> - do skip (isWord "<=") - return (<=) - <|> - do skip (isWord "<") - return (<) - <|> - do skip (isWord "==") - return (==) - <|> - do skip (isWord "!=") - return (/=) - -parseArithOp1 :: TextParser (Integer -> Integer -> Integer) -parseArithOp1 = - do skip (isWord "+") - return (+) - <|> - do skip (isWord "-") - return (-) - -parseArithOp0 :: TextParser (Integer -> Integer -> Integer) -parseArithOp0 = - do skip (isWord "*") - return (*) - <|> - do skip (isWord "/") - return (div) - <|> - do skip (isWord "%") - return (rem) - --- | Return the expansion of the symbol (if there is one). -parseSymOrCall :: SymTab HashDefine -> TextParser String -parseSymOrCall st = - do sym <- skip parseSym - args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ",")) - return $ convert sym args - <|> - do sym <- skip parseSym - return $ convert sym [] - where - convert sym args = - case lookupST sym st of - Nothing -> sym - Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) - Just (a@MacroExpansion{}) -> recursivelyExpand st (expandMacro a args False) - Just (a@AntiDefined{}) -> name a - -recursivelyExpand :: SymTab HashDefine -> String -> String -recursivelyExpand st inp = - case runParser (parseSymOrCall st) inp of - (Left msg, _) -> inp - (Right s, _) -> s - -parseSym :: TextParser String -parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_")) - `onFail` - do xs <- allAsString - fail $ "Expected an identifier, got \""++xs++"\"" - -notIdent :: Char -> Bool -notIdent c = not (isAlphaNum c || c`elem`"'`_") - -skip :: TextParser a -> TextParser a -skip p = many (satisfy isSpace) >> p - --- | The standard "parens" parser does not work for us here. Define our own. -parenthesis :: TextParser a -> TextParser a -parenthesis p = do isWord "(" - x <- p - isWord ")" - return x - --- | Determine filename in \#include -file :: SymTab HashDefine -> String -> String -file st name = - case name of - ('"':ns) -> init ns - ('<':ns) -> init ns - _ -> let ex = recursivelyExpand st name in - if ex == name then name else file st ex -
− examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs
@@ -1,129 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : HashDefine --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- What structures are declared in a \#define. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.HashDefine - ( HashDefine(..) - , ArgOrText(..) - , expandMacro - , parseHashDefine - , simplifyHashDefines - ) where - -import Data.Char (isSpace) -import Data.List (intercalate) - -data HashDefine - = LineDrop - { name :: String } - | Pragma - { name :: String } - | AntiDefined - { name :: String - , linebreaks :: Int - } - | SymbolReplacement - { name :: String - , replacement :: String - , linebreaks :: Int - } - | MacroExpansion - { name :: String - , arguments :: [String] - , expansion :: [(ArgOrText,String)] - , linebreaks :: Int - } - deriving (Eq,Show) - --- | 'smart' constructor to avoid warnings from ghc (undefined fields) -symbolReplacement :: HashDefine -symbolReplacement = - SymbolReplacement - { name=undefined, replacement=undefined, linebreaks=undefined } - --- | Macro expansion text is divided into sections, each of which is classified --- as one of three kinds: a formal argument (Arg), plain text (Text), --- or a stringised formal argument (Str). -data ArgOrText = Arg | Text | Str deriving (Eq,Show) - --- | Expand an instance of a macro. --- Precondition: got a match on the macro name. -expandMacro :: HashDefine -> [String] -> Bool -> String -expandMacro macro parameters layout = - let env = zip (arguments macro) parameters - replace (Arg,s) = maybe ("") id (lookup s env) - replace (Str,s) = maybe (str "") str (lookup s env) - replace (Text,s) = if layout then s else filter (/='\n') s - str s = '"':s++"\"" - checkArity | length (arguments macro) == 1 && length parameters <= 1 - || length (arguments macro) == length parameters = id - | otherwise = error ("macro "++name macro++" expected "++ - show (length (arguments macro))++ - " arguments, but was given "++ - show (length parameters)) - in - checkArity $ concatMap replace (expansion macro) - --- | Parse a \#define, or \#undef, ignoring other \# directives -parseHashDefine :: Bool -> [String] -> Maybe HashDefine -parseHashDefine ansi def = (command . skip) def - where - skip xss@(x:xs) | all isSpace x = skip xs - | otherwise = xss - skip [] = [] - command ("line":xs) = Just (LineDrop ("#line"++concat xs)) - command ("pragma":xs) = Just (Pragma ("#pragma"++concat xs)) - command ("define":xs) = Just (((define . skip) xs) { linebreaks=count def }) - command ("undef":xs) = Just (((undef . skip) xs)) - command _ = Nothing - undef (sym:_) = AntiDefined { name=sym, linebreaks=0 } - define (sym:xs) = case {-skip-} xs of - ("(":ys) -> (macroHead sym [] . skip) ys - ys -> symbolReplacement - { name=sym - , replacement = concatMap snd - (classifyRhs [] (chop (skip ys))) } - macroHead sym args (",":xs) = (macroHead sym args . skip) xs - macroHead sym args (")":xs) = MacroExpansion - { name =sym , arguments = reverse args - , expansion = classifyRhs args (skip xs) - , linebreaks = undefined } - macroHead sym args (var:xs) = (macroHead sym (var:args) . skip) xs - macroHead sym args [] = error ("incomplete macro definition:\n" - ++" #define "++sym++"(" - ++intercalate "," args) - classifyRhs args ("#":x:xs) - | ansi && - x `elem` args = (Str,x): classifyRhs args xs - classifyRhs args ("##":xs) - | ansi = classifyRhs args xs - classifyRhs args (s:"##":s':xs) - | ansi && all isSpace s && all isSpace s' - = classifyRhs args xs - classifyRhs args (word:xs) - | word `elem` args = (Arg,word): classifyRhs args xs - | otherwise = (Text,word): classifyRhs args xs - classifyRhs _ [] = [] - count = length . filter (=='\n') . concat - chop = reverse . dropWhile (all isSpace) . reverse - --- | Pretty-print hash defines to a simpler format, as key-value pairs. -simplifyHashDefines :: [HashDefine] -> [(String,String)] -simplifyHashDefines = concatMap simp - where - simp hd@LineDrop{} = [] - simp hd@Pragma{} = [] - simp hd@AntiDefined{} = [] - simp hd@SymbolReplacement{} = [(name hd, replacement hd)] - simp hd@MacroExpansion{} = [(name hd++"("++intercalate "," (arguments hd) - ++")" - ,concatMap snd (expansion hd))]
− examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs
@@ -1,184 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : MacroPass --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- Perform a cpp.second-pass, accumulating \#define's and \#undef's, --- whilst doing symbol replacement and macro expansion. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.MacroPass - ( macroPass - , preDefine - , defineMacro - , macroPassReturningSymTab - ) where - -import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro - , simplifyHashDefines) -import Language.Preprocessor.Cpphs.Tokenise (tokenise, WordStyle(..) - , parseMacroCall) -import Language.Preprocessor.Cpphs.SymTab (SymTab, lookupST, insertST - , emptyST, flattenST) -import Language.Preprocessor.Cpphs.Position (Posn, newfile, filename, lineno) -import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) -import System.IO.Unsafe (unsafeInterleaveIO) -import Control.Monad ((=<<)) -import System.Time (getClockTime, toCalendarTime, formatCalendarTime) -import System.Locale (defaultTimeLocale) - -noPos :: Posn -noPos = newfile "preDefined" - --- | Walk through the document, replacing calls of macros with the expanded RHS. -macroPass :: [(String,String)] -- ^ Pre-defined symbols and their values - -> BoolOptions -- ^ Options that alter processing style - -> [(Posn,String)] -- ^ The input file content - -> IO String -- ^ The file after processing -macroPass syms options = - fmap (safetail -- to remove extra "\n" inserted below - . concat - . onlyRights) - . macroProcess (pragma options) (layout options) (lang options) - (preDefine options syms) - . tokenise (stripEol options) (stripC89 options) - (ansi options) (lang options) - . ((noPos,""):) -- ensure recognition of "\n#" at start of file - where - safetail [] = [] - safetail (_:xs) = xs - --- | auxiliary -onlyRights :: [Either a b] -> [b] -onlyRights = concatMap (\x->case x of Right t-> [t]; Left _-> [];) - --- | Walk through the document, replacing calls of macros with the expanded RHS. --- Additionally returns the active symbol table after processing. -macroPassReturningSymTab - :: [(String,String)] -- ^ Pre-defined symbols and their values - -> BoolOptions -- ^ Options that alter processing style - -> [(Posn,String)] -- ^ The input file content - -> IO (String,[(String,String)]) - -- ^ The file and symbol table after processing -macroPassReturningSymTab syms options = - fmap (mapFst (safetail -- to remove extra "\n" inserted below - . concat) - . walk) - . macroProcess (pragma options) (layout options) (lang options) - (preDefine options syms) - . tokenise (stripEol options) (stripC89 options) - (ansi options) (lang options) - . ((noPos,""):) -- ensure recognition of "\n#" at start of file - where - safetail [] = [] - safetail (_:xs) = xs - walk (Right x: rest) = let (xs, foo) = walk rest - in (x:xs, foo) - walk (Left x: []) = ( [] , simplifyHashDefines (flattenST x) ) - walk (Left x: rest) = walk rest - mapFst f (a,b) = (f a, b) - - --- | Turn command-line definitions (from @-D@) into 'HashDefine's. -preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine -preDefine options defines = - foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d)) - emptyST defines - --- | Turn a string representing a macro definition into a 'HashDefine'. -defineMacro :: BoolOptions -> String -> (String,HashDefine) -defineMacro opts s = - let (Cmd (Just hd):_) = tokenise True True (ansi opts) (lang opts) - [(noPos,"\n#define "++s++"\n")] - in (name hd, hd) - - --- | Trundle through the document, one word at a time, using the WordStyle --- classification introduced by 'tokenise' to decide whether to expand a --- word or macro. Encountering a \#define or \#undef causes that symbol to --- be overwritten in the symbol table. Any other remaining cpp directives --- are discarded and replaced with blanks, except for \#line markers. --- All valid identifiers are checked for the presence of a definition --- of that name in the symbol table, and if so, expanded appropriately. --- (Bool arguments are: keep pragmas? retain layout? haskell language?) --- The result lazily intersperses output text with symbol tables. Lines --- are emitted as they are encountered. A symbol table is emitted after --- each change to the defined symbols, and always at the end of processing. -macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle] - -> IO [Either (SymTab HashDefine) String] -macroProcess _ _ _ st [] = return [Left st] -macroProcess p y l st (Other x: ws) = emit x $ macroProcess p y l st ws -macroProcess p y l st (Cmd Nothing: ws) = emit "\n" $ macroProcess p y l st ws -macroProcess p y l st (Cmd (Just (LineDrop x)): ws) - = emit "\n" $ - emit x $ macroProcess p y l st ws -macroProcess pragma y l st (Cmd (Just (Pragma x)): ws) - | pragma = emit "\n" $ emit x $ macroProcess pragma y l st ws - | otherwise = emit "\n" $ macroProcess pragma y l st ws -macroProcess p layout lang st (Cmd (Just hd): ws) = - let n = 1 + linebreaks hd - newST = insertST (name hd, hd) st - in - emit (replicate n '\n') $ - emitSymTab newST $ - macroProcess p layout lang newST ws -macroProcess pr layout lang st (Ident p x: ws) = - case x of - "__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws - "__LINE__" -> emit (show (lineno p)) $ macroProcess pr layout lang st ws - "__DATE__" -> do w <- return . - formatCalendarTime defaultTimeLocale "\"%d %b %Y\"" - =<< toCalendarTime =<< getClockTime - emit w $ macroProcess pr layout lang st ws - "__TIME__" -> do w <- return . - formatCalendarTime defaultTimeLocale "\"%H:%M:%S\"" - =<< toCalendarTime =<< getClockTime - emit w $ macroProcess pr layout lang st ws - _ -> - case lookupST x st of - Nothing -> emit x $ macroProcess pr layout lang st ws - Just hd -> - case hd of - AntiDefined {name=n} -> emit n $ - macroProcess pr layout lang st ws - SymbolReplacement {replacement=r} -> - let r' = if layout then r else filter (/='\n') r in - -- one-level expansion only: - -- emit r' $ macroProcess layout st ws - -- multi-level expansion: - macroProcess pr layout lang st - (tokenise True True False lang [(p,r')] - ++ ws) - MacroExpansion {} -> - case parseMacroCall p ws of - Nothing -> emit x $ - macroProcess pr layout lang st ws - Just (args,ws') -> - if length args /= length (arguments hd) then - emit x $ macroProcess pr layout lang st ws - else do args' <- mapM (fmap (concat.onlyRights) - . macroProcess pr layout - lang st) - args - -- one-level expansion only: - -- emit (expandMacro hd args' layout) $ - -- macroProcess layout st ws' - -- multi-level expansion: - macroProcess pr layout lang st - (tokenise True True False lang - [(p,expandMacro hd args' layout)] - ++ ws') - --- | Useful helper function. -emit :: a -> IO [Either b a] -> IO [Either b a] -emit x io = do xs <- unsafeInterleaveIO io - return (Right x:xs) --- | Useful helper function. -emitSymTab :: b -> IO [Either b a] -> IO [Either b a] -emitSymTab x io = do xs <- unsafeInterleaveIO io - return (Left x:xs)
− examples/CppHs/Language/Preprocessor/Cpphs/Options.hs
@@ -1,156 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : Options --- Copyright : 2006 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- This module deals with Cpphs options and parsing them ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Options - ( CpphsOptions(..) - , BoolOptions(..) - , parseOptions - , defaultCpphsOptions - , defaultBoolOptions - , trailing - ) where - -import Data.Maybe -import Data.List (isPrefixOf) - --- | Cpphs options structure. -data CpphsOptions = CpphsOptions - { infiles :: [FilePath] - , outfiles :: [FilePath] - , defines :: [(String,String)] - , includes :: [String] - , preInclude:: [FilePath] -- ^ Files to \#include before anything else - , boolopts :: BoolOptions - } deriving (Show) - --- | Default options. -defaultCpphsOptions :: CpphsOptions -defaultCpphsOptions = CpphsOptions { infiles = [], outfiles = [] - , defines = [], includes = [] - , preInclude = [] - , boolopts = defaultBoolOptions } - --- | Options representable as Booleans. -data BoolOptions = BoolOptions - { macros :: Bool -- ^ Leave \#define and \#undef in output of ifdef? - , locations :: Bool -- ^ Place \#line droppings in output? - , hashline :: Bool -- ^ Write \#line or {-\# LINE \#-} ? - , pragma :: Bool -- ^ Keep \#pragma in final output? - , stripEol :: Bool -- ^ Remove C eol (\/\/) comments everywhere? - , stripC89 :: Bool -- ^ Remove C inline (\/**\/) comments everywhere? - , lang :: Bool -- ^ Lex input as Haskell code? - , ansi :: Bool -- ^ Permit stringise \# and catenate \#\# operators? - , layout :: Bool -- ^ Retain newlines in macro expansions? - , literate :: Bool -- ^ Remove literate markup? - , warnings :: Bool -- ^ Issue warnings? - } deriving (Show) - --- | Default settings of boolean options. -defaultBoolOptions :: BoolOptions -defaultBoolOptions = BoolOptions { macros = True, locations = True - , hashline = True, pragma = False - , stripEol = False, stripC89 = False - , lang = True, ansi = False - , layout = False, literate = False - , warnings = True } - --- | Raw command-line options. This is an internal intermediate data --- structure, used during option parsing only. -data RawOption - = NoMacro - | NoLine - | LinePragma - | Pragma - | Text - | Strip - | StripEol - | Ansi - | Layout - | Unlit - | SuppressWarnings - | Macro (String,String) - | Path String - | PreInclude FilePath - | IgnoredForCompatibility - deriving (Eq, Show) - -flags :: [(String, RawOption)] -flags = [ ("--nomacro", NoMacro) - , ("--noline", NoLine) - , ("--linepragma", LinePragma) - , ("--pragma", Pragma) - , ("--text", Text) - , ("--strip", Strip) - , ("--strip-eol", StripEol) - , ("--hashes", Ansi) - , ("--layout", Layout) - , ("--unlit", Unlit) - , ("--nowarn", SuppressWarnings) - ] - --- | Parse a single raw command-line option. Parse failure is indicated by --- result Nothing. -rawOption :: String -> Maybe RawOption -rawOption x | isJust a = a - where a = lookup x flags -rawOption ('-':'D':xs) = Just $ Macro (s, if null d then "1" else tail d) - where (s,d) = break (=='=') xs -rawOption ('-':'U':xs) = Just $ IgnoredForCompatibility -rawOption ('-':'I':xs) = Just $ Path $ trailing "/\\" xs -rawOption xs | "--include="`isPrefixOf`xs - = Just $ PreInclude (drop 10 xs) -rawOption _ = Nothing - --- | Trim trailing elements of the second list that match any from --- the first list. Typically used to remove trailing forward\/back --- slashes from a directory path. -trailing :: (Eq a) => [a] -> [a] -> [a] -trailing xs = reverse . dropWhile (`elem`xs) . reverse - --- | Convert a list of RawOption to a BoolOptions structure. -boolOpts :: [RawOption] -> BoolOptions -boolOpts opts = - BoolOptions - { macros = not (NoMacro `elem` opts) - , locations = not (NoLine `elem` opts) - , hashline = not (LinePragma `elem` opts) - , pragma = Pragma `elem` opts - , stripEol = StripEol`elem` opts - , stripC89 = StripEol`elem` opts || Strip `elem` opts - , lang = not (Text `elem` opts) - , ansi = Ansi `elem` opts - , layout = Layout `elem` opts - , literate = Unlit `elem` opts - , warnings = not (SuppressWarnings `elem` opts) - } - --- | Parse all command-line options. -parseOptions :: [String] -> Either String CpphsOptions -parseOptions xs = f ([], [], []) xs - where - f (opts, ins, outs) (('-':'O':x):xs) = f (opts, ins, x:outs) xs - f (opts, ins, outs) (x@('-':_):xs) = case rawOption x of - Nothing -> Left x - Just a -> f (a:opts, ins, outs) xs - f (opts, ins, outs) (x:xs) = f (opts, normalise x:ins, outs) xs - f (opts, ins, outs) [] = - Right CpphsOptions { infiles = reverse ins - , outfiles = reverse outs - , defines = [ x | Macro x <- reverse opts ] - , includes = [ x | Path x <- reverse opts ] - , preInclude=[ x | PreInclude x <- reverse opts ] - , boolopts = boolOpts opts - } - normalise ('/':'/':filepath) = normalise ('/':filepath) - normalise (x:filepath) = x:normalise filepath - normalise [] = []
− examples/CppHs/Language/Preprocessor/Cpphs/Position.hs
@@ -1,106 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : Position --- Copyright : 2000-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- Simple file position information, with recursive inclusion points. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Position - ( Posn(..) - , newfile - , addcol, newline, tab, newlines, newpos - , cppline, haskline, cpp2hask - , filename, lineno, directory - , cleanPath - ) where - -import Data.List (isPrefixOf) - --- | Source positions contain a filename, line, column, and an --- inclusion point, which is itself another source position, --- recursively. -data Posn = Pn String !Int !Int (Maybe Posn) - deriving (Eq) - -instance Show Posn where - showsPrec _ (Pn f l c i) = showString f . - showString " at line " . shows l . - showString " col " . shows c . - ( case i of - Nothing -> id - Just p -> showString "\n used by " . - shows p ) - --- | Constructor. Argument is filename. -newfile :: String -> Posn -newfile name = Pn (cleanPath name) 1 1 Nothing - --- | Increment column number by given quantity. -addcol :: Int -> Posn -> Posn -addcol n (Pn f r c i) = Pn f r (c+n) i - --- | Increment row number, reset column to 1. -newline :: Posn -> Posn ---newline (Pn f r _ i) = Pn f (r+1) 1 i -newline (Pn f r _ i) = let r' = r+1 in r' `seq` Pn f r' 1 i - --- | Increment column number, tab stops are every 8 chars. -tab :: Posn -> Posn -tab (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i - --- | Increment row number by given quantity. -newlines :: Int -> Posn -> Posn -newlines n (Pn f r _ i) = Pn f (r+n) 1 i - --- | Update position with a new row, and possible filename. -newpos :: Int -> Maybe String -> Posn -> Posn -newpos r Nothing (Pn f _ c i) = Pn f r c i -newpos r (Just ('"':f)) (Pn _ _ c i) = Pn (init f) r c i -newpos r (Just f) (Pn _ _ c i) = Pn f r c i - --- | Project the line number. -lineno :: Posn -> Int --- | Project the filename. -filename :: Posn -> String --- | Project the directory of the filename. -directory :: Posn -> FilePath - -lineno (Pn _ r _ _) = r -filename (Pn f _ _ _) = f -directory (Pn f _ _ _) = dirname f - - --- | cpp-style printing of file position -cppline :: Posn -> String -cppline (Pn f r _ _) = "#line "++show r++" "++show f - --- | haskell-style printing of file position -haskline :: Posn -> String -haskline (Pn f r _ _) = "{-# LINE "++show r++" "++show f++" #-}" - --- | Conversion from a cpp-style "#line" to haskell-style pragma. -cpp2hask :: String -> String -cpp2hask line | "#line" `isPrefixOf` line = "{-# LINE " - ++unwords (tail (words line)) - ++" #-}" - | otherwise = line - --- | Strip non-directory suffix from file name (analogous to the shell --- command of the same name). -dirname :: String -> String -dirname = reverse . safetail . dropWhile (not.(`elem`"\\/")) . reverse - where safetail [] = [] - safetail (_:x) = x - --- | Sigh. Mixing Windows filepaths with unix is bad. Make sure there is a --- canonical path separator. -cleanPath :: FilePath -> FilePath -cleanPath [] = [] -cleanPath ('\\':cs) = '/': cleanPath cs -cleanPath (c:cs) = c: cleanPath cs
− examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs
@@ -1,55 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : ReadFirst --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- Read the first file that matches in a list of search paths. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.ReadFirst - ( readFirst - ) where - -import System.IO (hPutStrLn, stderr) -import System.Directory (doesFileExist) -import Data.List (intersperse) -import Control.Monad (when) -import Language.Preprocessor.Cpphs.Position (Posn,directory,cleanPath) - --- | Attempt to read the given file from any location within the search path. --- The first location found is returned, together with the file content. --- (The directory of the calling file is always searched first, then --- the current directory, finally any specified search path.) -readFirst :: String -- ^ filename - -> Posn -- ^ inclusion point - -> [String] -- ^ search path - -> Bool -- ^ report warnings? - -> IO ( FilePath - , String - ) -- ^ discovered filepath, and file contents - -readFirst name demand path warn = - case name of - '/':nm -> try nm [""] - _ -> try name (cons dd (".":path)) - where - dd = directory demand - cons x xs = if null x then xs else x:xs - try name [] = do - when warn $ - hPutStrLn stderr ("Warning: Can't find file \""++name - ++"\" in directories\n\t" - ++concat (intersperse "\n\t" (cons dd (".":path))) - ++"\n Asked for by: "++show demand) - return ("missing file: "++name,"") - try name (p:ps) = do - let file = cleanPath p++'/':cleanPath name - ok <- doesFileExist file - if not ok then try name ps - else do content <- readFile file - return (file,content)
− examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs
@@ -1,82 +0,0 @@-{- --- The main program for cpphs, a simple C pre-processor written in Haskell. - --- Copyright (c) 2004 Malcolm Wallace --- This file is LGPL (relicensed from the GPL by Malcolm Wallace, October 2011). --} -module Language.Preprocessor.Cpphs.RunCpphs ( runCpphs - , runCpphsPass1 - , runCpphsPass2 - , runCpphsReturningSymTab - ) where - -import Language.Preprocessor.Cpphs.CppIfdef (cppIfdef) -import Language.Preprocessor.Cpphs.MacroPass(macroPass,macroPassReturningSymTab) -import Language.Preprocessor.Cpphs.Options (CpphsOptions(..), BoolOptions(..) - ,trailing) -import Language.Preprocessor.Cpphs.Tokenise (deWordStyle, tokenise) -import Language.Preprocessor.Cpphs.Position (cleanPath, Posn) -import Language.Preprocessor.Unlit as Unlit (unlit) - - -runCpphs :: CpphsOptions -> FilePath -> String -> IO String -runCpphs options filename input = do - pass1 <- runCpphsPass1 options filename input - runCpphsPass2 (boolopts options) (defines options) filename pass1 - -runCpphsPass1 :: CpphsOptions -> FilePath -> String -> IO [(Posn,String)] -runCpphsPass1 options' filename input = do - let options= options'{ includes= map (trailing "\\/") (includes options') } - let bools = boolopts options - preInc = case preInclude options of - [] -> "" - is -> concatMap (\f->"#include \""++f++"\"\n") is - ++ "#line 1 \""++cleanPath filename++"\"\n" - - pass1 <- cppIfdef filename (defines options) (includes options) bools - (preInc++input) - return pass1 - -runCpphsPass2 :: BoolOptions -> [(String,String)] -> FilePath -> [(Posn,String)] -> IO String -runCpphsPass2 bools defines filename pass1 = do - pass2 <- macroPass defines bools pass1 - let result= if not (macros bools) - then if stripC89 bools || stripEol bools - then concatMap deWordStyle $ - tokenise (stripEol bools) (stripC89 bools) - (ansi bools) (lang bools) pass1 - else unlines (map snd pass1) - else pass2 - pass3 = if literate bools then Unlit.unlit filename else id - return (pass3 result) - -runCpphsReturningSymTab :: CpphsOptions -> FilePath -> String - -> IO (String,[(String,String)]) -runCpphsReturningSymTab options' filename input = do - let options= options'{ includes= map (trailing "\\/") (includes options') } - let bools = boolopts options - preInc = case preInclude options of - [] -> "" - is -> concatMap (\f->"#include \""++f++"\"\n") is - ++ "#line 1 \""++cleanPath filename++"\"\n" - (pass2,syms) <- - if macros bools then do - pass1 <- cppIfdef filename (defines options) (includes options) - bools (preInc++input) - macroPassReturningSymTab (defines options) bools pass1 - else do - pass1 <- cppIfdef filename (defines options) (includes options) - bools{macros=True} (preInc++input) - (_,syms) <- macroPassReturningSymTab (defines options) bools pass1 - pass1 <- cppIfdef filename (defines options) (includes options) - bools (preInc++input) - let result = if stripC89 bools || stripEol bools - then concatMap deWordStyle $ - tokenise (stripEol bools) (stripC89 bools) - (ansi bools) (lang bools) pass1 - else init $ unlines (map snd pass1) - return (result,syms) - - let pass3 = if literate bools then Unlit.unlit filename else id - return (pass3 pass2, syms) -
− examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs
@@ -1,92 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : SymTab --- Copyright : 2000-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : Stable --- Portability : All --- --- Symbol Table, based on index trees using a hash on the key. --- Keys are always Strings. Stored values can be any type. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.SymTab - ( SymTab - , emptyST - , insertST - , deleteST - , lookupST - , definedST - , flattenST - , IndTree - ) where - --- | Symbol Table. Stored values are polymorphic, but the keys are --- always strings. -type SymTab v = IndTree [(String,v)] - -emptyST :: SymTab v -insertST :: (String,v) -> SymTab v -> SymTab v -deleteST :: String -> SymTab v -> SymTab v -lookupST :: String -> SymTab v -> Maybe v -definedST :: String -> SymTab v -> Bool -flattenST :: SymTab v -> [v] - -emptyST = itgen maxHash [] -insertST (s,v) ss = itiap (hash s) ((s,v):) ss id -deleteST s ss = itiap (hash s) (filter ((/=s).fst)) ss id -lookupST s ss = let vs = filter ((==s).fst) ((itind (hash s)) ss) - in if null vs then Nothing - else (Just . snd . head) vs -definedST s ss = let vs = filter ((==s).fst) ((itind (hash s)) ss) - in (not . null) vs -flattenST ss = itfold (map snd) (++) ss - - ----- --- | Index Trees (storing indexes at nodes). - -data IndTree t = Leaf t | Fork Int (IndTree t) (IndTree t) - deriving Show - -itgen :: Int -> a -> IndTree a -itgen 1 x = Leaf x -itgen n x = - let n' = n `div` 2 - in Fork n' (itgen n' x) (itgen (n-n') x) - -itiap :: --Eval a => - Int -> (a->a) -> IndTree a -> (IndTree a -> b) -> b -itiap _ f (Leaf x) k = let fx = f x in {-seq fx-} (k (Leaf fx)) -itiap i f (Fork n lt rt) k = - if i<n then - itiap i f lt $ \lt' -> k (Fork n lt' rt) - else itiap (i-n) f rt $ \rt' -> k (Fork n lt rt') - -itind :: Int -> IndTree a -> a -itind _ (Leaf x) = x -itind i (Fork n lt rt) = if i<n then itind i lt else itind (i-n) rt - -itfold :: (a->b) -> (b->b->b) -> IndTree a -> b -itfold leaf _fork (Leaf x) = leaf x -itfold leaf fork (Fork _ l r) = fork (itfold leaf fork l) (itfold leaf fork r) - ----- --- Hash values - -maxHash :: Int -- should be prime -maxHash = 101 - -class Hashable a where - hashWithMax :: Int -> a -> Int - hash :: a -> Int - hash = hashWithMax maxHash - -instance Enum a => Hashable [a] where - hashWithMax m = h 0 - where h a [] = a - h a (c:cs) = h ((17*(fromEnum c)+19*a)`rem`m) cs - -----
− examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs
@@ -1,281 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : Tokenise --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- The purpose of this module is to lex a source file (language --- unspecified) into tokens such that cpp can recognise a replaceable --- symbol or macro-use, and do the right thing. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Tokenise - ( linesCpp - , reslash - , tokenise - , WordStyle(..) - , deWordStyle - , parseMacroCall - ) where - -import Data.Char -import Language.Preprocessor.Cpphs.HashDefine -import Language.Preprocessor.Cpphs.Position - --- | A Mode value describes whether to tokenise a la Haskell, or a la Cpp. --- The main difference is that in Cpp mode we should recognise line --- continuation characters. -data Mode = Haskell | Cpp - --- | linesCpp is, broadly speaking, Prelude.lines, except that --- on a line beginning with a \#, line continuation characters are --- recognised. In a line continuation, the newline character is --- preserved, but the backslash is not. -linesCpp :: String -> [String] -linesCpp [] = [] -linesCpp (x:xs) | x=='#' = tok Cpp ['#'] xs - | otherwise = tok Haskell [] (x:xs) - where - tok Cpp acc ('\\':'\n':ys) = tok Cpp ('\n':acc) ys - tok _ acc ('\n':'#':ys) = reverse acc: tok Cpp ['#'] ys - tok _ acc ('\n':ys) = reverse acc: tok Haskell [] ys - tok _ acc [] = reverse acc: [] - tok mode acc (y:ys) = tok mode (y:acc) ys - --- | Put back the line-continuation characters. -reslash :: String -> String -reslash ('\n':xs) = '\\':'\n':reslash xs -reslash (x:xs) = x: reslash xs -reslash [] = [] - ----- --- | Submodes are required to deal correctly with nesting of lexical --- structures. -data SubMode = Any | Pred (Char->Bool) (Posn->String->WordStyle) - | String Char | LineComment | NestComment Int - | CComment | CLineComment - --- | Each token is classified as one of Ident, Other, or Cmd: --- * Ident is a word that could potentially match a macro name. --- * Cmd is a complete cpp directive (\#define etc). --- * Other is anything else. -data WordStyle = Ident Posn String | Other String | Cmd (Maybe HashDefine) - deriving (Eq,Show) -other :: Posn -> String -> WordStyle -other _ s = Other s - -deWordStyle :: WordStyle -> String -deWordStyle (Ident _ i) = i -deWordStyle (Other i) = i -deWordStyle (Cmd _) = "\n" - --- | tokenise is, broadly-speaking, Prelude.words, except that: --- * the input is already divided into lines --- * each word-like "token" is categorised as one of {Ident,Other,Cmd} --- * \#define's are parsed and returned out-of-band using the Cmd variant --- * All whitespace is preserved intact as tokens. --- * C-comments are converted to white-space (depending on first param) --- * Parens and commas are tokens in their own right. --- * Any cpp line continuations are respected. --- No errors can be raised. --- The inverse of tokenise is (concatMap deWordStyle). -tokenise :: Bool -> Bool -> Bool -> Bool -> [(Posn,String)] -> [WordStyle] -tokenise _ _ _ _ [] = [] -tokenise stripEol stripComments ansi lang ((pos,str):pos_strs) = - (if lang then haskell else plaintext) Any [] pos pos_strs str - where - -- rules to lex Haskell - haskell :: SubMode -> String -> Posn -> [(Posn,String)] - -> String -> [WordStyle] - haskell Any acc p ls ('\n':'#':xs) = emit acc $ -- emit "\n" $ - cpp Any haskell [] [] p ls xs - -- warning: non-maximal munch on comment - haskell Any acc p ls ('-':'-':xs) = emit acc $ - haskell LineComment "--" p ls xs - haskell Any acc p ls ('{':'-':xs) = emit acc $ - haskell (NestComment 0) "-{" p ls xs - haskell Any acc p ls ('/':'*':xs) - | stripComments = emit acc $ - haskell CComment " " p ls xs - haskell Any acc p ls ('/':'/':xs) - | stripEol = emit acc $ - haskell CLineComment " " p ls xs - haskell Any acc p ls ('"':xs) = emit acc $ - haskell (String '"') ['"'] p ls xs - haskell Any acc p ls ('\'':'\'':xs) = emit acc $ -- TH type quote - haskell Any "''" p ls xs - haskell Any acc p ls ('\'':xs@('\\':_)) = emit acc $ -- escaped char literal - haskell (String '\'') "'" p ls xs - haskell Any acc p ls ('\'':x:'\'':xs) = emit acc $ -- character literal - emit ['\'', x, '\''] $ - haskell Any [] p ls xs - haskell Any acc p ls ('\'':xs) = emit acc $ -- TH name quote - haskell Any "'" p ls xs - haskell Any acc p ls (x:xs) | single x = emit acc $ emit [x] $ - haskell Any [] p ls xs - haskell Any acc p ls (x:xs) | space x = emit acc $ - haskell (Pred space other) [x] - p ls xs - haskell Any acc p ls (x:xs) | symbol x = emit acc $ - haskell (Pred symbol other) [x] - p ls xs - -- haskell Any [] p ls (x:xs) | ident0 x = id $ - haskell Any acc p ls (x:xs) | ident0 x = emit acc $ - haskell (Pred ident1 Ident) [x] - p ls xs - haskell Any acc p ls (x:xs) = haskell Any (x:acc) p ls xs - - haskell pre@(Pred pred ws) acc p ls (x:xs) - | pred x = haskell pre (x:acc) p ls xs - haskell (Pred _ ws) acc p ls xs = ws p (reverse acc): - haskell Any [] p ls xs - haskell (String c) acc p ls ('\\':x:xs) - | x=='\\' = haskell (String c) ('\\':'\\':acc) p ls xs - | x==c = haskell (String c) (c:'\\':acc) p ls xs - haskell (String c) acc p ls (x:xs) - | x==c = emit (c:acc) $ haskell Any [] p ls xs - | otherwise = haskell (String c) (x:acc) p ls xs - haskell LineComment acc p ls xs@('\n':_) = emit acc $ haskell Any [] p ls xs - haskell LineComment acc p ls (x:xs) = haskell LineComment (x:acc) p ls xs - haskell (NestComment n) acc p ls ('{':'-':xs) - = haskell (NestComment (n+1)) - ("-{"++acc) p ls xs - haskell (NestComment 0) acc p ls ('-':'}':xs) - = emit ("}-"++acc) $ haskell Any [] p ls xs - haskell (NestComment n) acc p ls ('-':'}':xs) - = haskell (NestComment (n-1)) - ("}-"++acc) p ls xs - haskell (NestComment n) acc p ls (x:xs) = haskell (NestComment n) (x:acc) - p ls xs - haskell CComment acc p ls ('*':'/':xs) = emit (" "++acc) $ - haskell Any [] p ls xs - haskell CComment acc p ls (x:xs) = haskell CComment (white x:acc) p ls xs - haskell CLineComment acc p ls xs@('\n':_)= emit acc $ haskell Any [] p ls xs - haskell CLineComment acc p ls (_:xs) = haskell CLineComment (' ':acc) - p ls xs - haskell mode acc _ ((p,l):ls) [] = haskell mode acc p ls ('\n':l) - haskell _ acc _ [] [] = emit acc $ [] - - -- rules to lex Cpp - cpp :: SubMode -> (SubMode -> String -> Posn -> [(Posn,String)] - -> String -> [WordStyle]) - -> String -> [String] -> Posn -> [(Posn,String)] - -> String -> [WordStyle] - cpp mode next word line pos remaining input = - lexcpp mode word line remaining input - where - lexcpp Any w l ls ('/':'*':xs) = lexcpp (NestComment 0) "" (w*/*l) ls xs - lexcpp Any w l ls ('/':'/':xs) = lexcpp LineComment " " (w*/*l) ls xs - lexcpp Any w l ((p,l'):ls) ('\\':[]) = cpp Any next [] ("\n":w*/*l) p ls l' - lexcpp Any w l ls ('\\':'\n':xs) = lexcpp Any [] ("\n":w*/*l) ls xs - lexcpp Any w l ls xs@('\n':_) = Cmd (parseHashDefine ansi - (reverse (w*/*l))): - next Any [] pos ls xs - -- lexcpp Any w l ls ('"':xs) = lexcpp (String '"') ['"'] (w*/*l) ls xs - -- lexcpp Any w l ls ('\'':xs) = lexcpp (String '\'') "'" (w*/*l) ls xs - lexcpp Any w l ls ('"':xs) = lexcpp Any [] ("\"":(w*/*l)) ls xs - lexcpp Any w l ls ('\'':xs) = lexcpp Any [] ("'": (w*/*l)) ls xs - lexcpp Any [] l ls (x:xs) - | ident0 x = lexcpp (Pred ident1 Ident) [x] l ls xs - -- lexcpp Any w l ls (x:xs) | ident0 x = lexcpp (Pred ident1 Ident) [x] (w*/*l) ls xs - lexcpp Any w l ls (x:xs) - | single x = lexcpp Any [] ([x]:w*/*l) ls xs - | space x = lexcpp (Pred space other) [x] (w*/*l) ls xs - | symbol x = lexcpp (Pred symbol other) [x] (w*/*l) ls xs - | otherwise = lexcpp Any (x:w) l ls xs - lexcpp pre@(Pred pred _) w l ls (x:xs) - | pred x = lexcpp pre (x:w) l ls xs - lexcpp (Pred _ _) w l ls xs = lexcpp Any [] (w*/*l) ls xs - lexcpp (String c) w l ls ('\\':x:xs) - | x=='\\' = lexcpp (String c) ('\\':'\\':w) l ls xs - | x==c = lexcpp (String c) (c:'\\':w) l ls xs - lexcpp (String c) w l ls (x:xs) - | x==c = lexcpp Any [] ((c:w)*/*l) ls xs - | otherwise = lexcpp (String c) (x:w) l ls xs - lexcpp LineComment w l ((p,l'):ls) ('\\':[]) - = cpp LineComment next [] (('\n':w)*/*l) pos ls l' - lexcpp LineComment w l ls ('\\':'\n':xs) - = lexcpp LineComment [] (('\n':w)*/*l) ls xs - lexcpp LineComment w l ls xs@('\n':_) = lexcpp Any w l ls xs - lexcpp LineComment w l ls (_:xs) = lexcpp LineComment (' ':w) l ls xs - lexcpp (NestComment _) w l ls ('*':'/':xs) - = lexcpp Any [] (w*/*l) ls xs - lexcpp (NestComment n) w l ls (x:xs) = lexcpp (NestComment n) (white x:w) l - ls xs - lexcpp mode w l ((p,l'):ls) [] = cpp mode next w l p ls ('\n':l') - lexcpp _ _ _ [] [] = [] - - -- rules to lex non-Haskell, non-cpp text - plaintext :: SubMode -> String -> Posn -> [(Posn,String)] - -> String -> [WordStyle] - plaintext Any acc p ls ('\n':'#':xs) = emit acc $ -- emit "\n" $ - cpp Any plaintext [] [] p ls xs - plaintext Any acc p ls ('/':'*':xs) - | stripComments = emit acc $ - plaintext CComment " " p ls xs - plaintext Any acc p ls ('/':'/':xs) - | stripEol = emit acc $ - plaintext CLineComment " " p ls xs - plaintext Any acc p ls (x:xs) | single x = emit acc $ emit [x] $ - plaintext Any [] p ls xs - plaintext Any acc p ls (x:xs) | space x = emit acc $ - plaintext (Pred space other) [x] - p ls xs - plaintext Any acc p ls (x:xs) | ident0 x = emit acc $ - plaintext (Pred ident1 Ident) [x] - p ls xs - plaintext Any acc p ls (x:xs) = plaintext Any (x:acc) p ls xs - plaintext pre@(Pred pred ws) acc p ls (x:xs) - | pred x = plaintext pre (x:acc) p ls xs - plaintext (Pred _ ws) acc p ls xs = ws p (reverse acc): - plaintext Any [] p ls xs - plaintext CComment acc p ls ('*':'/':xs) = emit (" "++acc) $ - plaintext Any [] p ls xs - plaintext CComment acc p ls (x:xs) = plaintext CComment (white x:acc) p ls xs - plaintext CLineComment acc p ls xs@('\n':_) - = emit acc $ plaintext Any [] p ls xs - plaintext CLineComment acc p ls (_:xs)= plaintext CLineComment (' ':acc) - p ls xs - plaintext mode acc _ ((p,l):ls) [] = plaintext mode acc p ls ('\n':l) - plaintext _ acc _ [] [] = emit acc $ [] - - -- predicates for lexing Haskell. - ident0 x = isAlpha x || x `elem` "_`" - ident1 x = isAlphaNum x || x `elem` "'_`" - symbol x = x `elem` ":!#$%&*+./<=>?@\\^|-~" - single x = x `elem` "(),[];{}" - space x = x `elem` " \t" - -- conversion of comment text to whitespace - white '\n' = '\n' - white '\r' = '\r' - white _ = ' ' - -- emit a token (if there is one) from the accumulator - emit "" = id - emit xs = (Other (reverse xs):) - -- add a reversed word to the accumulator - "" */* l = l - w */* l = reverse w : l - -- help out broken Haskell compilers which need balanced numbers of C - -- comments in order to do import chasing :-) -----> */* - - --- | Parse a possible macro call, returning argument list and remaining input -parseMacroCall :: Posn -> [WordStyle] -> Maybe ([[WordStyle]],[WordStyle]) -parseMacroCall p = call . skip - where - skip (Other x:xs) | all isSpace x = skip xs - skip xss = xss - call (Other "(":xs) = (args (0::Int) [] [] . skip) xs - call _ = Nothing - args 0 w acc ( Other ")" :xs) = Just (reverse (addone w acc), xs) - args 0 w acc ( Other "," :xs) = args 0 [] (addone w acc) (skip xs) - args n w acc (x@(Other "("):xs) = args (n+1) (x:w) acc xs - args n w acc (x@(Other ")"):xs) = args (n-1) (x:w) acc xs - args n w acc ( Ident _ v :xs) = args n (Ident p v:w) acc xs - args n w acc (x@(Other _) :xs) = args n (x:w) acc xs - args _ _ _ _ = Nothing - addone w acc = reverse (skip w): acc
− examples/CppHs/Language/Preprocessor/Unlit.hs
@@ -1,72 +0,0 @@--- | Part of this code is from "Report on the Programming Language Haskell", --- version 1.2, appendix C. -module Language.Preprocessor.Unlit (unlit) where - -import Data.Char -import Data.List (isPrefixOf) - -data Classified = Program String | Blank | Comment - | Include Int String | Pre String - -classify :: [String] -> [Classified] -classify [] = [] -classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs - where allProg [] = [] -- Should give an error message, - -- but I have no good position information. - allProg (('\\':x):xs) | "end{code}"`isPrefixOf`x = Blank : classify xs - allProg (x:xs) = Program x:allProg xs -classify (('>':x):xs) = Program (' ':x) : classify xs -classify (('#':x):xs) = (case words x of - (line:rest) | all isDigit line - -> Include (read line) (unwords rest) - _ -> Pre x - ) : classify xs ---classify (x:xs) | "{-# LINE" `isPrefixOf` x = Program x: classify xs -classify (x:xs) | all isSpace x = Blank:classify xs -classify (x:xs) = Comment:classify xs - -unclassify :: Classified -> String -unclassify (Program s) = s -unclassify (Pre s) = '#':s -unclassify (Include i f) = '#':' ':show i ++ ' ':f -unclassify Blank = "" -unclassify Comment = "" - --- | 'unlit' takes a filename (for error reports), and transforms the --- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> String -unlit file lhs = (unlines - . map unclassify - . adjacent file (0::Int) Blank - . classify) (inlines lhs) - -adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified] -adjacent file 0 _ (x :xs) = x : adjacent file 1 x xs -- force evaluation of line number -adjacent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment") -adjacent file n y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@(Program _) (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program") -adjacent file n y@Comment (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@Comment (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n y@Blank (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@Blank (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n _ (x@next :xs) = x: adjacent file (n+1) x xs -adjacent file n _ [] = [] - -message :: String -> Int -> String -> String -> String -message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" -message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" -message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n" - - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. -inlines :: String -> [String] -inlines s = lines' s id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) -
− examples/Project/cpp-opt/A.hs
@@ -1,6 +0,0 @@-{-# LANGUAGE CPP #-} -module A where - -#ifndef MACRO -"The macro 'MACRO' defined in the cabal file is not applied." -#endif
− examples/Project/cpp-opt/some-test-package.cabal
@@ -1,19 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 - cpp-options: -DMACRO
− examples/Project/has-cabal/A.hs
@@ -1,3 +0,0 @@-module A where - -x = ()
− examples/Project/has-cabal/some-test-package.cabal
@@ -1,18 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010
− examples/Project/multi-packages-flags/package1/A.hs
@@ -1,3 +0,0 @@-module A where - -x = \case () -> ()
− examples/Project/multi-packages-flags/package1/package1.cabal
@@ -1,19 +0,0 @@-name: package1 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 - default-extensions: LambdaCase
− examples/Project/multi-packages-flags/package2/B.hs
@@ -1,3 +0,0 @@-module B where - -x = (,())
− examples/Project/multi-packages-flags/package2/package2.cabal
@@ -1,19 +0,0 @@-name: package2 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: B - build-depends: base - default-language: Haskell2010 - default-extensions: TupleSections
− examples/Project/multi-packages/package1/A.hs
@@ -1,3 +0,0 @@-module A where - -x = ()
− examples/Project/multi-packages/package1/package1.cabal
@@ -1,18 +0,0 @@-name: package1 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010
− examples/Project/multi-packages/package2/B.hs
@@ -1,3 +0,0 @@-module B where - -x = ()
− examples/Project/multi-packages/package2/package2.cabal
@@ -1,18 +0,0 @@-name: package2 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: B - build-depends: base - default-language: Haskell2010
− examples/Project/no-cabal/A.hs
@@ -1,3 +0,0 @@-module A where - -x = ()
− examples/Project/reloading/A.hs
@@ -1,5 +0,0 @@-module A where - -import B - -a = b
− examples/Project/reloading/B.hs
@@ -1,5 +0,0 @@-module B where - -import C - -b = c
− examples/Project/reloading/C.hs
@@ -1,3 +0,0 @@-module C where - -c = ()
− examples/Project/selection/B.hs
@@ -1,5 +0,0 @@-module B where - -import C - -b = c
− examples/Project/selection/C.hs
@@ -1,3 +0,0 @@-module C where - -c = ()
− examples/Project/source-dir-outside/some-test-package.cabal
@@ -1,19 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - hs-source-dirs: ../src - build-depends: base - default-language: Haskell2010
− examples/Project/source-dir/some-test-package.cabal
@@ -1,19 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - hs-source-dirs: src - build-depends: base - default-language: Haskell2010
− examples/Project/source-dir/src/A.hs
@@ -1,3 +0,0 @@-module A where - -x = ()
− examples/Project/src/A.hs
@@ -1,3 +0,0 @@-module A where - -x = ()
− examples/Project/with-main-renamed/A.hs
@@ -1,3 +0,0 @@-module Main where - -main = putStrLn "Hello World"
− examples/Project/with-main-renamed/some-test-package.cabal
@@ -1,18 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -executable foo - main-is: A.hs - build-depends: base - default-language: Haskell2010
− examples/Project/with-main/Main.hs
@@ -1,3 +0,0 @@-module Main where - -main = putStrLn "Hello World"
− examples/Project/with-main/some-test-package.cabal
@@ -1,18 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -executable foo - main-is: Main.hs - build-depends: base - default-language: Haskell2010
− examples/Project/with-multi-main/A.hs
@@ -1,5 +0,0 @@-module Main where - -import B - -main = putStrLn (b ++ " World")
− examples/Project/with-multi-main/B.hs
@@ -1,3 +0,0 @@-module B where - -b = "Hello"
− examples/Project/with-multi-main/Main.hs
@@ -1,3 +0,0 @@-module Main where - -main = putStrLn "Hello World"
− examples/Project/with-multi-main/some-test-package.cabal
@@ -1,24 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -executable foo - main-is: A.hs - build-depends: base - default-language: Haskell2010 - other-modules: B - -executable bar - main-is: Main.hs - build-depends: base - default-language: Haskell2010
− examples/Project/with-other-executable/A.hs
@@ -1,3 +0,0 @@-module A where - -main = putStrLn "Hello World"
− examples/Project/with-other-executable/some-test-package.cabal
@@ -1,19 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -executable foo - main-is: A.hs - build-depends: base - default-language: Haskell2010 - ghc-options: -main-is A.main
− examples/Project/working-dir/data.txt
− examples/Project/working-dir/some-test-package.cabal
@@ -1,19 +0,0 @@-name: some-test-package -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - hs-source-dirs: src - build-depends: base, directory, filepath - default-language: Haskell2010
− examples/Project/working-dir/src/A.hs
@@ -1,7 +0,0 @@-{-# LANGUAGE TemplateHaskell #-} -module A where - -import Language.Haskell.TH -import System.FilePath - -$(location >>= \loc -> runIO (readFile (takeDirectory (takeDirectory (loc_filename loc)) </> "data.txt")) >> return [])
+ examples/example-project/Demo.hs view
@@ -0,0 +1,3 @@+module Demo where + +a = ()
exe/Main.hs view
@@ -1,13 +1,63 @@ module Main where -import System.IO -import System.Environment -import System.Exit +import System.Exit (exitSuccess, exitFailure) +import System.IO (IO, stdout, stdin) +import Options.Applicative +import Options.Applicative.Types +import Control.Monad +import Control.Monad.Reader +import Data.Semigroup ((<>)) +import Data.List +import Data.List.Split -import Language.Haskell.Tools.Refactor.CLI +import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) +import Language.Haskell.Tools.Refactor.CLI (normalRefactorSession, CLIOptions(..)) main :: IO () -main = exit =<< refactorSession stdin stdout =<< getArgs +main = exit =<< normalRefactorSession builtinRefactorings stdin stdout =<< execParser opts where exit :: Bool -> IO () exit True = exitSuccess - exit False = exitFailure+ exit False = exitFailure + opts = info (cliOptions <**> helper) + (fullDesc + <> progDesc "Run a refactoring or open a session" + <> header "ht-refact: a command-line interface for Haskell-tools") + +cliOptions :: Parser CLIOptions +cliOptions = CLIOptions <$> version <*> verb <*> oneShot <*> noWatch <*> watch <*> ghcFlags + <*> packages + where version = switch (long "version" + <> short 'v' + <> help "Show the version of this software") + verb = switch (long "verbose" + <> help "Prints debugging information.") + oneShot + = optional $ strOption (long "execute" + <> short 'e' + <> metavar "COMMAND" + <> help "Commands to execute in a one-shot refactoring run, separated by semicolons.") + noWatch = switch (long "no-watch" + <> help "Disables file system watching.") + watch = optional $ strOption + (long "watch-exe" + <> short 'w' + <> help "The file path of the watch executable that is used to monitor file system changes." + <> metavar "WATH_PATH") + ghcFlags + = optional $ option ghcFlagsParser + (long "ghc-options" + <> short 'g' + <> metavar "GHC_OPTIONS" + <> help "Flags passed to GHC when loading the packages, separated by spaces.") + where ghcFlagsParser :: ReadM [String] + ghcFlagsParser + = ReadM $ do str <- ask + let str' = case str of '=':rest -> rest + other -> other + let splitted = splitOn " " str' + let wrong = filter (not . isPrefixOf "-") splitted + when (not $ null wrong) + $ fail ("The following arguments passed as ghc-options are not flags: " ++ intercalate " " wrong) + return splitted + packages = many $ strArgument (metavar "PACKAGE_ROOT" + <> help "The root folder of packages that are refactored")
haskell-tools-cli.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-cli -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Command-line frontend for Haskell-tools Refact description: Command-line frontend for Haskell-tools Refact. Not meant as a final product, only for demonstration purposes. homepage: https://github.com/haskell-tools/haskell-tools @@ -11,39 +11,7 @@ build-type: Simple cabal-version: >=1.10 -extra-source-files: examples/CppHs/Language/Preprocessor/*.hs - , examples/CppHs/Language/Preprocessor/Cpphs/*.hs - , bench-tests/*.txt - , examples/Project/cpp-opt/*.hs - , examples/Project/cpp-opt/*.cabal - , examples/Project/has-cabal/*.hs - , examples/Project/has-cabal/*.cabal - , examples/Project/multi-packages/package1/*.hs - , examples/Project/multi-packages/package1/*.cabal - , examples/Project/multi-packages/package2/*.hs - , examples/Project/multi-packages/package2/*.cabal - , examples/Project/multi-packages-flags/package1/*.hs - , examples/Project/multi-packages-flags/package1/*.cabal - , examples/Project/multi-packages-flags/package2/*.hs - , examples/Project/multi-packages-flags/package2/*.cabal - , examples/Project/no-cabal/*.hs - , examples/Project/reloading/*.hs - , examples/Project/selection/*.hs - , examples/Project/source-dir/*.cabal - , examples/Project/source-dir/src/*.hs - , examples/Project/source-dir-outside/*.cabal - , examples/Project/working-dir/src/*.hs - , examples/Project/working-dir/*.cabal - , examples/Project/working-dir/*.txt - , examples/Project/with-main/*.hs - , examples/Project/with-main/*.cabal - , examples/Project/with-main-renamed/*.hs - , examples/Project/with-main-renamed/*.cabal - , examples/Project/with-multi-main/*.hs - , examples/Project/with-multi-main/*.cabal - , examples/Project/with-other-executable/*.hs - , examples/Project/with-other-executable/*.cabal - , examples/Project/src/*.hs +extra-source-files: examples/example-project/*.hs library build-depends: base >= 4.9 && < 4.10 @@ -56,9 +24,9 @@ , ghc-paths >= 0.1 && < 0.2 , references >= 0.3 && < 0.4 , strict >= 0.3 && < 0.4 - , haskell-tools-ast >= 0.8 && < 0.9 - , haskell-tools-prettyprint >= 0.8 && < 0.9 - , haskell-tools-refactor >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.9 && < 0.10 + , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 + , haskell-tools-daemon >= 0.9 && < 0.10 exposed-modules: Language.Haskell.Tools.Refactor.CLI , Paths_haskell_tools_cli default-language: Haskell2010 @@ -67,18 +35,14 @@ executable ht-refact ghc-options: -rtsopts build-depends: base >= 4.9 && < 4.10 - , haskell-tools-cli >= 0.8 && < 0.9 - hs-source-dirs: exe - main-is: Main.hs - default-language: Haskell2010 - -executable ht-test-stackage - build-depends: base >= 4.9 && < 4.10 - , directory >= 1.2 && < 1.4 - , process >= 1.4 && < 1.5 , split >= 0.2 && < 0.3 - ghc-options: -threaded -with-rtsopts=-M4g - hs-source-dirs: test-stackage + , mtl >= 2.2 && < 2.3 + , directory >= 1.2 && < 1.4 + , filepath >= 1.4 && < 2.0 + , optparse-applicative >= 0.13 && < 0.14 + , haskell-tools-cli + , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 + hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 @@ -92,16 +56,29 @@ , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 - , haskell-tools-cli >= 0.8 && < 0.9 , knob >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 + , haskell-tools-cli + , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 default-language: Haskell2010 +executable ht-test-stackage + build-depends: base >= 4.9 && < 4.10 + , directory >= 1.2 && < 1.4 + , process >= 1.4 && < 1.5 + , split >= 0.2 && < 0.3 + , filepath >= 1.4 && < 2.0 + , optparse-applicative >= 0.13 && < 0.14 + , Glob >= 0.8 && < 0.9 + ghc-options: -threaded + hs-source-dirs: test-stackage + main-is: Main.hs + default-language: Haskell2010 + benchmark cli-benchmark type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g build-depends: base >= 4.9 && < 4.10 - , haskell-tools-cli >= 0.8 && < 0.9 , criterion >= 1.1 && < 1.3 , time >= 1.6 && < 1.7 , aeson >= 1.0 && < 1.3 @@ -110,5 +87,8 @@ , knob >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 , split >= 0.2 && < 0.3 + , haskell-tools-cli + , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 hs-source-dirs: benchmark main-is: Main.hs + default-language: Haskell2010
test-stackage/Main.hs view
@@ -1,85 +1,133 @@-{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase + , TypeApplications + , TupleSections + , ScopedTypeVariables + #-} module Main where -import Control.Applicative +import Control.Applicative ((<$>)) +import Control.Concurrent (threadDelay) import Control.Exception import Control.Monad +import Data.List +import Options.Applicative +import Data.Semigroup ((<>)) +import Data.List.Split (splitOn) import System.Directory -import System.IO +import System.FilePath +import System.FilePath.Glob (glob) +import System.Environment (getArgs) +import System.Exit (ExitCode(..)) import System.Process -import System.Timeout -import System.Environment -import System.Exit -import Control.Concurrent -import Data.List -import Data.List.Split -data Result = GetFailure - | BuildFailure - | RefactError - | WrongCodeError - | OK - deriving Show - main :: IO () -main = do args <- getArgs - testHackage args +main = testStackage =<< execParser opts + where opts = info (options <**> helper) + (fullDesc + <> progDesc "Tests the Haskell-tools framework with stackage packages." + <> header "ht-test-stackage: a tester utility for Haskell-tools") -testHackage :: [String] -> IO () -testHackage args = do - createDirectoryIfMissing False workDir - withCurrentDirectory workDir $ do - packages <- lines <$> readFile (last args) - alreadyTested <- if noRetest then do appendFile resultFile "" - map (head . splitOn ";") . filter (not . null) . lines - <$> readFile resultFile - else writeFile resultFile "" >> return [] +options :: Parser StackageTestConfig +options = StackageTestConfig <$> noload <*> noretest <*> result <*> srcdir <*> logdir <*> inputfile + where noload = switch (long "no-load" + <> help "Don't download the package, use the existing sources.") + noretest = switch (long "no-retest" + <> help "Don't run the test on packages already in the results file.") + srcdir + = strOption (long "src-dir" + <> short 't' + <> metavar "PATH" + <> showDefault + <> value "stackage-test" + <> help "The directory where the downloaded sources should be stored.") + logdir + = strOption (long "log-dir" + <> short 'l' + <> metavar "PATH" + <> showDefault + <> value "stackage-test-logs" + <> help "The directory where the log files should be stored.") + result + = strOption (long "result" + <> short 'r' + <> metavar "FILE" + <> showDefault + <> value ("results.csv") + <> help "The text file where the results are stored in csv format.") + inputfile = strArgument (metavar "FILE") + + +data StackageTestConfig = StackageTestConfig { noLoad :: Bool + , noRetest :: Bool + , resultFile :: FilePath + , sourceDirectory :: FilePath + , logDirectory :: FilePath + , inputFile :: FilePath + } + +testStackage :: StackageTestConfig -> IO () +testStackage config = do + packages <- lines <$> readFile (inputFile config) + alreadyTested + <- if noRetest config + then do appendFile (resultFile config) "" + map (head . splitOn ";") . filter (not . null) . lines + <$> readFile (resultFile config) + else writeFile (resultFile config) "" >> return [] let filteredPackages = packages \\ alreadyTested - createDirectoryIfMissing False "logs" + createDirectoryIfMissing False (logDirectory config) mapM_ testAndEvaluate filteredPackages - where workDir = "stackage-test" - resultFile = "results.csv" - - noRetest = "-no-retest" `elem` args - noLoad = "-no-load" `elem` args - testAndEvaluate p = do - (res, problem) <- testPackage noLoad p - appendFile resultFile (p ++ ";" ++ show res ++ " ; " ++ problem ++ "\n") + where testAndEvaluate p = do + (res, problem) <- testPackage (noLoad config) (sourceDirectory config) (logDirectory config) p + appendFile (resultFile config) (p ++ ";" ++ show res ++ " ; " ++ problem ++ "\n") -testPackage :: Bool -> String -> IO (Result, String) -testPackage noLoad pack = do - res <- runCommands $ load - ++ [ Left ("stack build --test --no-run-tests --bench --no-run-benchmarks > logs\\" ++ pack ++ "-build-log.txt 2>&1", BuildFailure) - -- correct rts option handling (on windows) requires stack 1.4 - , let autogenPath = "tested-package\\.stack-work\\dist\\" ++ snapshotId ++ "\\build\\autogen" - logPath = "logs\\" ++ pack ++ "-refact-log.txt 2>&1" - dbPaths = ["C:\\Users\\nboldi\\AppData\\Local\\Programs\\stack\\x86_64-windows\\ghc-8.0.2\\lib\\package.conf.d", "C:\\sr\\snapshots\\c095693b\\pkgdb"] - in Left ("stack exec ht-refact --stack-yaml=..\\stack.yaml --rts-options -M4G -- -one-shot -refactoring=ProjectOrganizeImports tested-package " ++ autogenPath ++ " -clear-package-db" ++ concatMap (" -package-db " ++) dbPaths ++ " -package base > " ++ logPath, RefactError) - , Left ("stack build > logs\\" ++ pack ++ "-reload-log.txt 2>&1", WrongCodeError) - ] +testPackage :: Bool -> FilePath -> FilePath -> String -> IO (Result, String) +testPackage noLoad sourceDirectory logDirectory pack = do + baseDir <- getCurrentDirectory + let pkgLoc = baseDir </> sourceDirectory </> pack + buildLogPath = baseDir </> logDirectory </> (pack ++ "-build-log.txt") + refLogPath = baseDir </> logDirectory </> (pack ++ "-refact-log.txt") + reloadLogPath = baseDir </> logDirectory </> (pack ++ "-reload-log.txt") + res <- runCommands (cleanup pkgLoc) + $ init + ++ load + ++ [ Left ("stack init > " ++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure) + , Left ("stack build --test --no-run-tests --bench --no-run-benchmarks --ghc-options=\"-w\" > " + ++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure) + -- correct rts option handling (on windows) requires stack 1.4 + , Left ("stack exec --RTS -- ht-refact +RTS -M4G -RTS --no-watch --ghc-options=\"-w\" " + ++ " --execute=\"ProjectOrganizeImports\" . > " + ++ refLogPath ++ " 2>&1", pkgLoc, RefactError) + , Left ("stack build > " ++ reloadLogPath ++ " 2>&1", pkgLoc, WrongCodeError) + ] problem <- case res of - RefactError -> map (\case '\n' -> ' '; c -> c) <$> readFile ("logs\\" ++ pack ++ "-refact-log.txt") - WrongCodeError -> map (\case '\n' -> ' '; c -> c) <$> readFile ("logs\\" ++ pack ++ "-reload-log.txt") + RefactError -> map (\case '\n' -> ' '; c -> c) <$> readFile refLogPath + WrongCodeError -> map (\case '\n' -> ' '; c -> c) <$> readFile reloadLogPath _ -> return "" return (res, problem) - where testedDir = "tested-package" - snapshotId = "ca59d0ab" - refreshDir = refreshDir' 5 - refreshDir' n = do createDirectoryIfMissing False testedDir - removeDirectoryRecursive testedDir - renameDirectory pack testedDir - `catch` \e -> if n <= 0 - then throwIO (e :: IOException) - else do threadDelay 500000 - refreshDir' (n-1) - load = if noLoad then [] else [ Left ("cabal get " ++ pack, GetFailure), Right refreshDir ] + where load = if noLoad + then [] + else [ Right $ (either (\(e :: SomeException) -> return ()) return =<<) + $ try (removeDirectoryRecursive (sourceDirectory </> pack)) + , Left ("cabal get -d " ++ sourceDirectory ++ " " ++ pack, ".", GetFailure) ] + init = [ Right (forM_ [sourceDirectory,logDirectory] (createDirectoryIfMissing True)) ] + cleanup pkgLoc = either (print @SomeException) return =<< try (removeDirectoryRecursive pkgLoc) -runCommands :: [Either (String, Result) (IO ())] -> IO Result -runCommands [] = return OK -runCommands (Left (cmd,failRes) : rest) = do - pr <- runCommand cmd +data Result = GetFailure + | BuildFailure + | RefactError + | WrongCodeError + | OK + deriving Show + +runCommands :: IO () -> [Either (String, FilePath, Result) (IO ())] -> IO Result +runCommands final [] = final >> return OK +runCommands final (Left (cmd,wd,failRes) : rest) = do + baseDir <- getCurrentDirectory + let sh = shell cmd + (_, _, _, pr) <- createProcess sh{ cwd = Just (baseDir </> wd) } exitCode <- waitForProcess pr - case exitCode of ExitSuccess -> runCommands rest - ExitFailure _ -> return failRes -runCommands (Right act : rest) = act >> runCommands rest + case exitCode of ExitSuccess -> runCommands final rest + ExitFailure _ -> final >> return failRes +runCommands final (Right act : rest) = act >> runCommands final rest
test/Main.hs view
@@ -1,158 +1,57 @@ module Main where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty (TestTree, testGroup, defaultMain) +import Test.Tasty.HUnit (assertBool, testCase) -import System.Exit +import Control.Monad ((=<<), when, forM_) +import Data.ByteString.Char8 (pack, unpack) +import Data.Knob (newKnob, newFileHandle, getContents) +import qualified Data.List as List import System.Directory import System.FilePath -import Control.Monad -import Control.Exception -import qualified Data.List as List -import Data.Knob -import Data.ByteString.Char8 (pack, unpack) import System.IO +import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) import Language.Haskell.Tools.Refactor.CLI main :: IO () -main = do nightlyTests <- benchTests - defaultMain $ testGroup "cli tests" (allTests ++ nightlyTests) +main = defaultMain allTests -allTests :: [TestTree] -allTests = map makeCliTest cliTests +allTests :: TestTree +allTests + = testGroup "cli-tests" [ + makeCliTest ( "batch", ["examples"</>"example-project"] + , \s -> CLIOptions False False (Just $ "RenameDefinition " ++ "examples"</>("example-project"++s)</>"Demo.hs" ++ " 3:1 b") + True Nothing Nothing + , \_ -> "" + , \s _ -> checkFileContent ("examples"</>("example-project"++s)</>"Demo.hs") + ("b = ()" `List.isInfixOf`)) + , makeCliTest ( "session", ["examples"</>"example-project"], \_ -> CLIOptions False False Nothing True Nothing Nothing + , \s -> "RenameDefinition " ++ "examples"</>("example-project"++s)</>"Demo.hs" ++ " 3:1 b\nExit\n" + , \s _ -> checkFileContent ("examples"</>("example-project"++s)</>"Demo.hs") + ("b = ()" `List.isInfixOf`)) + ] -makeCliTest :: ([FilePath], [String], String, String) -> TestTree -makeCliTest (dirs, args, input, output) +makeCliTest :: (String, [FilePath], String -> [FilePath] -> CLIOptions, String -> String, String -> String -> IO Bool) -> TestTree +makeCliTest (name, dirs, args, input, outputCheck) = let dir = joinPath $ longestCommonPrefix $ map splitDirectories dirs - testdirs = map (\d -> if d == dir then dir ++ "_test" else (dir ++ "_test" </> makeRelative dir d)) dirs - in testCase dir $ do - exists <- doesDirectoryExist (dir ++ "_test") - when exists $ removeDirectoryRecursive (dir ++ "_test") - copyDir dir (dir ++ "_test") - inKnob <- newKnob (pack input) + testdirs = map (\d -> if d == dir then dir ++ suffix else (dir ++ suffix </> makeRelative dir d)) dirs + in testCase name $ do + copyDir dir (dir ++ suffix) + inKnob <- newKnob (pack (input suffix)) inHandle <- newFileHandle inKnob "<input>" ReadMode outKnob <- newKnob (pack []) outHandle <- newFileHandle outKnob "<output>" WriteMode - res <- refactorSession inHandle outHandle (args ++ testdirs) + res <- normalRefactorSession builtinRefactorings inHandle outHandle (args suffix testdirs) actualOut <- Data.Knob.getContents outKnob - assertEqual "" (filter (/= '\r') output) (filter (/= '\r') $ unpack actualOut) - `finally` removeDirectoryRecursive (dir ++ "_test") - -cliTests :: [([FilePath], [String], String, String)] -cliTests - = [ ( [testRoot </> "Project" </> "cpp-opt"] - , ["-dry-run", "-one-shot", "-module-name=A"] - , "", oneShotPrefix ["A"] ++ "-module-name or -refactoring flag not specified correctly. Not doing any refactoring.\n") - , ( [testRoot </> "Project" </> "source-dir"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] - , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") - , ( [testRoot </> "Project" </> "working-dir"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"OrganizeImports\""] - , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\n{-# LANGUAGE TemplateHaskell #-}\nmodule A where\n\nimport Language.Haskell.TH\nimport System.FilePath\n\n$(location >>= \\loc -> runIO (readFile (takeDirectory (takeDirectory (loc_filename loc)) </> \"data.txt\")) >> return [])\n\n") - , ( [testRoot </> "Project" </> "source-dir-outside"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] - , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") - , ( [testRoot </> "Project" </> "no-cabal"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] - , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") - , ( [testRoot </> "Project" </> "has-cabal"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] - , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") - , ( [testRoot </> "Project" </> "selection"], [] - , "SelectModule C\nSelectModule B\nRenameDefinition 5:1-5:2 bb\nSelectModule C\nRenameDefinition 3:1-3:2 cc\nExit" - , prefixText ["C","B"] ++ "no-module-selected> C> B> " - ++ reloads ["B"] ++ "B> C> " - ++ reloads ["C", "B"] ++ "C> " - ) - , ( [testRoot </> "Project" </> "reloading"], [] - , "SelectModule C\nRenameDefinition 3:1-3:2 cc\nSelectModule B\nRenameDefinition 5:1-5:2 bb\nExit" - , prefixText ["C","B","A"] ++ "no-module-selected> C> " - ++ reloads ["C", "B", "A"] ++ "C> B> " - ++ reloads ["B", "A"] ++ "B> ") - , ( map ((testRoot </> "Project" </> "multi-packages") </>) ["package1", "package2"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], "" - , oneShotPrefix ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n" - ) - , ( map ((testRoot </> "Project" </> "multi-packages-flags") </>) ["package1", "package2"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], "" - , oneShotPrefix ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = \\case () -> ()\n" - ) - , ( [testRoot </> "Project" </> "with-main"] - , ["-dry-run", "-one-shot", "-module-name=Main", "-refactoring=\"GenerateSignature 3:1\""] - , "", oneShotPrefix ["Main"] ++ "### Module changed: Main\n### new content:\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"Hello World\"\n") - , ( [testRoot </> "Project" </> "with-main-renamed"] - , ["-dry-run", "-one-shot", "-module-name=Main", "-refactoring=\"GenerateSignature 3:1\""] - , "", oneShotPrefix ["Main"] ++ "### Module changed: Main\n### new content:\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"Hello World\"\n") - , ( [testRoot </> "Project" </> "with-multi-main"], ["-dry-run", "-one-shot", "-module-name=B", "-refactoring=\"RenameDefinition 3:1 bb\""], "" - , oneShotPrefix ["Main", "B", "Main"] - ++ "### Module changed: B\n### new content:\nmodule B where\n\nbb = \"Hello\"\n" - ++ "### Module changed: Main\n### new content:\nmodule Main where\n\nimport B\n\nmain = putStrLn (bb ++ \" World\")\n") - , ( [testRoot </> "Project" </> "with-other-executable"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1\""] - , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nmain :: IO ()\nmain = putStrLn \"Hello World\"\n") - ] - -benchTests :: IO [TestTree] -benchTests - = forM ["full-1", "full-2", "full-3"] $ \id -> do - commands <- readFile ("bench-tests" </> id <.> "txt") - return $ makeCliTest (["examples" </> "CppHs"], [], filter (/='\r') commands, expectedOut id) - -expectedOut "full-1" - = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.CppIfdef> " - ++ concat (replicate 8 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> ")) -expectedOut "full-2" - = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.MacroPass> " - ++ concat (replicate 3 (reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> ")) -expectedOut "full-3" - = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.CppIfdef> " - ++ concat (replicate 2 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> ")) - ++ "Language.Preprocessor.Cpphs.MacroPass> " - ++ reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> " - ++ "Language.Preprocessor.Cpphs.CppIfdef> " - ++ concat (replicate 3 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> ")) - ++ "Language.Preprocessor.Cpphs.MacroPass> " - ++ reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> " - ++ "Language.Preprocessor.Cpphs.CppIfdef> " - ++ concat (replicate 3 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> ")) - -cppIfDefReloads = [ "Language.Preprocessor.Cpphs.CppIfdef" - , "Language.Preprocessor.Cpphs.RunCpphs" - , "Language.Preprocessor.Cpphs" ] -macroPassReloads = "Language.Preprocessor.Cpphs.MacroPass" : cppIfDefReloads - -cppHsMods = [ "Language.Preprocessor.Unlit" - , "Language.Preprocessor.Cpphs.SymTab" - , "Language.Preprocessor.Cpphs.Position" - , "Language.Preprocessor.Cpphs.ReadFirst" - , "Language.Preprocessor.Cpphs.Options" - , "Language.Preprocessor.Cpphs.HashDefine" - , "Language.Preprocessor.Cpphs.Tokenise" - , "Language.Preprocessor.Cpphs.MacroPass" - , "Language.Preprocessor.Cpphs.CppIfdef" - , "Language.Preprocessor.Cpphs.RunCpphs" - , "Language.Preprocessor.Cpphs" ] - -testRoot = "examples" - -prefixText :: [String] -> String -prefixText mods - = "Compiling modules. This may take some time. Please wait.\n" - ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods - ++ "All modules loaded. Use 'SelectModule module-name' to select a module.\n" - -oneShotPrefix :: [String] -> String -oneShotPrefix mods - = "Compiling modules. This may take some time. Please wait.\n" - ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods - ++ "All modules loaded.\n" - + assertBool ("The result is not what is expected. Output: " ++ (unpack actualOut)) + =<< outputCheck suffix (unpack actualOut) + where suffix = "_test_" ++ name -reloads :: [String] -> String -reloads mods = concatMap (\m -> "Re-loaded module: " ++ m ++ "\n") mods +checkFileContent :: FilePath -> (String -> Bool) -> IO Bool +checkFileContent fp check = check <$> readFile fp -copyDir :: FilePath -> FilePath -> IO () +copyDir :: FilePath -> FilePath -> IO () copyDir src dst = do exists <- doesDirectoryExist dst -- clear the target directory from possible earlier test runs @@ -168,12 +67,12 @@ then copyDir srcPath dstPath else copyFile srcPath dstPath +longestCommonPrefix :: (Eq a) => [[a]] -> [a] +longestCommonPrefix = foldl1 commonPrefix + commonPrefix :: (Eq e) => [e] -> [e] -> [e] commonPrefix _ [] = [] commonPrefix [] _ = [] commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys | otherwise = [] - -longestCommonPrefix :: (Eq a) => [[a]] -> [a] -longestCommonPrefix = foldl1 commonPrefix