{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE CPP #-}

module Web.Apiary.PureScript.Internal where

import qualified System.FilePath.Glob as G
import qualified System.IO.UTF8 as U

import qualified Language.PureScript as P

import Control.Monad.Apiary.Action(ActionT, contentType, string, bytes)
import Control.Exception(Exception, throwIO, try)
import Control.Applicative((<$>))

import Web.Apiary(MonadIO(..))
import Data.Apiary.Extension(Extension)

import Data.Default.Class(Default(def))
import Data.IORef(IORef, newIORef, readIORef, atomicModifyIORef')
import Data.Typeable(Typeable)
import qualified Data.HashMap.Strict as H
import qualified Text.Parsec.Error as P

data PureScriptException
    = ParseError   P.ParseError
    | CompileError String
    deriving (Show, Typeable)
instance Exception PureScriptException

defaultPatterns :: [G.Pattern]
defaultPatterns = map G.compile 
    [ "src/**/*.purs"
    , "bower_components/purescript-*/src/**/*.purs"
    ]

data PureScriptConfig = PureScriptConfig
    { libraryPatterns   :: [G.Pattern]
    , libraryBaseDir    :: FilePath
    , development       :: Bool
    , initialCompiles   :: [FilePath]
    , pureScriptPrefix  :: [String]
    , pureScriptOptions :: P.Options P.Compile
    }

instance Default PureScriptConfig where
    def = PureScriptConfig 
        defaultPatterns
        "."
        False
        []
        ["Generated by apiary-purescript. purescript version: " ++ "0.6.3"] -- TODO
        P.defaultCompileOptions
        { P.optionsMain  = Just "Main" }

data PureScript = PureScript
    { pscConfig :: PureScriptConfig
    , compiled  :: IORef (H.HashMap FilePath String)
    }
instance Extension PureScript

makePureScript :: PureScriptConfig -> IO PureScript
makePureScript conf = do
    ir <- mapM (\p -> (p,) <$> compile conf p) (initialCompiles conf)
    p  <- PureScript conf <$> newIORef (H.fromList ir)
    return p

compile :: PureScriptConfig -> FilePath -> IO String
compile opt p = do
    mods <- G.globDir (libraryPatterns opt) (libraryBaseDir opt)
        >>= mapM (\f -> (f,) <$> U.readFile f) . (p:) . concat . fst
    case P.parseModulesFromFiles id $ ("prelude", P.prelude) : mods of
        Left l   -> throwIO (ParseError l)
        Right ms -> case P.compile (pureScriptOptions opt) (map snd ms) (pureScriptPrefix opt) of
            Left l         -> throwIO (CompileError l)
            Right (js,_,_) -> return js

pureScript :: MonadIO m => PureScript -> FilePath -> ActionT exts prms m ()
pureScript env p = do
    contentType "text/javascript"
    s <- liftIO . try $ 
        if development (pscConfig env)
        then compile (pscConfig env) p
        else (H.lookup p <$> readIORef (compiled env)) >>= \case
           Nothing -> do
               r <- compile (pscConfig env) p
               atomicModifyIORef' (compiled env) ((,()) . H.insert p r)
               return r
           Just r  -> return r
    case s of
        Right r -> string r
        Left  e | development (pscConfig env) -> do
            bytes "console.log(\""
            string $ pr (e :: PureScriptException)
            bytes "\")"
                | otherwise -> bytes "console.log(\"PureScript error.\");"
  where
    pr = concatMap esc . show
    esc '"'  = "\\\""
    esc '\'' = "\\'"
    esc '\\' = "\\\\"
    esc '/'  = "\\/"
    esc '<'  = "\\x3c"
    esc '>'  = "\\x3e"
    esc '\n' = "\\n"
    esc c    = [c]