diff --git a/CHANGELOG.md b/CHANGELOG.md index 385637c..7cd5db8 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/SJW.cabal b/SJW.cabal index 36a31e9..15a31b7 100644 --- a/SJW.cabal +++ b/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 diff --git a/src/Compiler.hs b/src/Compiler.hs index 759a2e6..db792c9 100644 --- a/src/Compiler.hs +++ b/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 diff --git a/src/Dependencies.hs b/src/Dependencies.hs new file mode 100644 index 0000000..f513ca6 --- /dev/null +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 65f98fa..309f215 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Module.hs b/src/Module.hs index 1f5eabe..8c01263 100644 --- a/src/Module.hs +++ b/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" diff --git a/src/Module/Environment.hs b/src/Module/Environment.hs deleted file mode 100644 index 2fb4754..0000000 --- a/src/Module/Environment.hs +++ /dev/null @@ -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 - } diff --git a/src/Module/File.hs b/src/Module/File.hs index a35d3ba..24c047b 100644 --- a/src/Module/File.hs +++ b/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 diff --git a/src/Priority.hs b/src/Priority.hs deleted file mode 100644 index 53d225c..0000000 --- a/src/Priority.hs +++ /dev/null @@ -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)