Tissevert/SJW
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

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

Browse source
This commit is contained in:
Tissevert 2020-01-09 21:51:24 +01:00
parent bcdcec1cf2
commit f0adee46f3
9 changed files with 139 additions and 139 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
CHANGELOG.md
View file

@ -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

5
SJW.cabal
View file

@ -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

37
src/Compiler.hs
View file

@ -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

72
src/Dependencies.hs Normal file
View file

@ -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

4
src/Main.hs
View file

@ -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

59
src/Module.hs
View file

@ -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"

39
src/Module/Environment.hs
View file

@ -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
}

7
src/Module/File.hs
View file

@ -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

50
src/Priority.hs
View file

@ -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)