File.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module SJW.Module.File (
      File(..)
    , header
    , footer
    , parser
    , variables
  ) where

import SJW.Source (Path)
import Control.Applicative ((<|>))
import Data.Attoparsec.Text (
      Parser, inClass, isEndOfLine, sepBy, string, takeTill, takeWhile
  )
import Data.List (intercalate)
import qualified Data.Map as Map (toList)
import Data.Text (Text)
import qualified Data.Text as Text (pack)
import SJW.Module.Imports (Reference(..), Tree(..))
import qualified SJW.Module.Imports as Imports (parser)
import Prelude hiding (takeWhile)
import Text.Printf (printf)

data File = File {
      isMain :: Bool
    , imports :: Tree
    , payload :: [Text]
  } deriving Show

parser :: Bool -> Parser File
parser isMain = File isMain
  <$> Imports.parser
  <*> (blank *> line `sepBy` eol)
  where
    eol = string "\r\n" <|> string "\r" <|> string "\n"
    blank = takeWhile (inClass " \t\r\n")
    line = takeTill isEndOfLine

header :: Bool -> Path -> [String] -> Text
header 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"])

footer :: [String] -> [Text]
footer values = [Text.pack $ printf "})(%s);" (intercalate ", " values)]

variables :: Tree -> [(String, String)]
variables = fmap (fmap computeValue) . Map.toList . children
  where
    computeValue :: Tree -> 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