Fix bug in dependency ordering due to using too naive an approach

CHANGELOG.md

@@ -1,5 +1,10 @@
 # Revision history for SJW
 
+## 0.1.1.1 -- 2020-01-09
+
+* Fix bug in dependency ordering due to using too naive an approach
+* Compiled successfully with base == 4.11
+
 ## 0.1.1.0 -- 2020-01-03
 
 * Imports can now span several lines

SJW.cabal

@@ -3,7 +3,7 @@ cabal-version:       >=1.10
 -- further documentation, see http://haskell.org/cabal/users-guide/
 
 name:                SJW
-version:             0.1.1.0
+version:             0.1.1.1
 synopsis:            The Simple Javascript Wrench is a very simple tool to pack several JS «modules» into a single script.
 -- description:
 homepage:            https://git.marvid.fr/Tissevert/SJW
@@ -21,12 +21,11 @@ executable sjw
   main-is:             Main.hs
   other-modules:       Compiler
                      , Context
+                     , Dependencies
                      , Module
-                     , Module.Environment
                      , Module.File
                      , Module.Imports
                      , Paths_SJW
-                     , Priority
   -- other-extensions:
   build-depends:       attoparsec
                      , base >=4.11 && <4.13

src/Compiler.hs

@@ -8,19 +8,16 @@ module Compiler (
 
 import Context (Context(..), Contextual, Path)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.RWS (asks, gets)
+import Control.Monad.RWS (ask, gets)
 import Data.Map ((!))
 import qualified Data.Map as Map (member)
 import Data.Text (Text, cons)
 import qualified Data.Text as Text (null, unlines)
-import Module (Environment, Failable, Log, Module(..), Log)
+import Dependencies (Failable, solve)
+import Module (Environment, Log, Module(..), Modules(..), register)
 import qualified Module (parse)
-import qualified Module.Environment as Environment (
-    Environment(..), register, reorder
-  )
 import Module.File (File(..), variables)
 import qualified Module.File as File (header, footer)
-import qualified Priority (set, toList)
 
 type Compiler m = (Contextual m, Log m, Environment m, MonadIO m, Failable m)
 
@@ -31,35 +28,35 @@ indent = fmap indentLine
       | Text.null t = t
       | otherwise = cons '\t' t
 
-include :: Environment m => (Int, Path) -> m [Text]
-include (priority, path) = do
-  File {imports, payload} <- gets (file . (! path) . Environment.modules)
+include :: Environment m => Path -> m [Text]
+include path = do
+  File {isMain, imports, payload} <- gets (file . (! path) . modules)
   let (names, values) = unzip $ variables imports
   return $ File.header isMain path names : indent payload ++ File.footer values
-  where
-    isMain = priority == 0
 
-scan :: Compiler m => Int -> Path -> m ()
-scan priority modulePath = do
-  Environment.reorder $ Priority.set modulePath priority
-  alreadyLoaded <- gets (Map.member modulePath . Environment.modules)
+scan :: Compiler m => Bool -> Path -> m ()
+scan isMain modulePath = do
+  alreadyLoaded <- gets (Map.member modulePath . modules)
   if alreadyLoaded then return () else load
   where
     load :: Compiler m => m ()
     load = do
-      newModule <- Module.parse modulePath
-      Environment.register modulePath newModule
-      mapM_ (scan (priority + 1)) $ dependencies newModule
+      newModule <- Module.parse isMain modulePath
+      Module.register modulePath newModule
+      mapM_ (scan False) $ dependencies newModule
 
 body :: Compiler m => m [Text]
 body = do
-  sortedPath <- gets (Priority.toList . Environment.queue)
+  sortedPath <- Dependencies.solve =<< dependenciesGraph
   includes <- concat <$> mapM include sortedPath
   return $ "var modules = {};" : includes
+  where
+    dependenciesGraph = gets (fmap dependencies . modules)
 
 main :: Compiler m => m Text
 main = do
-  scan 0 =<< asks mainModule
+  Context {mainModule} <- ask
+  scan True mainModule
   codeBody <- body
   return . Text.unlines $ openOnLoad : indent codeBody ++ [closeOnLoad]
   where

src/Dependencies.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Dependencies (
+      Dependencies
+    , Failable
+    , solve
+  ) where
+
+import Context (Path)
+import Control.Monad.Except (MonadError(..), runExcept)
+import Control.Monad.RWS (MonadState, MonadWriter, evalRWST, gets, modify, tell)
+import Data.List (intercalate)
+import Data.Map (Map, (!))
+import qualified Data.Map as Map (adjust, toList)
+import Data.Set (Set)
+import Text.Printf (printf)
+
+type Dependencies = Map Path (Set Path)
+type Failable = MonadError String
+
+solve :: Failable m => Dependencies -> m [Path]
+solve dependencies =
+  case runExcept $ evalRWST dfs () initState of
+    Left loop -> throwError $ printLoop loop
+    Right (_, sorted) -> return sorted
+  where
+    initState = State {graph = (,) New <$> dependencies, ariadne = []}
+
+data Flag = New | Temporary | Permanent deriving (Eq, Ord)
+data State = State {
+      graph :: Map Path (Flag, Set Path)
+    , ariadne :: [Path]
+  }
+
+type DFSComputation m = (MonadWriter [Path] m, MonadState State m, MonadError [Path] m)
+
+dfs :: DFSComputation m => m ()
+dfs = do
+  maybeNewNode <- gets (popNew . Map.toList . graph)
+  case maybeNewNode of
+    Nothing -> return ()
+    Just newNode -> visit newNode >> dfs
+  where
+    popNew [] = Nothing
+    popNew ((k, v@(New, _)):_) = Just (k, v)
+    popNew (_:others) = popNew others
+
+modifyState :: MonadState State m => ((Path, Flag), [Path] -> [Path]) -> m ()
+modifyState ((path, flag), f) = modify $ \state -> state {
+      graph = Map.adjust (\(_, set) -> (flag, set)) path $ graph state
+    , ariadne = f $ ariadne state
+  }
+
+visit :: DFSComputation m => (Path, (Flag, Set Path)) -> m ()
+visit (_, (Permanent, _)) = return ()
+visit (_, (Temporary, _)) = throwError =<< gets (reverse . ariadne)
+visit (path, (New, set)) = do
+  modifyState ((path, Temporary), (path:))
+  mapM_ (\depPath -> (,) depPath <$> gets ((!depPath) . graph) >>= visit) set
+  modifyState ((path, Permanent), (drop 1))
+  tell [path]
+
+printLoop :: [Path] -> String
+printLoop [] = "Weird dependencies cycle found"
+printLoop (path:paths) = beginning ++ description paths
+  where
+    beginning = "Dependencies cycle found: "
+    description [] = printf "module %s requires itself." (show path)
+    description _ =
+      printf "%s requires %s which itself requires %s." first others first
+    first = show path
+    others = intercalate " which requires " $ show <$> paths

src/Main.hs

@@ -9,7 +9,7 @@ import Control.Monad.RWS (evalRWST)
 import Data.Text (Text)
 import qualified Data.Text as Text (unpack)
 import Data.Version (showVersion)
-import qualified Module.Environment as Environment (empty)
+import Module (emptyEnvironment)
 import Options.Applicative (
       Parser, execParser, fullDesc, info, header, help, helper, long, metavar
     , short, strArgument, strOption, value
@@ -61,7 +61,7 @@ runCompiler :: Config -> IO (Either String (Text, [String]))
 runCompiler (Config {includes, mainIs, target}) = do
   codePaths <- CodePath . (target:) <$> packages includes
   let initialContext = Context {codePaths, mainModule = read mainIs}
-  runExceptT $ evalRWST Compiler.main initialContext Environment.empty
+  runExceptT $ evalRWST Compiler.main initialContext emptyEnvironment
 
 main :: IO ()
 main = do

src/Module.hs

@@ -3,20 +3,25 @@
 {-# LANGUAGE FlexibleContexts #-}
 module Module (
       Environment
-    , Failable
     , Log
     , Module(..)
+    , Modules(..)
+    , emptyEnvironment
     , parse
+    , register
   ) where
 
 import Context (CodePath(..), Context(..), Contextual, Path(..))
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.RWS (MonadWriter, asks)
+import Control.Monad.RWS (MonadState, MonadWriter, asks, modify)
 import Data.Attoparsec.Text (parseOnly)
-import qualified Data.Set as Set (empty, insert, toList)
+import Data.Map (Map)
+import qualified Data.Map as Map (empty, insert)
+import Data.Set (Set)
+import qualified Data.Set as Set (empty, insert)
 import qualified Data.Text as Text (pack)
-import Module.Environment (HasEnvironment)
+import Dependencies (Failable)
 import Module.File (File(..))
 import qualified Module.File (parser)
 import Module.Imports (Reference(..), recurse)
@@ -27,36 +32,46 @@ import Text.Printf (printf)
 
 data Module = Module {
       file :: Module.File.File
-    , dependencies :: [Path]
+    , dependencies :: Set Path
   }
 
-type Environment = HasEnvironment Module
+newtype Modules = Modules {
+    modules :: Map Path Module
+  }
+
+emptyEnvironment :: Modules
+emptyEnvironment = Modules {
+    modules = Map.empty
+  }
+
+type Environment = MonadState Modules
 type Log = MonadWriter [String]
-type Failable = MonadError String
+
+register :: Environment m => Path -> Module -> m ()
+register path module_ = modify $
+  \(Modules modules) -> Modules $ Map.insert path module_ modules
 
 build :: File -> Module
 build file = Module {file, dependencies}
   where
-    dependencies =
-      Set.toList . recurse pushDependency Set.empty $ imports file
+    dependencies = recurse pushDependency Set.empty $ imports file
     pushDependency set _ ref = Set.insert (modulePath ref) set
 
-parse :: (Contextual m, MonadIO m, Failable m) => Path -> m Module
-parse path = do
+parse :: (Contextual m, MonadIO m, Failable m) => Bool -> Path -> m Module
+parse isMain path = do
   searchPath <- asks codePaths
-  maybeSource <- find searchPath path
-  case maybeSource of
-    Nothing -> throwError $
-      printf "Module %s not found in paths : %s" (show path) (show searchPath)
-    Just source -> either throwError (return . build) =<<
-      parseOnly Module.File.parser . Text.pack <$> liftIO (readFile source)
+  filePath <- find (CodePath [], searchPath) path
+  source <- Text.pack <$> liftIO (readFile filePath)
+  either throwError (return . build) $
+    parseOnly (Module.File.parser isMain) source
 
-find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath)
-find (CodePath []) _ = return Nothing
-find (CodePath (dir:otherDirs)) path@(Path components) = do
+find :: (Failable m, MonadIO m) => (CodePath, CodePath) -> Path -> m FilePath
+find (stack, CodePath []) path = throwError $
+  printf "Module %s not found in paths : %s" (show path) (show $ stack)
+find (CodePath stackedDirs, CodePath (dir:otherDirs)) path@(Path components) = do
   fileExists <- liftIO $ doesFileExist filePath
   if fileExists
-  then return (Just filePath)
-  else find (CodePath otherDirs) path
+  then return filePath
+  else find (CodePath (dir:stackedDirs), CodePath otherDirs) path
   where
     filePath = foldl (</>) dir components <.> "js"

src/Module/Environment.hs

@@ -1,39 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Module.Environment (
-      Environment(..)
-    , HasEnvironment
-    , empty
-    , register
-    , reorder
-  ) where
-
-import Context (Path)
-import Control.Monad.State (MonadState, modify)
-import Data.Map (Map)
-import qualified Data.Map as Map (empty, insert)
-import Priority (Queue)
-import qualified Priority (empty)
-
-data Environment a = Environment {
-      modules :: Map Path a
-    , queue :: Queue Path
-  }
-
-type HasEnvironment a = MonadState (Environment a)
-
-register :: HasEnvironment a m => Path -> a -> m ()
-register path module_ = modify $ \moduleSpace -> moduleSpace {
-    modules = Map.insert path module_ (modules moduleSpace)
-  }
-
-reorder :: HasEnvironment a m => (Queue Path -> Queue Path) -> m ()
-reorder f = modify $ \moduleSpace -> moduleSpace {
-    queue = f (queue moduleSpace)
-  }
-
-empty :: Environment a
-empty = Environment {
-      modules = Map.empty
-    , queue = Priority.empty
-  }

src/Module/File.hs

@@ -23,12 +23,13 @@ import Prelude hiding (takeWhile)
 import Text.Printf (printf)
 
 data File = File {
-      imports :: Tree
+      isMain :: Bool
+    , imports :: Tree
     , payload :: [Text]
   } deriving Show
 
-parser :: Parser File
-parser = File
+parser :: Bool -> Parser File
+parser isMain = File isMain
   <$> Module.Imports.parser
   <*> (blank *> line `sepBy` eol)
   where

src/Priority.hs

@@ -1,50 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-module Priority (
-      Queue(..)
-    , empty
-    , set
-    , toList
-  ) where
-
-import Data.Map (Map)
-import qualified Data.Map as Map (
-    adjust, alter, delete, empty, insert, lookup, lookupMax
-  )
-
-data Queue a = Queue {
-      byElement :: Map a Int
-    , byRank :: Map Int [a]
-  }
-
-empty :: Queue a
-empty = Queue {byElement = Map.empty, byRank = Map.empty}
-
-set :: Ord a => a -> Int -> Queue a -> Queue a
-set x priority queue@(Queue {byElement, byRank}) =
-  case Map.lookup x byElement of
-    Nothing -> Queue {
-          byElement = Map.insert x priority byElement
-        , byRank = Map.alter (push x) priority byRank
-      }
-    Just formerPriority
-      | formerPriority >= priority -> queue
-      | otherwise -> queue {
-            byElement = Map.insert x priority byElement
-          , byRank = move x formerPriority priority byRank
-        }
-
-push :: a -> Maybe [a] -> Maybe [a]
-push a Nothing = Just [a]
-push a (Just as) = Just (a:as)
-
-move :: Eq a => a -> Int -> Int -> Map Int [a] -> Map Int [a]
-move a from to =
-  Map.alter (push a) to . Map.adjust (filter (/= a)) from
-
-toList :: Queue a -> [(Int, a)]
-toList = extract . byRank
-  where
-    extract tmpMap =
-      case Map.lookupMax tmpMap of
-        Nothing -> []
-        Just (k, elems) -> ((,) k <$> elems) ++ extract (Map.delete k tmpMap)