90 lines
3.1 KiB
Haskell
90 lines
3.1 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Compiler (
|
|
main
|
|
) where
|
|
|
|
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 (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 indentLine
|
|
where
|
|
indentLine t
|
|
| 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 (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 = "});"
|