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

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

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
+library
-  main-is:             Main.hs
+  exposed-modules:     SJW
-  other-modules:       Compiler
+  other-modules:       SJW.Compiler
-                     , Context
+                     , SJW.Dependencies
-                     , Dependencies
+                     , SJW.Module
-                     , Module
+                     , SJW.Module.File
-                     , Module.File
+                     , SJW.Module.Imports
-                     , Module.Imports
+                     , SJW.Source
-                     , Paths_SJW
-  -- other-extensions:
   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

src/Context.hs

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

src/Main.hs

@@ -1,25 +1,19 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main where
 
-import qualified Compiler (main)
+import Control.Applicative (many, optional)
-import Context (CodePath(..), Context (..), packages)
-import Control.Applicative (many)
-import Control.Monad.Except (runExceptT)
-import Control.Monad.RWS (evalRWST)
-import Data.Text (Text)
 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 Paths_SJW (version)
-import System.IO (stderr, hPutStrLn)
+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]))
+getSource :: Config -> Source
-runCompiler (Config {includes, mainIs, target}) = do
+getSource (Config {includes, mainModuleName = Nothing, target}) =
-  codePaths <- CodePath . (target:) <$> packages includes
+  source (target:includes)
-  let initialContext = Context {codePaths, mainModule = read mainIs}
+getSource (Config {includes, mainModuleName = Just moduleName, target}) =
-  runExceptT $ evalRWST Compiler.main initialContext emptyEnvironment
+  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
+    Nothing -> return ()
-    Right (sourceCode, logs) -> do
+    Just code -> output outputFile $ Text.unpack code
-      mapM_ printErr logs
-      output outputFile . Text.unpack $ sourceCode
   where
-    printErr = hPutStrLn stderr
     output "-" = putStr
     output fileName = writeFile fileName

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

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 SJW.Dependencies as Dependencies (Failable, solve)
-import Module (Environment, Log, Module(..), Modules(..), register)
+import SJW.Module (Environment, Log, Module(..), Modules(..))
-import qualified Module (parse)
+import qualified SJW.Module as Module (parse, register)
-import Module.File (File(..), variables)
+import SJW.Module.File (File(..), variables)
-import qualified Module.File as File (header, footer)
+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]

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)

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)

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 SJW.Dependencies (Failable)
-import Module.File (File(..))
+import SJW.Module.File (File(..))
-import qualified Module.File (parser)
+import qualified SJW.Module.File as File (parser)
-import Module.Imports (Reference(..), recurse)
+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 $

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 SJW.Module.Imports (Reference(..), Tree(..))
-import qualified Module.Imports (parser)
+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"

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

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"]
+  }