Improve common code detection (#54)

* Fix common code detection

* Plagiarism progress reports, update .travis.yml

* Update .travis.yml

* Update .travis.yml

* Update .travis.yml

* Fix

Author: chameco

.travis.yml

@@ -14,8 +14,9 @@ before_install:
 - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
 - rvm use 2.1 --install --binary --fuzzy
 install:
-- travis_wait 30 stack --no-terminal --install-ghc --copy-bins build
-- stack --no-terminal install hlint
+- travis_wait 30 stack --install-ghc --copy-bins install language-python
+- travis_wait 30 stack --install-ghc --copy-bins build
+- stack install hlint
 - cp hlint ~/.local/bin
 - gem install danger danger-hlint
 script:

lichen.cabal

@@ -49,6 +49,7 @@ library
                      , process
                      , directory
                      , filepath
+                     , ansi-terminal
                      , aeson
                      , megaparsec
                      , optparse-applicative

src/Lichen/Error.hs

@@ -2,7 +2,7 @@
 
 module Lichen.Error where
 
-import System.IO (stderr)
+import System.IO (stderr, hPutStrLn)
 
 import Data.Monoid ((<>))
 import qualified Data.Text as T
@@ -24,7 +24,7 @@ data LichenError = LexError (ParseError (Token BS.ByteString) Dec)
                  deriving Show
 
 printError :: LichenError -> IO ()
-printError (LexError e) = T.IO.hPutStrLn stderr "Lexer error: " >> putStrLn (parseErrorPretty e)
+printError (LexError e) = T.IO.hPutStrLn stderr "Lexer error: " >> hPutStrLn stderr (parseErrorPretty e)
 printError (ParseError t) = T.IO.hPutStrLn stderr ("Parser error: " <> t)
 printError (InvalidTokenError t) = T.IO.hPutStrLn stderr ("Invalid token error: " <> t)
 printError (InvocationError t) = T.IO.hPutStrLn stderr ("Invocation error: " <> t)

src/Lichen/Plagiarism/Main.hs

@@ -7,6 +7,7 @@ import System.FilePath
 
 import Data.Aeson
 import Data.Semigroup ((<>))
+import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.ByteString.Lazy as BS
 
@@ -24,6 +25,7 @@ import Lichen.Plagiarism.Concatenate
 import Lichen.Plagiarism.Highlight
 import Lichen.Plagiarism.Report
 import Lichen.Plagiarism.Walk
+import Lichen.Plagiarism.Shared
 
 parseOptions :: Config -> Parser Config
 parseOptions dc = Config
@@ -58,11 +60,20 @@ realMain ic = do
             dir <- liftIO $ canonicalizePath p
             pdirs <- liftIO . mapM canonicalizePath $ pastDirs config
             let concatenate = if allVersions config then concatenateAll else concatenateActive
-            concatenate dir
-            mapM_ concatenate pdirs
-            highlight dir
-            mapM_ highlight pdirs
-            prints <- fingerprintDir (language config) (dataDir config </> concatDir config ++ dir)
-            past <- concat <$> mapM (\x -> fingerprintDir (language config) (dataDir config </> concatDir config ++ x)) pdirs
-            report dir prints past
+            progress "Concatenating submissions" $ do
+                concatenate dir
+                mapM_ concatenate pdirs
+            progress "Highlighting concatenated files" $ do
+                highlight dir
+                mapM_ highlight pdirs
+            (prints, past) <- progress "Fingerprinting submissions" $ do
+                prints <- fingerprintDir (language config) (dataDir config </> concatDir config ++ dir)
+                past <- concat <$> mapM (\x -> fingerprintDir (language config) (dataDir config </> concatDir config ++ x)) pdirs
+                return (prints, past)
+            (sprints, spast) <- progress "Detecting shared code" $ do
+                let shared = findShared config (fst <$> prints) (fst <$> past)
+                    sprints = (\(x, t) -> (Set.toList $ Set.difference (Set.fromList x) shared, t)) <$> prints
+                    spast = (\(x, t) -> (Set.toList $ Set.difference (Set.fromList x) shared, t)) <$> past
+                return (sprints, spast)
+            progress "Generating plagiarism reports" $ report dir sprints spast
     where opts c = info (helper <*> parseOptions c) (fullDesc <> progDesc "Run plagiarism detection" <> header "plagiarism - plagiarism detection")

src/Lichen/Plagiarism/Report.hs

@@ -5,7 +5,6 @@ import System.FilePath
 
 import Data.List
 import qualified Data.ByteString.Lazy as BS
-import qualified Data.Set as Set
 
 import Control.Applicative
 import Control.Monad.Reader
@@ -16,20 +15,16 @@ import Lichen.Util
 import Lichen.Config.Plagiarism
 import Lichen.Plagiarism.Winnow
 import Lichen.Plagiarism.Compare
-import Lichen.Plagiarism.Shared
 import Lichen.Plagiarism.Render
 import Lichen.Plagiarism.Render.Index
 import Lichen.Plagiarism.Render.Compare
 
 report :: (Show a, Eq a) => FilePath -> [(Fingerprints, a)] -> [(Fingerprints, a)] -> Plagiarism ()
 report p prints past = do
         config <- ask
-        let shared = findShared config (fst <$> prints) (fst <$> past)
-            sprints = (\(x, t) -> (Set.toList $ Set.difference (Set.fromList x) shared, t)) <$> prints
-            spast = (\(x, t) -> (Set.toList $ Set.difference (Set.fromList x) shared, t)) <$> past
         dstPath <- liftIO $ liftA2 (++) (pure $ dataDir config </> reportDir config) $ canonicalizePath p
         srcPath <- liftIO $ liftA2 (++) (pure $ dataDir config </> concatDir config) $ canonicalizePath p
-        let compared = ccmp (topMatches config) sprints spast
+        let compared = ccmp (topMatches config) prints past
         liftIO $ removeDir dstPath >> createDirectoryIfMissing True dstPath
         liftIO . createDirectoryIfMissing True $ dstPath </> "compare"
         liftIO . BS.writeFile (dstPath </> "index.html") . renderHtml . renderPage config $ renderTable config compared

src/Lichen/Util.hs

@@ -4,10 +4,14 @@ module Lichen.Util where
 
 import System.Directory
 import System.FilePath
+import System.Console.ANSI
+import System.IO (hPutStr, hPutStrLn, stderr)
 
 import Data.List.Split
+import Data.Monoid ((<>))
 
 import Control.Monad
+import Control.Monad.IO.Class
 
 -- Ex: purify [Maybe 1, Nothing, Maybe 3] = [1, 3]
 purify :: [Maybe a] -> [a]
@@ -62,3 +66,12 @@ sq = go . show where
     go ('"':s) | last s == '"' = init s
                | otherwise = s
     go x = x
+
+progress :: MonadIO m => String -> m a -> m a
+progress msg body = do
+        liftIO (hPutStr stderr (msg <> "..."))
+        ret <- body
+        liftIO (hSetSGR stderr [SetColor Foreground Vivid Green])
+        liftIO (hPutStrLn stderr " Done!")
+        liftIO (hSetSGR stderr [Reset])
+        return ret