Implement the imports, dependencies solving and generation of the code

This commit is contained in:
Tissevert 2020-01-01 17:27:39 +01:00
parent 6b254dcdeb
commit f3c43c79e7
3 changed files with 240 additions and 57 deletions

View file

@ -1,33 +1,89 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Compiler ( module Compiler (
main main
) where ) where
import Context (Contextual) import Context (Context(..), Path)
import Control.Monad.RWS (asks, gets)
import Data.List (intercalate)
import Data.Map ((!))
import qualified Data.Map as Map (member, toList)
import Data.Text (Text, cons) import Data.Text (Text, cons)
import qualified Data.Text as Text (concat) import qualified Data.Text as Text (null, pack, unlines)
import Module (Module(..)) import Module (Compiler, Entry(..), ImportTree(..), Module(..), Modules, Reference(..))
import qualified Module (ModuleSpace(..), buildEntry, parse, register, reorder)
import qualified Priority (set, toList)
import Text.Printf (printf)
indent :: [Text] -> [Text] indent :: [Text] -> [Text]
indent = fmap (cons '\t') indent = fmap indentLine
include :: Bool -> Module -> Text
include isMain (Module {imports, payload}) = Text.concat $
header isMain
: indent payload
++ footer isMain
where where
header True = "(function() {\n" indentLine t
header False = "modules[''] = (function() {\n" | Text.null t = t
footer True = ["})());"] | otherwise = cons '\t' t
footer False = [
"})());"
, "Object.freeze(modules['']);"
]
scan :: Contextual () variables :: ImportTree -> [(String, String)]
scan = undefined 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
main :: Contextual Text moduleHeader :: Bool -> Path -> [String] -> Text
main = undefined 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 (priority, path) = do
Module {imports, payload} <- getModule path
let (names, values) = unzip $ variables imports
return $ moduleHeader isMain path names : indent payload ++ moduleFooter 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)
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
body :: Compiler m => m [Text]
body = do
sortedPath <- gets (Priority.toList . Module.queue)
includes <- concat <$> mapM include sortedPath
return $ "var modules = {};" : includes
main :: Compiler m => m Text
main = do
scan 0 =<< asks mainModule
codeBody <- body
return . Text.unlines $ openOnLoad : indent codeBody ++ [closeOnLoad]
where
openOnLoad = "window.addEventListener('load', function() {"
closeOnLoad = "});"

View file

@ -2,17 +2,17 @@
module Main where module Main where
import qualified Compiler (main) import qualified Compiler (main)
import Context (CodePath(..), Context (..), Path(..), packages) import Context (CodePath(..), Context (..), packages)
import Control.Applicative (many, optional) import Control.Applicative (many)
import Control.Monad.Except (runExceptT)
import Control.Monad.RWS (evalRWST) import Control.Monad.RWS (evalRWST)
import qualified Data.Map as Map (empty)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text (unpack) import qualified Data.Text as Text (unpack)
import Data.Version (showVersion) import Data.Version (showVersion)
import qualified Module (parse) import qualified Module (emptySpace)
import Options.Applicative ( import Options.Applicative (
Parser, execParser, fullDesc, info, header, help, helper, long, metavar Parser, execParser, fullDesc, info, header, help, helper, long, metavar
, option, short, str, strArgument, strOption, value , short, strArgument, strOption, value
) )
import qualified Paths_SJW as SJW (version) import qualified Paths_SJW as SJW (version)
import System.IO (stderr, hPutStrLn) import System.IO (stderr, hPutStrLn)
@ -57,20 +57,22 @@ getConfig = execParser $
(helper <*> configParser) (helper <*> configParser)
(fullDesc <> header ("SJW v" ++ showVersion SJW.version)) (fullDesc <> header ("SJW v" ++ showVersion SJW.version))
runCompiler :: Config -> IO (Text, [String]) runCompiler :: Config -> IO (Either String (Text, [String]))
runCompiler (Config {includes, mainIs, target}) = do runCompiler (Config {includes, mainIs, target}) = do
codePaths <- CodePath . (target:) <$> packages includes codePaths <- CodePath . (target:) <$> packages includes
flip (evalRWST Compiler.main) Map.empty $ Context { let initialContext = Context {codePaths, mainModule = read mainIs}
codePaths runExceptT $ evalRWST Compiler.main initialContext Module.emptySpace
, mainModule = read mainIs
}
main :: IO () main :: IO ()
main = do main = do
config@(Config {outputFile}) <- getConfig config@(Config {outputFile}) <- getConfig
(sourceCode, logs) <- runCompiler config result <- runCompiler config
mapM_ (hPutStrLn stderr) logs case result of
output outputFile . Text.unpack $ sourceCode Left errorMessage -> printErr errorMessage
Right (sourceCode, logs) -> do
mapM_ printErr logs
output outputFile . Text.unpack $ sourceCode
where where
printErr = hPutStrLn stderr
output "-" = putStr output "-" = putStr
output fileName = writeFile fileName output fileName = writeFile fileName

