From 57e34a800244e7075ef6e8dd32eb07c451861595 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 17 May 2020 16:30:56 +0200 Subject: [PATCH] Separate the sjw executable from a Haskell library used to write it and that can be re-used by other Haskell programs to assemble JS code directly from a Haskell program --- CHANGELOG.md | 5 +++ SJW.cabal | 33 +++++++++------ src/Context.hs | 53 ------------------------ src/Main.hs | 40 +++++++----------- src/SJW.hs | 72 +++++++++++++++++++++++++++++++++ src/{ => SJW}/Compiler.hs | 18 ++++----- src/SJW/Config.hs | 10 +++++ src/{ => SJW}/Dependencies.hs | 4 +- src/{ => SJW}/Module.hs | 28 +++++-------- src/{ => SJW}/Module/File.hs | 10 ++--- src/{ => SJW}/Module/Imports.hs | 4 +- src/SJW/Source.hs | 40 ++++++++++++++++++ 12 files changed, 192 insertions(+), 125 deletions(-) delete mode 100644 src/Context.hs create mode 100644 src/SJW.hs rename src/{ => SJW}/Compiler.hs (78%) create mode 100644 src/SJW/Config.hs rename src/{ => SJW}/Dependencies.hs (97%) rename src/{ => SJW}/Module.hs (76%) rename src/{ => SJW}/Module/File.hs (91%) rename src/{ => SJW}/Module/Imports.hs (98%) create mode 100644 src/SJW/Source.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 7cd5db8..13f3814 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for SJW +## 0.1.2.0 -- 2020-01-10 + +* Expose SJW as a library and make sjw executable use it +* Check all sources directories for existence instead of delaying the fail to individual modules + ## 0.1.1.1 -- 2020-01-09 * Fix bug in dependency ordering due to using too naive an approach diff --git a/SJW.cabal b/SJW.cabal index 15a31b7..d20cdbe 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.1 +version: 0.1.2.0 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 @@ -17,25 +17,34 @@ category: Web build-type: Simple extra-source-files: CHANGELOG.md -executable sjw - main-is: Main.hs - other-modules: Compiler - , Context - , Dependencies - , Module - , Module.File - , Module.Imports - , Paths_SJW - -- other-extensions: +library + exposed-modules: SJW + other-modules: SJW.Compiler + , SJW.Dependencies + , SJW.Module + , SJW.Module.File + , SJW.Module.Imports + , SJW.Source build-depends: attoparsec , base >=4.11 && <4.13 , containers , directory , filepath , mtl - , optparse-applicative , text , unix hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +executable sjw + main-is: src/Main.hs + other-modules: Paths_SJW + -- other-extensions: + build-depends: attoparsec + , base >=4.11 && <4.13 + , optparse-applicative + , SJW + , text + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Context.hs b/src/Context.hs deleted file mode 100644 index c730f93..0000000 --- a/src/Context.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -module Context ( - CodePath(..) - , Context(..) - , Contextual - , Path(..) - , packages - ) where - -import Control.Monad.Reader (MonadReader) -import Data.List (intercalate) -import System.Directory (doesDirectoryExist) -import System.Environment (lookupEnv) -import System.FilePath (()) -import System.Posix.User (getRealUserID, getUserEntryForID, homeDirectory) -import Text.ParserCombinators.ReadP (char, munch, sepBy) -import Text.ParserCombinators.ReadPrec (lift) -import Text.Read (readPrec) - -newtype Path = Path [String] deriving (Eq, Ord) -newtype CodePath = CodePath [FilePath] - -data Context = Context { - codePaths :: CodePath - , mainModule :: Path - } - -type Contextual = MonadReader Context - -instance Show Path where - show (Path components) = intercalate "." components - -instance Read Path where - readPrec = fmap Path . lift $ - munch (/= '.') `sepBy` char '.' - -instance Show CodePath where - show (CodePath dirs) = intercalate ":" dirs - -dbDirectory :: IO FilePath -dbDirectory = do - unixHome <- homeDirectory <$> (getUserEntryForID =<< getRealUserID) - home <- maybe unixHome id <$> lookupEnv "HOME" - maybe (home ".sjw") id <$> lookupEnv "SJW_PACKAGE_DB" - -packages :: [String] -> IO [FilePath] -packages names = do - db <- dbDirectory - mapM (pathOrPackageName db) names - where - pathOrPackageName db name = do - directoryExists <- doesDirectoryExist name - return $ if directoryExists then name else db name diff --git a/src/Main.hs b/src/Main.hs index 309f215..48a2dc9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,25 +1,19 @@ {-# LANGUAGE NamedFieldPuns #-} module Main where -import qualified Compiler (main) -import Context (CodePath(..), Context (..), packages) -import Control.Applicative (many) -import Control.Monad.Except (runExceptT) -import Control.Monad.RWS (evalRWST) -import Data.Text (Text) +import Control.Applicative (many, optional) import qualified Data.Text as Text (unpack) import Data.Version (showVersion) -import Module (emptyEnvironment) import Options.Applicative ( Parser, execParser, fullDesc, info, header, help, helper, long, metavar , short, strArgument, strOption, value ) -import qualified Paths_SJW as SJW (version) -import System.IO (stderr, hPutStrLn) +import Paths_SJW (version) +import SJW (Source, compile, mainIs, source, sourceCode) data Config = Config { includes :: [String] - , mainIs :: String + , mainModuleName :: Maybe String , outputFile :: FilePath , target :: FilePath } deriving (Show) @@ -32,13 +26,12 @@ configParser = Config <> metavar "PACKAGE" <> help "Include this package during compilation" )) - <*> strOption ( + <*> optional (strOption ( long "main-is" <> short 'm' <> metavar "MODULE_NAME" <> help "The name of the main module containing the code to run" - <> value "Main" - ) + )) <*> strOption ( long "output" <> short 'o' @@ -55,24 +48,21 @@ getConfig :: IO Config getConfig = execParser $ info (helper <*> configParser) - (fullDesc <> header ("SJW v" ++ showVersion SJW.version)) + (fullDesc <> header ("SJW v" ++ showVersion version)) -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 emptyEnvironment +getSource :: Config -> Source +getSource (Config {includes, mainModuleName = Nothing, target}) = + source (target:includes) +getSource (Config {includes, mainModuleName = Just moduleName, target}) = + source (target:includes) `mainIs` moduleName main :: IO () main = do config@(Config {outputFile}) <- getConfig - result <- runCompiler config + result <- SJW.sourceCode =<< SJW.compile (getSource config) case result of - Left errorMessage -> printErr errorMessage - Right (sourceCode, logs) -> do - mapM_ printErr logs - output outputFile . Text.unpack $ sourceCode + Nothing -> return () + Just code -> output outputFile $ Text.unpack code where - printErr = hPutStrLn stderr output "-" = putStr output fileName = writeFile fileName diff --git a/src/SJW.hs b/src/SJW.hs new file mode 100644 index 0000000..ce6dd92 --- /dev/null +++ b/src/SJW.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +module SJW ( + Source + , Path(..) + , compile + , mainIs + , source + , sourceCode + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Except (MonadError(..), runExceptT) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.RWS (evalRWST) +import qualified Data.Map as Map (empty) +import Data.Text (Text) +import qualified SJW.Compiler as Compiler (main) +import SJW.Dependencies (Failable) +import SJW.Module (Modules(..)) +import SJW.Source (CodePath(..), Source(..), Path(..), source) +import System.Directory (doesDirectoryExist) +import System.Environment (lookupEnv) +import System.FilePath (()) +import System.IO (stderr, hPutStrLn) +import System.Posix.User (getRealUserID, getUserEntryForID, homeDirectory) +import Text.Printf (printf) + +type Result = Either String (Text, [String]) + +compile :: Source -> IO Result +compile inputSource = runExceptT $ do + checkedPackages <- check packages + let checkedSource = inputSource {code = CodePath checkedPackages} + evalRWST Compiler.main checkedSource emptyEnvironment + where + CodePath packages = code inputSource + emptyEnvironment = Modules { + modules = Map.empty + } + +sourceCode :: Result -> IO (Maybe Text) +sourceCode (Left errorMessage) = hPutStrLn stderr errorMessage >> return Nothing +sourceCode (Right (output, logs)) = + mapM_ (hPutStrLn stderr) logs >> return (Just output) + +mainIs :: Source -> String -> Source +mainIs context dotSeparated = context {mainModule = read dotSeparated} + +(<||>) :: (Monad m) => m (Maybe a) -> a -> m a +(<||>) value defaultValue = maybe defaultValue id <$> value + +dbDirectory :: MonadIO m => m FilePath +dbDirectory = liftIO $ do + unixHome <- homeDirectory <$> (getUserEntryForID =<< getRealUserID) + homeDB <- lookupEnv "HOME" <||> unixHome + lookupEnv "SJW_PACKAGE_DB" <||> (homeDB ".sjw") + +checkPath :: MonadIO m => FilePath -> m (Maybe FilePath) +checkPath filePath = liftIO $ do + directoryExists <- doesDirectoryExist filePath + return $ if directoryExists then Just filePath else Nothing + +check :: (MonadIO m, Failable m) => [String] -> m [FilePath] +check names = do + db <- dbDirectory + mapM (pathOrPackageName db) names + where + notFound = throwError . printf "%s: package and directory not found" + pathOrPackageName db name = + (<|>) <$> checkPath name <*> checkPath (db name) + >>= maybe (notFound name) return diff --git a/src/Compiler.hs b/src/SJW/Compiler.hs similarity index 78% rename from src/Compiler.hs rename to src/SJW/Compiler.hs index db792c9..0e452af 100644 --- a/src/Compiler.hs +++ b/src/SJW/Compiler.hs @@ -2,24 +2,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -module Compiler ( +module SJW.Compiler ( main ) where -import Context (Context(..), Contextual, Path) +import SJW.Source (Source(..), HasSource, Path) import Control.Monad.IO.Class (MonadIO(..)) 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 Dependencies (Failable, solve) -import Module (Environment, Log, Module(..), Modules(..), register) -import qualified Module (parse) -import Module.File (File(..), variables) -import qualified Module.File as File (header, footer) +import SJW.Dependencies as Dependencies (Failable, solve) +import SJW.Module (Environment, Log, Module(..), Modules(..)) +import qualified SJW.Module as Module (parse, register) +import SJW.Module.File (File(..), variables) +import qualified SJW.Module.File as File (header, footer) -type Compiler m = (Contextual m, Log m, Environment m, MonadIO m, Failable m) +type Compiler m = (HasSource m, Log m, Environment m, MonadIO m, Failable m) indent :: [Text] -> [Text] indent = fmap indentLine @@ -55,7 +55,7 @@ body = do main :: Compiler m => m Text main = do - Context {mainModule} <- ask + Source {mainModule} <- ask scan True mainModule codeBody <- body return . Text.unlines $ openOnLoad : indent codeBody ++ [closeOnLoad] diff --git a/src/SJW/Config.hs b/src/SJW/Config.hs new file mode 100644 index 0000000..0effa60 --- /dev/null +++ b/src/SJW/Config.hs @@ -0,0 +1,10 @@ +module SJW.Config ( + Config(..) + ) where + +data Config = Config { + includes :: [String] + , mainIs :: String + , outputFile :: FilePath + , target :: FilePath + } deriving (Show) diff --git a/src/Dependencies.hs b/src/SJW/Dependencies.hs similarity index 97% rename from src/Dependencies.hs rename to src/SJW/Dependencies.hs index f513ca6..ba0ae62 100644 --- a/src/Dependencies.hs +++ b/src/SJW/Dependencies.hs @@ -1,12 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -module Dependencies ( +module SJW.Dependencies ( Dependencies , Failable , solve ) where -import Context (Path) +import SJW.Source (Path) import Control.Monad.Except (MonadError(..), runExcept) import Control.Monad.RWS (MonadState, MonadWriter, evalRWST, gets, modify, tell) import Data.List (intercalate) diff --git a/src/Module.hs b/src/SJW/Module.hs similarity index 76% rename from src/Module.hs rename to src/SJW/Module.hs index 8c01263..b3ace6b 100644 --- a/src/Module.hs +++ b/src/SJW/Module.hs @@ -1,37 +1,36 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -module Module ( +module SJW.Module ( Environment , Log , Module(..) , Modules(..) - , emptyEnvironment , parse , register ) where -import Context (CodePath(..), Context(..), Contextual, Path(..)) +import SJW.Source (CodePath(..), Source(..), HasSource, Path(..)) import Control.Monad.Except (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.RWS (MonadState, MonadWriter, asks, modify) import Data.Attoparsec.Text (parseOnly) import Data.Map (Map) -import qualified Data.Map as Map (empty, insert) +import qualified Data.Map as Map (insert) import Data.Set (Set) import qualified Data.Set as Set (empty, insert) import qualified Data.Text as Text (pack) -import Dependencies (Failable) -import Module.File (File(..)) -import qualified Module.File (parser) -import Module.Imports (Reference(..), recurse) +import SJW.Dependencies (Failable) +import SJW.Module.File (File(..)) +import qualified SJW.Module.File as File (parser) +import SJW.Module.Imports (Reference(..), recurse) import Prelude hiding (takeWhile) import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) import Text.Printf (printf) data Module = Module { - file :: Module.File.File + file :: File , dependencies :: Set Path } @@ -39,11 +38,6 @@ newtype Modules = Modules { modules :: Map Path Module } -emptyEnvironment :: Modules -emptyEnvironment = Modules { - modules = Map.empty - } - type Environment = MonadState Modules type Log = MonadWriter [String] @@ -57,13 +51,13 @@ build file = Module {file, dependencies} dependencies = recurse pushDependency Set.empty $ imports file pushDependency set _ ref = Set.insert (modulePath ref) set -parse :: (Contextual m, MonadIO m, Failable m) => Bool -> Path -> m Module +parse :: (HasSource m, MonadIO m, Failable m) => Bool -> Path -> m Module parse isMain path = do - searchPath <- asks codePaths + searchPath <- asks code filePath <- find (CodePath [], searchPath) path source <- Text.pack <$> liftIO (readFile filePath) either throwError (return . build) $ - parseOnly (Module.File.parser isMain) source + parseOnly (File.parser isMain) source find :: (Failable m, MonadIO m) => (CodePath, CodePath) -> Path -> m FilePath find (stack, CodePath []) path = throwError $ diff --git a/src/Module/File.hs b/src/SJW/Module/File.hs similarity index 91% rename from src/Module/File.hs rename to src/SJW/Module/File.hs index 24c047b..e90d2bc 100644 --- a/src/Module/File.hs +++ b/src/SJW/Module/File.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module Module.File ( +module SJW.Module.File ( File(..) , header , footer @@ -8,7 +8,7 @@ module Module.File ( , variables ) where -import Context (Path) +import SJW.Source (Path) import Control.Applicative ((<|>)) import Data.Attoparsec.Text ( Parser, inClass, isEndOfLine, sepBy, string, takeTill, takeWhile @@ -17,8 +17,8 @@ import Data.List (intercalate) import qualified Data.Map as Map (toList) import Data.Text (Text) import qualified Data.Text as Text (pack) -import Module.Imports (Reference(..), Tree(..)) -import qualified Module.Imports (parser) +import SJW.Module.Imports (Reference(..), Tree(..)) +import qualified SJW.Module.Imports as Imports (parser) import Prelude hiding (takeWhile) import Text.Printf (printf) @@ -30,7 +30,7 @@ data File = File { parser :: Bool -> Parser File parser isMain = File isMain - <$> Module.Imports.parser + <$> Imports.parser <*> (blank *> line `sepBy` eol) where eol = string "\r\n" <|> string "\r" <|> string "\n" diff --git a/src/Module/Imports.hs b/src/SJW/Module/Imports.hs similarity index 98% rename from src/Module/Imports.hs rename to src/SJW/Module/Imports.hs index c548609..63a28c6 100644 --- a/src/Module/Imports.hs +++ b/src/SJW/Module/Imports.hs @@ -1,13 +1,13 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module Module.Imports ( +module SJW.Module.Imports ( Reference(..) , Tree(..) , parser , recurse ) where -import Context (Path(..)) +import SJW.Source (Path(..)) import Control.Applicative ((<|>), many, optional) import Data.Attoparsec.Text ( Parser, char, count, digit, inClass, letter, sepBy, string, takeWhile diff --git a/src/SJW/Source.hs b/src/SJW/Source.hs new file mode 100644 index 0000000..79954a4 --- /dev/null +++ b/src/SJW/Source.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ConstraintKinds #-} +module SJW.Source ( + CodePath(..) + , Source(..) + , HasSource + , Path(..) + , source + ) where + +import Control.Monad.Reader (MonadReader) +import Data.List (intercalate) +import Text.ParserCombinators.ReadP (char, munch, sepBy) +import Text.ParserCombinators.ReadPrec (lift) +import Text.Read (readPrec) + +newtype Path = Path [String] deriving (Eq, Ord) +newtype CodePath = CodePath [FilePath] + +data Source = Source { + code :: CodePath + , mainModule :: Path + } + +type HasSource = MonadReader Source + +instance Show Path where + show (Path components) = intercalate "." components + +instance Read Path where + readPrec = fmap Path . lift $ + munch (/= '.') `sepBy` char '.' + +instance Show CodePath where + show (CodePath dirs) = intercalate ":" dirs + +source :: [String] -> Source +source paths = Source { + code = CodePath paths + , mainModule = Path ["Main"] + }