From f3c43c79e7efe1f30aaba885a067b1965ca55d4e Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Wed, 1 Jan 2020 17:27:39 +0100
Subject: [PATCH] Implement the imports, dependencies solving and generation of
 the code

---
 src/Compiler.hs |  98 +++++++++++++++++++++------
 src/Main.hs     |  28 ++++----
 src/Module.hs   | 171 +++++++++++++++++++++++++++++++++++++++++-------
 3 files changed, 240 insertions(+), 57 deletions(-)

diff --git a/src/Compiler.hs b/src/Compiler.hs
index a2384db..fca0608 100644
--- a/src/Compiler.hs
+++ b/src/Compiler.hs
@@ -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 = "});"
diff --git a/src/Main.hs b/src/Main.hs
index ea3ece5..941a814 100644
--- a/src/Main.hs
+++ b/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
diff --git a/src/Module.hs b/src/Module.hs
index 056a95d..de431a4 100644
--- a/src/Module.hs
+++ b/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)