Implement proper Cabal tests out of the existing structure

SJW.cabal

@@ -48,3 +48,28 @@ executable sjw
                      , text
   default-language:    Haskell2010
   ghc-options:         -Wall
+
+benchmark big-src
+  type:                exitcode-stdio-1.0
+  main-is:             benchmark/Main.hs
+  build-depends:       base >= 4.9 && <4.15
+                     , directory
+                     , filepath
+                     , random
+                     , SJW
+                     , time
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+test-suite tests
+  type:                detailed-0.9
+  test-module:         Tests
+  build-depends:       base >=4.11 && <4.13
+                     , Cabal
+                     , directory
+                     , filepath
+                     , random
+                     , SJW
+  hs-source-dirs:      test
+  default-language:    Haskell2010
+  ghc-options:         -Wall

benchmark/Main.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Main where
+
+import SJW (Path(..), compile, source, sourceCode)
+import Control.Monad (foldM)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
+import System.FilePath ((</>), (<.>))
+import System.Random (randomRIO)
+import Text.Printf (printf)
+
+data FakeModule = FakeModule {
+      name :: Path
+    , dependencies :: [Path]
+  } deriving Show
+type DAG = [FakeModule]
+
+moduleNames :: [String]
+moduleNames = (:[]) <$> ['A'..'Z']
+
+emptyModule :: Path -> FakeModule
+emptyModule name = FakeModule {name, dependencies = []}
+
+addDependency :: Path -> FakeModule -> FakeModule
+addDependency path fakeModule = fakeModule {
+    dependencies = path : (dependencies fakeModule)
+  }
+
+destDir :: FilePath
+destDir = "/tmp/SJW-benchmark/giant"
+
+generateCode :: FakeModule -> String
+generateCode (FakeModule {dependencies}) = unlines $
+  (printf "import %s;" . show <$> dependencies)
+  ++ [
+      ""
+    , "return {"
+    , " s: 'truc'"
+    , "};"
+  ]
+
+combinations :: [a] -> [[a]]
+combinations l = ((:[]) <$> l) ++ concat [(:m) <$> l | m <- combinations l]
+
+edit :: Int -> (a -> a) -> [a] -> [a]
+edit 0 _ l = l
+edit 1 _ [] = []
+edit 1 f (x:xs) = (f x):xs
+edit n f l =
+  let (beginning, end) = splitAt half l in
+  edit m f beginning ++ edit (n - m) f end
+  where
+    half = length l `div` 2
+    m = n `div` 2
+
+generateDAG :: Int -> Int -> (Int, Int) -> IO DAG
+generateDAG size maxTargets generationSize =
+  let paths = ["Main"] : (take size $ combinations moduleNames) in
+  addEdges [] $ emptyModule . Path <$> paths
+  where
+    addEdges ready nodes
+      | length nodes < 2 = return $ nodes ++ ready
+      | otherwise = do
+        (targets, chosen) <- generation nodes
+        addEdges (chosen ++ ready) =<< foldM edgesTo targets chosen
+    generation nodes = do
+      genSize <- randomRIO generationSize
+      return $ splitAt (max 1 (length nodes - genSize)) nodes
+    edgesTo [mainModule] (FakeModule {name}) =
+      return [addDependency name mainModule]
+    edgesTo targets (FakeModule {name}) = do
+      nTargets <- randomRIO (1, maxTargets)
+      (intact, nextGen) <- generation targets
+      return (intact ++ edit nTargets (addDependency name) nextGen)
+
+writeFakeModule :: FakeModule -> IO ()
+writeFakeModule fakeModule@(FakeModule {name = Path components}) =
+  let (parents, fileName) = splitAt (length components - 1) components in
+  let directory = foldl (</>) destDir parents in do
+  createDirectoryIfMissing True directory
+  writeFile (directory </> head fileName <.> "js") $ generateCode fakeModule
+
+main :: IO ()
+main = do
+  directoryExists <- doesDirectoryExist destDir
+  if not directoryExists
+  then do
+    createDirectoryIfMissing True destDir
+    generateDAG 10000 10 (50, 100) >>= mapM_ writeFakeModule
+  else return ()
+  start <- getCurrentTime
+  maybe (return ()) (\_ -> return ()) =<< sourceCode =<< compile (source [destDir])
+  end <- getCurrentTime
+  mapM_ putStrLn [
+        "Compiled 10k modules in " ++ show (diffUTCTime end start)
+      , "Left the fake project in " ++ destDir ++ " if you want to poke around"
+    ]