View file

@ -1,28 +1,67 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Module ( module Module (
Module(..) Compiler
, Contextual
, Entry(..)
, Failable
, ImportTree(..)
, Log
, Module(..)
, Modules
, ModuleSpace(..)
, Reference(..)
, buildEntry
, emptySpace
, parse , parse
, register
, reorder
) where ) where
import Context (CodePath(..), Context(..), Contextual, Path(..)) import Context (CodePath(..), Context(..), Path(..))
import Control.Applicative ((<|>)) import Control.Applicative ((<|>), many, optional)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (asks) import Control.Monad.RWS (MonadReader, MonadState, MonadWriter, asks, modify)
import Data.Attoparsec.Text ( import Data.Attoparsec.Text (
Parser, char, parseOnly, sepBy, string, takeTill, takeWhile 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 qualified Data.Set as Set (empty, insert, toList)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text (concat, pack) import qualified Data.Text as Text (pack)
import Prelude hiding (takeWhile) import Prelude hiding (takeWhile)
import Priority (Queue, empty)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>)) import System.FilePath ((</>), (<.>))
import Text.Printf (printf) import Text.Printf (printf)
type ImportTree = Int 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 { data Mapping = Mapping {
exposedName :: String exposedName :: Path
, sourceObject :: String , reference :: Reference
} }
data Module = Module { data Module = Module {
@ -30,32 +69,118 @@ data Module = Module {
, payload :: [Text] , payload :: [Text]
} deriving Show } deriving Show
importParser :: Parser [Mapping] data Entry = Entry {
importParser = content :: Module
string "import" *> space *> pure [] <* space <* char ';' , dependencies :: [Path]
where }
space = takeWhile (`elem` [' ', '\t'])
treeOf :: [[Mapping]] -> ImportTree data ModuleSpace = ModuleSpace {
treeOf = foldl (\n l -> n + length l) 0 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 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 :: Parser Module
moduleParser = Module moduleParser = Module
<$> (treeOf <$> importParser `sepBy` blank) <$> (foldl (foldl insertMapping) emptyTree <$> importParser `sepBy` blank)
<*> line `sepBy` eol <*> (blank *> line `sepBy` eol)
where where
eol = string "\r\n" <|> string "\r" <|> string "\n" eol = string "\r\n" <|> string "\r" <|> string "\n"
blank = takeWhile (`elem` [' ', '\t', '\r', '\n']) blank = takeWhile (inClass " \t\r\n")
line = takeTill (`elem` ['\r', '\n']) line = takeTill isEndOfLine
parse :: Path -> Contextual (Either String Module) buildEntry :: Module -> Entry
buildEntry content = Entry {content, dependencies}
where
dependencies =
Set.toList . recurse pushDependency Set.empty $ imports content
pushDependency set _ ref = Set.insert (modulePath ref) set
parse :: (Contextual m, MonadIO m, Failable m) => Path -> m Module
parse path = do parse path = do
searchPath <- asks codePaths searchPath <- asks codePaths
maybeSource <- find searchPath path maybeSource <- find searchPath path
case maybeSource of case maybeSource of
Nothing -> return . Left $ Nothing -> throwError $
printf "Module %s not found in paths : %s" (show path) (show searchPath) printf "Module %s not found in paths : %s" (show path) (show searchPath)
Just source -> Just source -> either throwError return =<<
parseOnly moduleParser . Text.pack <$> liftIO (readFile source) parseOnly moduleParser . Text.pack <$> liftIO (readFile source)
find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath) find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath)