Implement the imports, dependencies solving and generation of the code
This commit is contained in:
parent
6b254dcdeb
commit
f3c43c79e7
3 changed files with 240 additions and 57 deletions
|
|
@ -1,33 +1,89 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Compiler (
|
||||
main
|
||||
) 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 qualified Data.Text as Text (concat)
|
||||
import Module (Module(..))
|
||||
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 Priority (set, toList)
|
||||
import Text.Printf (printf)
|
||||
|
||||
indent :: [Text] -> [Text]
|
||||
indent = fmap (cons '\t')
|
||||
|
||||
include :: Bool -> Module -> Text
|
||||
include isMain (Module {imports, payload}) = Text.concat $
|
||||
header isMain
|
||||
: indent payload
|
||||
++ footer isMain
|
||||
indent = fmap indentLine
|
||||
where
|
||||
header True = "(function() {\n"
|
||||
header False = "modules[''] = (function() {\n"
|
||||
footer True = ["})());"]
|
||||
footer False = [
|
||||
"})());"
|
||||
, "Object.freeze(modules['']);"
|
||||
]
|
||||
indentLine t
|
||||
| Text.null t = t
|
||||
| otherwise = cons '\t' t
|
||||
|
||||
scan :: Contextual ()
|
||||
scan = undefined
|
||||
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
|
||||
|
||||
main :: Contextual Text
|
||||
main = undefined
|
||||
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 (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 = "});"
|
||||
|
|
|
|||
28
src/Main.hs
28
src/Main.hs
|
|
@ -2,17 +2,17 @@
|
|||
module Main where
|
||||
|
||||
import qualified Compiler (main)
|
||||
import Context (CodePath(..), Context (..), Path(..), packages)
|
||||
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 qualified Data.Map as Map (empty)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text (unpack)
|
||||
import Data.Version (showVersion)
|
||||
import qualified Module (parse)
|
||||
import qualified Module (emptySpace)
|
||||
import Options.Applicative (
|
||||
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 System.IO (stderr, hPutStrLn)
|
||||
|
|
@ -57,20 +57,22 @@ getConfig = execParser $
|
|||
(helper <*> configParser)
|
||||
(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
|
||||
codePaths <- CodePath . (target:) <$> packages includes
|
||||
flip (evalRWST Compiler.main) Map.empty $ Context {
|
||||
codePaths
|
||||
, mainModule = read mainIs
|
||||
}
|
||||
let initialContext = Context {codePaths, mainModule = read mainIs}
|
||||
runExceptT $ evalRWST Compiler.main initialContext Module.emptySpace
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
config@(Config {outputFile}) <- getConfig
|
||||
(sourceCode, logs) <- runCompiler config
|
||||
mapM_ (hPutStrLn stderr) logs
|
||||
output outputFile . Text.unpack $ sourceCode
|
||||
result <- runCompiler config
|
||||
case result of
|
||||
Left errorMessage -> printErr errorMessage
|
||||
Right (sourceCode, logs) -> do
|
||||
mapM_ printErr logs
|
||||
output outputFile . Text.unpack $ sourceCode
|
||||
where
|
||||
printErr = hPutStrLn stderr
|
||||
output "-" = putStr
|
||||
output fileName = writeFile fileName
|
||||
|
|
|
|||
171
src/Module.hs
171
src/Module.hs
|
|
@ -1,28 +1,67 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Module (
|
||||
Module(..)
|
||||
Compiler
|
||||
, Contextual
|
||||
, Entry(..)
|
||||
, Failable
|
||||
, ImportTree(..)
|
||||
, Log
|
||||
, Module(..)
|
||||
, Modules
|
||||
, ModuleSpace(..)
|
||||
, Reference(..)
|
||||
, buildEntry
|
||||
, emptySpace
|
||||
, parse
|
||||
, register
|
||||
, reorder
|
||||
) where
|
||||
|
||||
import Context (CodePath(..), Context(..), Contextual, Path(..))
|
||||
import Control.Applicative ((<|>))
|
||||
import Context (CodePath(..), Context(..), Path(..))
|
||||
import Control.Applicative ((<|>), many, optional)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Reader (asks)
|
||||
import Control.Monad.RWS (MonadReader, MonadState, MonadWriter, asks, modify)
|
||||
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 qualified Data.Text as Text (concat, pack)
|
||||
import qualified Data.Text as Text (pack)
|
||||
import Prelude hiding (takeWhile)
|
||||
import Priority (Queue, empty)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath ((</>), (<.>))
|
||||
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 {
|
||||
exposedName :: String
|
||||
, sourceObject :: String
|
||||
exposedName :: Path
|
||||
, reference :: Reference
|
||||
}
|
||||
|
||||
data Module = Module {
|
||||
|
|
@ -30,32 +69,118 @@ data Module = Module {
|
|||
, payload :: [Text]
|
||||
} deriving Show
|
||||
|
||||
importParser :: Parser [Mapping]
|
||||
importParser =
|
||||
string "import" *> space *> pure [] <* space <* char ';'
|
||||
where
|
||||
space = takeWhile (`elem` [' ', '\t'])
|
||||
data Entry = Entry {
|
||||
content :: Module
|
||||
, dependencies :: [Path]
|
||||
}
|
||||
|
||||
treeOf :: [[Mapping]] -> ImportTree
|
||||
treeOf = foldl (\n l -> n + length l) 0
|
||||
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 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
|
||||
<$> (treeOf <$> importParser `sepBy` blank)
|
||||
<*> line `sepBy` eol
|
||||
<$> (foldl (foldl insertMapping) emptyTree <$> importParser `sepBy` blank)
|
||||
<*> (blank *> line `sepBy` eol)
|
||||
where
|
||||
eol = string "\r\n" <|> string "\r" <|> string "\n"
|
||||
blank = takeWhile (`elem` [' ', '\t', '\r', '\n'])
|
||||
line = takeTill (`elem` ['\r', '\n'])
|
||||
blank = takeWhile (inClass " \t\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
|
||||
searchPath <- asks codePaths
|
||||
maybeSource <- find searchPath path
|
||||
case maybeSource of
|
||||
Nothing -> return . Left $
|
||||
Nothing -> throwError $
|
||||
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)
|
||||
|
||||
find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath)
|
||||
|
|
|
|||
Loading…
Reference in a new issue