{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module SJW.Compiler (
    main
  ) where

import SJW.Source (Source(..), HasSource, Path)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.RWS (ask, gets)
import Data.Map ((!))
import qualified Data.Map as Map (member)
import Data.Text (Text, cons)
import qualified Data.Text as Text (null, unlines)
import SJW.Dependencies as Dependencies (Failable, solve)
import SJW.Module (Environment, Log, Module(..), Modules(..))
import qualified SJW.Module as Module (parse, register)
import SJW.Module.File (File(..), variables)
import qualified SJW.Module.File as File (header, footer)

type Compiler m = (HasSource m, Log m, Environment m, MonadIO m, Failable m)

indent :: [Text] -> [Text]
indent :: [Text] -> [Text]
indent = (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
indentLine
  where
    indentLine :: Text -> Text
indentLine Text
t
      | Text -> Bool
Text.null Text
t = Text
t
      | Bool
otherwise = Char -> Text -> Text
cons Char
'\t' Text
t

include :: Environment m => Path -> m [Text]
include :: Path -> m [Text]
include Path
path = do
  File {Bool
isMain :: File -> Bool
isMain :: Bool
isMain, Tree
imports :: File -> Tree
imports :: Tree
imports, [Text]
payload :: File -> [Text]
payload :: [Text]
payload} <- (Modules -> File) -> m File
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Module -> File
file (Module -> File) -> (Modules -> Module) -> Modules -> File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Path Module -> Path -> Module
forall k a. Ord k => Map k a -> k -> a
! Path
path) (Map Path Module -> Module)
-> (Modules -> Map Path Module) -> Modules -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modules -> Map Path Module
modules)
  let ([String]
names, [String]
values) = [(String, String)] -> ([String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, String)] -> ([String], [String]))
-> [(String, String)] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ Tree -> [(String, String)]
variables Tree
imports
  [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Bool -> Path -> [String] -> Text
File.header Bool
isMain Path
path [String]
names Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
indent [Text]
payload [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [String] -> [Text]
File.footer [String]
values

scan :: Compiler m => Bool -> Path -> m ()
scan :: Bool -> Path -> m ()
scan Bool
isMain Path
modulePath = do
  Bool
alreadyLoaded <- (Modules -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Path -> Map Path Module -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Path
modulePath (Map Path Module -> Bool)
-> (Modules -> Map Path Module) -> Modules -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modules -> Map Path Module
modules)
  if Bool
alreadyLoaded then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else m ()
forall (m :: * -> *). Compiler m => m ()
load
  where
    load :: Compiler m => m ()
    load :: m ()
load = do
      Module
newModule <- Bool -> Path -> m Module
forall (m :: * -> *).
(HasSource m, MonadIO m, Failable m) =>
Bool -> Path -> m Module
Module.parse Bool
isMain Path
modulePath
      Path -> Module -> m ()
forall (m :: * -> *). Environment m => Path -> Module -> m ()
Module.register Path
modulePath Module
newModule
      (Path -> m ()) -> Set Path -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Path -> m ()
forall (m :: * -> *). Compiler m => Bool -> Path -> m ()
scan Bool
False) (Set Path -> m ()) -> Set Path -> m ()
forall a b. (a -> b) -> a -> b
$ Module -> Set Path
dependencies Module
newModule

body :: Compiler m => m [Text]
body :: m [Text]
body = do
  [Path]
sortedPath <- Dependencies -> m [Path]
forall (m :: * -> *). Failable m => Dependencies -> m [Path]
Dependencies.solve (Dependencies -> m [Path]) -> m Dependencies -> m [Path]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Dependencies
dependenciesGraph
  [Text]
includes <- [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> m [[Text]] -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path -> m [Text]) -> [Path] -> m [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path -> m [Text]
forall (m :: * -> *). Environment m => Path -> m [Text]
include [Path]
sortedPath
  [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text
"var modules = {};" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
includes
  where
    dependenciesGraph :: m Dependencies
dependenciesGraph = (Modules -> Dependencies) -> m Dependencies
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Module -> Set Path) -> Map Path Module -> Dependencies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Set Path
dependencies (Map Path Module -> Dependencies)
-> (Modules -> Map Path Module) -> Modules -> Dependencies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modules -> Map Path Module
modules)

main :: Compiler m => m Text
main :: m Text
main = do
  Source {Path
mainModule :: Source -> Path
mainModule :: Path
mainModule} <- m Source
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool -> Path -> m ()
forall (m :: * -> *). Compiler m => Bool -> Path -> m ()
scan Bool
True Path
mainModule
  [Text]
codeBody <- m [Text]
forall (m :: * -> *). Compiler m => m [Text]
body
  Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> ([Text] -> Text) -> [Text] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Text
openOnLoad Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
indent [Text]
codeBody [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
closeOnLoad]
  where
    openOnLoad :: Text
openOnLoad = Text
"window.addEventListener('load', function() {"
    closeOnLoad :: Text
closeOnLoad = Text
"});"