diff --git a/SJW.cabal b/SJW.cabal index 0381324..9ada014 100644 --- a/SJW.cabal +++ b/SJW.cabal @@ -22,6 +22,9 @@ executable sjw other-modules: Compiler , Context , Module + , Module.Environment + , Module.File + , Module.Imports , Paths_SJW , Priority -- other-extensions: diff --git a/src/Compiler.hs b/src/Compiler.hs index fca0608..759a2e6 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,21 +1,28 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} module Compiler ( main ) where -import Context (Context(..), Path) +import Context (Context(..), Contextual, Path) +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.RWS (asks, gets) -import Data.List (intercalate) import Data.Map ((!)) -import qualified Data.Map as Map (member, toList) +import qualified Data.Map as Map (member) import Data.Text (Text, cons) -import qualified Data.Text as Text (null, pack, unlines) -import Module (Compiler, Entry(..), ImportTree(..), Module(..), Modules, Reference(..)) -import qualified Module (ModuleSpace(..), buildEntry, parse, register, reorder) +import qualified Data.Text as Text (null, unlines) +import Module (Environment, Failable, Log, Module(..), Log) +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) -import Text.Printf (printf) + +type Compiler m = (Contextual m, Log m, Environment m, MonadIO m, Failable m) indent :: [Text] -> [Text] indent = fmap indentLine @@ -24,58 +31,29 @@ indent = fmap indentLine | Text.null t = t | otherwise = cons '\t' t -variables :: ImportTree -> [(String, String)] -variables = fmap (fmap computeValue) . Map.toList . children - where - computeValue :: ImportTree -> String - computeValue subTree = - let subModules = intercalate ", " $ f <$> Map.toList (children subTree) in - case target subTree of - Nothing -> printf "Object.create(null, {%s})" subModules - Just (ModulePath {modulePath}) -> - printf "Object.create(modules['%s'], {%s})" - (show modulePath) - subModules - Just (Object {modulePath, field}) -> - printf "modules['%s'].%s" (show modulePath) field - f (name, subTree) = printf "%s: {value: %s}" name $ computeValue subTree - -moduleHeader :: Bool -> Path -> [String] -> Text -moduleHeader isMain path names = Text.pack (outside isMain ++ arguments) - where - outside True = "" - outside False = printf "modules['%s'] = " (show path) - arguments = printf "(function(%s) {" (intercalate ", " $ names ++ ["modules"]) - -moduleFooter :: [String] -> [Text] -moduleFooter values = [Text.pack $ printf "})(%s);" (intercalate ", " values)] - -include :: Modules m => (Int, Path) -> m [Text] +include :: Environment m => (Int, Path) -> m [Text] include (priority, path) = do - Module {imports, payload} <- getModule path + File {imports, payload} <- gets (file . (! path) . Environment.modules) let (names, values) = unzip $ variables imports - return $ moduleHeader isMain path names : indent payload ++ moduleFooter values + return $ File.header isMain path names : indent payload ++ File.footer values where isMain = priority == 0 -getModule :: Modules m => Path -> m Module -getModule path = gets (content . (! path) . Module.entries) - scan :: Compiler m => Int -> Path -> m () scan priority modulePath = do - Module.reorder $ Priority.set modulePath priority - alreadyLoaded <- gets (Map.member modulePath . Module.entries) + Environment.reorder $ Priority.set modulePath priority + alreadyLoaded <- gets (Map.member modulePath . Environment.modules) if alreadyLoaded then return () else load where load :: Compiler m => m () load = do - newEntry <- Module.buildEntry <$> Module.parse modulePath - Module.register modulePath newEntry - mapM_ (scan (priority + 1)) $ dependencies newEntry + newModule <- Module.parse modulePath + Environment.register modulePath newModule + mapM_ (scan (priority + 1)) $ dependencies newModule body :: Compiler m => m [Text] body = do - sortedPath <- gets (Priority.toList . Module.queue) + sortedPath <- gets (Priority.toList . Environment.queue) includes <- concat <$> mapM include sortedPath return $ "var modules = {};" : includes diff --git a/src/Context.hs b/src/Context.hs index f050c11..c730f93 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,10 +1,13 @@ +{-# 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) @@ -22,6 +25,8 @@ data Context = Context { , mainModule :: Path } +type Contextual = MonadReader Context + instance Show Path where show (Path components) = intercalate "." components diff --git a/src/Main.hs b/src/Main.hs index 941a814..65f98fa 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 (emptySpace) +import qualified Module.Environment as Environment (empty) 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 Module.emptySpace + runExceptT $ evalRWST Compiler.main initialContext Environment.empty main :: IO () main = do diff --git a/src/Module.hs b/src/Module.hs index de431a4..1f5eabe 100644 --- a/src/Module.hs +++ b/src/Module.hs @@ -1,176 +1,44 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} module Module ( - Compiler - , Contextual - , Entry(..) + Environment , Failable - , ImportTree(..) , Log , Module(..) - , Modules - , ModuleSpace(..) - , Reference(..) - , buildEntry - , emptySpace , parse - , register - , reorder ) where -import Context (CodePath(..), Context(..), Path(..)) -import Control.Applicative ((<|>), many, optional) +import Context (CodePath(..), Context(..), Contextual, Path(..)) import Control.Monad.Except (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.RWS (MonadReader, MonadState, MonadWriter, asks, modify) -import Data.Attoparsec.Text ( - Parser, char, count, digit, inClass, isEndOfLine, letter, parseOnly, sepBy - , string, takeTill, takeWhile - ) -import Data.Map (Map, foldlWithKey) -import qualified Data.Map as Map (empty, insert, lookup) +import Control.Monad.RWS (MonadWriter, asks) +import Data.Attoparsec.Text (parseOnly) import qualified Data.Set as Set (empty, insert, toList) -import Data.Text (Text) import qualified Data.Text as Text (pack) +import Module.Environment (HasEnvironment) +import Module.File (File(..)) +import qualified Module.File (parser) +import Module.Imports (Reference(..), recurse) import Prelude hiding (takeWhile) -import Priority (Queue, empty) import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) import Text.Printf (printf) -data Reference = - ModulePath {modulePath :: Path} - | Object {modulePath :: Path, field :: String} - deriving Show - -data ImportTree = ImportTree { - target :: Maybe Reference - , children :: Map String ImportTree - } deriving Show - -recurse :: (a -> [String] -> Reference -> a) -> a -> ImportTree -> a -recurse f initValue = recAux [] initValue - where - next _ value Nothing = value - next stack value (Just ref) = f value (reverse stack) ref - recAux stack value tree = - let nextValue = next stack value (target tree) in - foldlWithKey (\a k b -> recAux (k:stack) a b) nextValue (children tree) - -data Mapping = Mapping { - exposedName :: Path - , reference :: Reference - } - data Module = Module { - imports :: ImportTree - , payload :: [Text] - } deriving Show - -data Entry = Entry { - content :: Module + file :: Module.File.File , dependencies :: [Path] } -data ModuleSpace = ModuleSpace { - entries :: Map Path Entry - , queue :: Queue Path - } - -register :: Modules m => Path -> Entry -> m () -register path entry = modify $ \moduleSpace -> moduleSpace { - entries = Map.insert path entry (entries moduleSpace) - } - -reorder :: Modules m => (Queue Path -> Queue Path) -> m () -reorder f = modify $ \moduleSpace -> moduleSpace { - queue = f (queue moduleSpace) - } - -emptySpace :: ModuleSpace -emptySpace = ModuleSpace { - entries = Map.empty - , queue = Priority.empty - } - -type Contextual = MonadReader Context +type Environment = HasEnvironment Module type Log = MonadWriter [String] -type Modules = MonadState ModuleSpace type Failable = MonadError String -type Compiler m = (Contextual m, Log m, Modules m, MonadIO m, Failable m) -space :: Parser () -space = takeWhile (inClass " \t") *> pure () - -between :: Parser a -> (Parser b, Parser c) -> Parser a -between p (left, right) = left *> space *> p <* space <* right - -keyword :: String -> Parser () -keyword k = space <* string (Text.pack k) <* space - -name :: Parser String -name = (:) <$> letter <*> many (letter <|> digit) - -aliasedName :: Parser (Maybe String, String) -aliasedName = - ((,) <$> (Just <$> name) <* keyword "as" <*> name) - <|> ((\s -> (Just s, s)) <$> name) - -buildMappings :: Maybe [(Maybe String, String)] -> Path -> [Mapping] -buildMappings Nothing modulePath = - [Mapping modulePath (ModulePath modulePath)] -buildMappings (Just nameAssocs) modulePath = mappingOf <$> nameAssocs - where - mappingOf (Nothing, dest) = Mapping (Path [dest]) (ModulePath modulePath) - mappingOf (Just source, dest) = - Mapping (Path [dest]) (Object modulePath source) - -mappingParser :: Parser [Mapping] -mappingParser = - buildMappings <$> optional fromClause <*> (Path <$> name `sepBy` char '.') - where - fromClause = - (count 1 (aliasedName <|> star) <|> namesBlock) <* keyword "from" - namesBlock = - (aliasedName `sepBy` (char ',' *> space)) `between` (char '{', char '}') - star = (,) <$> (char '*' *> pure Nothing) <* keyword "as" <*> name - -importParser :: Parser [Mapping] -importParser = mappingParser `between` (string "import", char ';') - -emptyTree :: ImportTree -emptyTree = ImportTree { - target = Nothing - , children = Map.empty - } - -insertMapping :: ImportTree -> Mapping -> ImportTree -insertMapping tmpTree (Mapping {exposedName, reference}) = - insertAt components tmpTree - where - Path components = exposedName - insertAt [] tree = tree {target = Just reference} - insertAt (next:restOfPath) tree@(ImportTree {children}) = - let subTree = maybe emptyTree id $ Map.lookup next children in tree { - children = Map.insert next (insertAt restOfPath subTree) children - } - -moduleParser :: Parser Module -moduleParser = Module - <$> (foldl (foldl insertMapping) emptyTree <$> importParser `sepBy` blank) - <*> (blank *> line `sepBy` eol) - where - eol = string "\r\n" <|> string "\r" <|> string "\n" - blank = takeWhile (inClass " \t\r\n") - line = takeTill isEndOfLine - -buildEntry :: Module -> Entry -buildEntry content = Entry {content, dependencies} +build :: File -> Module +build file = Module {file, dependencies} where dependencies = - Set.toList . recurse pushDependency Set.empty $ imports content + Set.toList . recurse pushDependency Set.empty $ imports file pushDependency set _ ref = Set.insert (modulePath ref) set parse :: (Contextual m, MonadIO m, Failable m) => Path -> m Module @@ -180,8 +48,8 @@ parse path = do case maybeSource of Nothing -> throwError $ printf "Module %s not found in paths : %s" (show path) (show searchPath) - Just source -> either throwError return =<< - parseOnly moduleParser . Text.pack <$> liftIO (readFile source) + Just source -> either throwError (return . build) =<< + parseOnly Module.File.parser . Text.pack <$> liftIO (readFile source) find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath) find (CodePath []) _ = return Nothing diff --git a/src/Module/Environment.hs b/src/Module/Environment.hs new file mode 100644 index 0000000..2fb4754 --- /dev/null +++ b/src/Module/Environment.hs @@ -0,0 +1,39 @@ +{-# 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 new file mode 100644 index 0000000..a35d3ba --- /dev/null +++ b/src/Module/File.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Module.File ( + File(..) + , header + , footer + , parser + , variables + ) where + +import Context (Path) +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text ( + Parser, inClass, isEndOfLine, sepBy, string, takeTill, takeWhile + ) +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 Prelude hiding (takeWhile) +import Text.Printf (printf) + +data File = File { + imports :: Tree + , payload :: [Text] + } deriving Show + +parser :: Parser File +parser = File + <$> Module.Imports.parser + <*> (blank *> line `sepBy` eol) + where + eol = string "\r\n" <|> string "\r" <|> string "\n" + blank = takeWhile (inClass " \t\r\n") + line = takeTill isEndOfLine + +header :: Bool -> Path -> [String] -> Text +header isMain path names = Text.pack (outside isMain ++ arguments) + where + outside True = "" + outside False = printf "modules['%s'] = " (show path) + arguments = printf "(function(%s) {" (intercalate ", " $ names ++ ["modules"]) + +footer :: [String] -> [Text] +footer values = [Text.pack $ printf "})(%s);" (intercalate ", " values)] + +variables :: Tree -> [(String, String)] +variables = fmap (fmap computeValue) . Map.toList . children + where + computeValue :: Tree -> String + computeValue subTree = + let subModules = intercalate ", " $ f <$> Map.toList (children subTree) in + case target subTree of + Nothing -> printf "Object.create(null, {%s})" subModules + Just (ModulePath {modulePath}) -> + printf "Object.create(modules['%s'], {%s})" + (show modulePath) + subModules + Just (Object {modulePath, field}) -> + printf "modules['%s'].%s" (show modulePath) field + f (name, subTree) = printf "%s: {value: %s}" name $ computeValue subTree diff --git a/src/Module/Imports.hs b/src/Module/Imports.hs new file mode 100644 index 0000000..3df4625 --- /dev/null +++ b/src/Module/Imports.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Module.Imports ( + Reference(..) + , Tree(..) + , parser + , recurse + ) where + +import Context (Path(..)) +import Control.Applicative ((<|>), many, optional) +import Data.Attoparsec.Text ( + Parser, char, count, digit, inClass, letter, sepBy, string, takeWhile + ) +import Data.Map (Map, foldlWithKey) +import qualified Data.Map as Map (empty, insert, lookup) +import qualified Data.Text as Text (pack) +import Prelude hiding (takeWhile) + +data Reference = + ModulePath {modulePath :: Path} + | Object {modulePath :: Path, field :: String} + deriving Show + +data Tree = Tree { + target :: Maybe Reference + , children :: Map String Tree + } deriving Show + +data Mapping = Mapping { + exposedName :: Path + , reference :: Reference + } + +recurse :: (a -> [String] -> Reference -> a) -> a -> Tree -> a +recurse f initValue = recAux [] initValue + where + next _ value Nothing = value + next stack value (Just ref) = f value (reverse stack) ref + recAux stack value tree = + let nextValue = next stack value (target tree) in + foldlWithKey (\a k b -> recAux (k:stack) a b) nextValue (children tree) + +space :: Parser () +space = takeWhile (inClass " \t") *> pure () + +between :: Parser a -> (Parser b, Parser c) -> Parser a +between p (left, right) = left *> space *> p <* space <* right + +keyword :: String -> Parser () +keyword k = space <* string (Text.pack k) <* space + +name :: Parser String +name = (:) <$> letter <*> many (letter <|> digit) + +aliasedName :: Parser (Maybe String, String) +aliasedName = + ((,) <$> (Just <$> name) <* keyword "as" <*> name) + <|> ((\s -> (Just s, s)) <$> name) + +buildMappings :: Maybe [(Maybe String, String)] -> Path -> [Mapping] +buildMappings Nothing modulePath = + [Mapping modulePath (ModulePath modulePath)] +buildMappings (Just nameAssocs) modulePath = mappingOf <$> nameAssocs + where + mappingOf (Nothing, dest) = Mapping (Path [dest]) (ModulePath modulePath) + mappingOf (Just source, dest) = + Mapping (Path [dest]) (Object modulePath source) + +mappingParser :: Parser [Mapping] +mappingParser = + buildMappings <$> optional fromClause <*> (Path <$> name `sepBy` char '.') + where + fromClause = + (count 1 (aliasedName <|> star) <|> namesBlock) <* keyword "from" + namesBlock = + (aliasedName `sepBy` (char ',' *> space)) `between` (char '{', char '}') + star = (,) <$> (char '*' *> pure Nothing) <* keyword "as" <*> name + +emptyTree :: Tree +emptyTree = Tree { + target = Nothing + , children = Map.empty + } + +insertMapping :: Tree -> Mapping -> Tree +insertMapping tmpTree (Mapping {exposedName, reference}) = + insertAt components tmpTree + where + Path components = exposedName + insertAt [] tree = tree {target = Just reference} + insertAt (next:restOfPath) tree@(Tree {children}) = + let subTree = maybe emptyTree id $ Map.lookup next children in tree { + children = Map.insert next (insertAt restOfPath subTree) children + } + +parser :: Parser Tree +parser = foldl (foldl insertMapping) emptyTree <$> importParser `sepBy` blank + where + blank = takeWhile (inClass " \t\r\n") + importParser = mappingParser `between` (string "import", char ';')