src/Language/Fay/Compiler.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

module Language.Fay.Compiler where

import Language.Fay                 (compileToplevelModule,compileViaStr,prettyPrintString)
import Language.Fay.Types

import Control.Monad
import Language.Haskell.Exts.Syntax
import Paths_fay
import System.FilePath
import Text.Groom

-- | A result of something the compiler writes.
class Writer a where
  writeout :: a -> String -> IO ()

-- | Something to feed into the compiler.
class Reader a where
  readin :: a -> IO String

-- | Simple file writer.
instance Writer FilePath where
  writeout = writeFile

-- | Simple file reader.
instance Reader FilePath where
  readin = readFile

-- | Compile file program to…
compileFromTo :: CompileConfig -> FilePath -> FilePath -> IO ()
compileFromTo config filein fileout = do
  result <- compileFile config filein
  case result of
    Right out -> do
      writeFile fileout out
      when (configHtmlWrapper config) $
        writeFile (replaceExtension fileout "html") $ unlines [
            "<!doctype html>"
          , "<html>"
          , "  <head>"
          , unlines . map ("    "++) . map makeScriptTagSrc $ configHtmlJSLibs config
          , "    " ++ makeScriptTagSrc relativeJsPath
          , "    </script>"
          , "  </head>"
          , "  <body>"
          , "  </body>"
          , "</html>"]
            where relativeJsPath = makeRelative (dropFileName fileout) fileout
                  makeScriptTagSrc :: FilePath -> String
                  makeScriptTagSrc = \s ->
                    "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"
    Left err -> error . groom $ err

-- | Compile readable/writable values.
compileReadWrite :: (Reader r, Writer w) => CompileConfig -> r -> w -> IO ()
compileReadWrite config reader writer = do
  result <- compileFile config reader
  case result of
    Right out -> do
      writeout writer out
    Left err -> error . groom $ err

-- | Compile the given file.
compileFile :: (Reader r) => CompileConfig -> r -> IO (Either CompileError String)
compileFile config filein = do
  runtime <- getDataFileName "js/runtime.js"
  stdlibpath <- getDataFileName "hs/stdlib.hs"
  stdlibpathprelude <- getDataFileName "src/Language/Fay/Stdlib.hs"
  raw <- readFile runtime
  stdlib <- readFile stdlibpath
  stdlibprelude <- readFile stdlibpathprelude
  hscode <- readin filein
  compileProgram config
                 raw
                 compileToplevelModule
                 (hscode ++ "\n" ++ stdlib ++ "\n" ++ strip stdlibprelude)

  where strip = unlines . dropWhile (/="-- START") . lines

-- | Compile the given module to a runnable program.
compileProgram :: (Show from,Show to,CompilesTo from to)
               => CompileConfig -> String -> (from -> Compile to) -> String
               -> IO (Either CompileError String)
compileProgram config raw with hscode = do
  result <- compileViaStr config with hscode
  case result of
    Left err -> return (Left err)
    Right (jscode,state) -> fmap Right $
      let out = generate jscode (stateExports state) (stateModuleName state)
      in if configPrettyPrint config
            then prettyPrintString out
            else return out

  where generate jscode exports (ModuleName modulename) = unlines
          ["/** @constructor"
          ,"*/"
          ,"var " ++ modulename ++ " = function(){"
          ,raw
          ,jscode
          ,"// Exports"
          ,unlines (map printExport exports)
          ,"// Built-ins"
          ,"this._ = _;"
          ,if configExportBuiltins config
              then unlines ["this.$           = $;"
                           ,"this.$fayToJs    = Fay$$fayToJs;"
                           ,"this.$jsToFay    = Fay$$jsToFay;"
                           ]
              else ""
          ,"};"
          ,if configAutorun config
              then unlines [";"
                           ,"var main = new " ++ modulename ++ "();"
                           ,"main._(main.main);"
                           ]
              else ""
          ]

-- | Print an this.x = x; export out.
printExport :: Name -> String
printExport name =
  printJS (JsSetProp ":this"
                     (UnQual name)
                     (JsName (UnQual name)))

-- | Convert a Haskell filename to a JS filename.
toJsName :: String -> String
toJsName x = case reverse x of
               ('s':'h':'.': (reverse -> file)) -> file ++ ".js"
               _ -> x