test/Tests.hs

@@ -0,0 +1,42 @@
+module Tests (
+    tests
+  ) where
+
+import Distribution.TestSuite
+import SJW (compile, source)
+import System.FilePath ((</>))
+import Text.Printf (printf)
+
+testData :: FilePath
+testData = "test" </> "data"
+
+checkResult :: (String, Bool) -> IO Progress
+checkResult (dirName, expected) = do
+  result <- either failed passed =<< compile (source [testData </> dirName])
+  return . Finished $ if result == expected then Pass else Fail (explain message)
+  where
+    failed s = putStrLn s>> return False
+    passed _ = return True
+    explain = uncurry (printf "Compilation %sed when it was expected to %s")
+    message = if expected then ("fail", "succeed") else ("succeed", "fail")
+
+makeTest :: (String, Bool) -> TestInstance
+makeTest (patternName, expected) = testInstance
+  where
+    testInstance = TestInstance {
+          run = checkResult (patternName, expected)
+        , name = patternName
+        , tags = []
+        , options = []
+        , setOption = \_ _ -> Right testInstance
+      }
+
+tests :: IO [Test]
+tests = return $ (Test . makeTest) <$> [
+      ("cycle", False)
+    , ("diamond", True)
+    , ("loop", False)
+    , ("q", False)
+    , ("simple", True)
+    , ("triangle", True)
+  ]

test/data/cycle/A.js

@@ -0,0 +1,5 @@
+import B;
+
+return {
+  s: 'a' + B.s
+};

test/data/cycle/B.js

@@ -0,0 +1,5 @@
+import C;
+
+return {
+  s: 'b' + C.s
+};

test/data/cycle/C.js

@@ -0,0 +1,5 @@
+import A;
+
+return {
+  s: 'c' + A.s
+}

test/data/cycle/Main.js

@@ -0,0 +1,3 @@
+import A;
+
+console.log(A.s);

test/data/diamond/A.js

@@ -0,0 +1,5 @@
+import C;
+
+return {
+  s: "Hello" + C.punctuation
+};

test/data/diamond/B.js

@@ -0,0 +1,5 @@
+import C;
+
+return {
+  s: "world" + C.exclamation
+};

test/data/diamond/C.js

@@ -0,0 +1,4 @@
+return {
+  punctuation: ", ",
+  exclamation: " !"
+};

test/data/diamond/Main.js

@@ -0,0 +1,4 @@
+import A;
+import B;
+
+console.log(A.s + B.s);

test/data/loop/A.js

@@ -0,0 +1,5 @@
+import A;
+
+return {
+  s: 'a' + A.s
+};

test/data/loop/Main.js

@@ -0,0 +1,3 @@
+import A;
+
+console.log(A.s);

test/data/q/A.js

@@ -0,0 +1,5 @@
+import B;
+
+return {
+	s: 'a' + B.s;
+};

test/data/q/B.js

@@ -0,0 +1,5 @@
+import C;
+
+return {
+  s: 'b' + C.s
+};

test/data/q/C.js

@@ -0,0 +1,5 @@
+import D;
+
+return {
+  s: 'c' + D.s
+}

test/data/q/D.js

@@ -0,0 +1,5 @@
+import B;
+
+return {
+  s: 'd' + B.s
+}

test/data/q/Main.js

@@ -0,0 +1,3 @@
+import A;
+
+console.log(A.s);

test/data/simple/A.js

@@ -0,0 +1,3 @@
+return {
+  s: "Hello, "
+};

test/data/simple/B.js

@@ -0,0 +1,3 @@
+return {
+  s: "world !"
+};

test/data/simple/Main.js

@@ -0,0 +1,4 @@
+import A;
+import B;
+
+console.log(A.s + B.s);

test/data/triangle/Main.js

@@ -0,0 +1,4 @@
+import N;
+import O;
+
+console.log(N.s + O.s);

test/data/triangle/N.js

@@ -0,0 +1,5 @@
+import O;
+
+return {
+  s: O.s
+};

test/data/triangle/O.js

@@ -0,0 +1,3 @@
+return {
+  s: 'o'
+};