{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Development.Cake3.Ext.UrWeb where

import Data.Data
import Data.Char
import Data.Typeable
import Data.Generics
import Data.Maybe
import Data.Monoid
import Data.List ()
import qualified Data.List as L
import Data.Set (Set)
import qualified Data.Set as S
import Data.Foldable (Foldable(..), foldl')
import qualified Data.Foldable as F
import Data.ByteString.Char8 (ByteString(..))
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import Data.String
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Error
import Language.JavaScript.Parser
import Network.Mime (defaultMimeLookup)
import System.Directory
import Text.Printf
import qualified System.FilePath as F
import System.IO as IO

import System.FilePath.Wrapper
import Development.Cake3.Monad
import Development.Cake3

data UrpAllow = UrpMime | UrpUrl | UrpResponseHeader
  deriving(Show,Data,Typeable)

data UrpRewrite = UrpStyle | UrpAll
  deriving(Show,Data,Typeable)

data UrpHdrToken = UrpDatabase String
                 | UrpSql File
                 | UrpAllow UrpAllow String
                 | UrpRewrite UrpRewrite String
                 | UrpLibrary File
                 | UrpDebug
                 | UrpInclude File
                 | UrpLink File String
                 | UrpSrc File String String
                 | UrpPkgConfig String
                 | UrpFFI File
                 | UrpJSFunc String String String -- ^ Module name, UrWeb name, JavaScript name
                 | UrpSafeGet String
                 | UrpScript String
  deriving(Show,Data,Typeable)

data UrpModToken
  = UrpModule1 File
  | UrpModule2 File File
  | UrpModuleSys String
  deriving(Show,Data,Typeable)

data Urp = Urp {
    urp :: File
  , uexe :: Maybe File
  , uhdr :: [UrpHdrToken]
  , umod :: [UrpModToken]
  } deriving(Show,Data,Typeable)

newtype UWLib = UWLib Urp
  deriving (Show,Data,Typeable)

newtype UWExe = UWExe Urp
  deriving (Show,Data,Typeable)

instance (MonadAction a m) => RefInput a m UWLib where
  refInput (UWLib u) = refInput (urp u)
 
instance (MonadAction a m) => RefInput a m UWExe where
  refInput (UWExe u) = refInput (urpExe u)
 
class UrpLike x where
  toUrp :: x -> Urp
  tempfiles :: x -> [File]
  tempfiles = (\x -> (urpObjs x) ++ maybeToList (urpSql' x) ++ maybeToList (urpExe' x)) . toUrp

instance UrpLike Urp where
  toUrp = id

instance UrpLike UWLib where
  toUrp (UWLib x) = x
instance UrpLike UWExe where
  toUrp (UWExe x) = x

urpDeps :: Urp -> [File]
urpDeps (Urp _ _ hdr mod) = foldl' scan2 (foldl' scan1 mempty hdr) mod where
  scan1 a (UrpLink f _) = f:a
  scan1 a (UrpSrc f _ _) = (f.="o"):a
  scan1 a (UrpInclude f) = f:a
  scan1 a _ = a
  scan2 a (UrpModule1 f) = f:a
  scan2 a (UrpModule2 f1 f2) = f1:f2:a
  scan2 a _ = a

urpSql' :: Urp -> Maybe File
urpSql' (Urp _ _ hdr _) = find hdr where
  find [] = Nothing
  find ((UrpSql f):hs) = Just f
  find (h:hs) = find hs

urpSql :: Urp -> File
urpSql u = case urpSql' u of
  Nothing -> error "ur project defines no SQL file"
  Just sql -> sql

urpSrcs (Urp _ _ hdr _) = foldl' scan [] hdr where
  scan a (UrpSrc f cfl lfl) = (f,cfl):a
  scan a _ = a

urpObjs (Urp _ _ hdr _) = foldl' scan [] hdr where
  scan a (UrpSrc f _ lfl) = (f.="o"):a
  scan a (UrpLink f lfl) = (f):a
  scan a _ = a

urpLibs (Urp _ _ hdr _) = foldl' scan [] hdr where
  scan a (UrpLibrary f) = f:a
  scan a _ = a

urpExe' = uexe
urpExe u = case uexe u of
  Nothing -> error "ur project defines no EXE file"
  Just exe -> exe

urpPkgCfg (Urp _ _ hdr _) = foldl' scan [] hdr where
  scan a (UrpPkgConfig s) = s:a
  scan a _ = a

data UrpState = UrpState {
    urpst :: Urp
  } deriving (Show)

defState urp = UrpState (Urp urp Nothing [] [])

class ToUrpWord a where
  toUrpWord :: a -> String

instance ToUrpWord UrpAllow where
  toUrpWord (UrpMime) = "mime"
  toUrpWord (UrpUrl) = "url"
  toUrpWord (UrpResponseHeader) = "responseHeader"

instance ToUrpWord UrpRewrite where
  toUrpWord (UrpStyle) = "style"
  toUrpWord (UrpAll) = "all"

class ToUrpLine a where
  toUrpLine :: FilePath -> a -> String

maskPkgCfg s = "%" ++ (map toUpper s) ++ "%"

instance ToUrpLine UrpHdrToken where
  toUrpLine up (UrpDatabase dbs) = printf "database %s" dbs
  toUrpLine up (UrpSql f) = printf "sql %s" (up </> toFilePath f)
  toUrpLine up (UrpAllow a s) = printf "allow %s %s" (toUrpWord a) s
  toUrpLine up (UrpRewrite a s) = printf "rewrite %s %s" (toUrpWord a) s
  toUrpLine up (UrpLibrary f)
    | (takeFileName f) == "lib.urp" = printf "library %s" (up </> toFilePath (takeDirectory f))
    | otherwise = printf "library %s" (up </> toFilePath (dropExtension f))
  toUrpLine up (UrpDebug) = printf "debug"
  toUrpLine up (UrpInclude f) = printf "include %s" (up </> toFilePath f)
  toUrpLine up (UrpLink f lfl) = printf "link %s %s" lfl (up </> toFilePath f)
  toUrpLine up (UrpSrc f _ lfl) = printf "link %s %s" lfl (up </> toFilePath (f.="o"))
  toUrpLine up (UrpPkgConfig s) = printf "link %s" (maskPkgCfg s)
  toUrpLine up (UrpFFI s) = printf "ffi %s" (up </> toFilePath (dropExtensions s))
  toUrpLine up (UrpSafeGet s) = printf "safeGet %s" (dropExtensions s)
  toUrpLine up (UrpJSFunc s1 s2 s3) = printf "jsFunc %s.%s = %s" s1 s2 s3
  toUrpLine up (UrpScript s) = printf "script %s" s
  toUrpLine up e = error $ "toUrpLine: unhandled case " ++ (show e)

instance ToUrpLine UrpModToken where
  toUrpLine up (UrpModule1 f) = up </> toFilePath (dropExtensions f)
  toUrpLine up (UrpModule2 f _) = up </> toFilePath (dropExtensions f)
  toUrpLine up (UrpModuleSys s) = printf "$/%s" s

newtype UrpGen m a = UrpGen { unUrpGen :: StateT UrpState m a }
  deriving(Functor, Applicative, Monad, MonadState UrpState, MonadMake, MonadIO)

-- instance (Monad m) => MonadAction (UrpGen (A' m)) m where
--   liftAction a = UrpGen (lift a)

toFile f wr = liftIO $ writeFile (toFilePath f) $ execWriter $ wr

line :: (MonadWriter String m) => String -> m ()
line s = tell (s++"\n")

uwlib :: File -> UrpGen (Make' IO) () -> Make UWLib
uwlib urpfile m = do
  ((),s) <- runStateT (unUrpGen m) (defState urpfile)
  let u@(Urp _ _ hdr mod) = urpst s
  let pkgcfg = (urpPkgCfg u)

  inp <- rule' $ do
    let inp = urpfile .= "urp.in"
    toFile inp $ do
      forM hdr (line . toUrpLine (urpUp urpfile))
      line ""
      forM mod (line . toUrpLine (urpUp urpfile))

    forM_ (urpSrcs u) $ \(c,fl) -> do
      let flags = concat $ fl : map (\p -> printf "$(shell pkg-config --cflags %s) " p) (urpPkgCfg u)
      let i = makevar "URINCL" "-I$(shell urweb -print-cinclude) " 
      let cc = makevar "URCC" "$(shell $(shell urweb -print-ccompiler) -print-prog-name=gcc)"
      let cpp = makevar "URCPP" "$(shell $(shell urweb -print-ccompiler) -print-prog-name=g++)"
      rule2 $ do
        case takeExtension c of
          ".cpp" -> shell [cmd| $cpp -c $i $(string flags) -o @(c .= "o") $(c) |]
          ".c" -> shell [cmd| $cc -c $i -o $(string flags) @(c .= "o") $(c) |]
          e -> error ("Unknown C-source extension " ++ e)

    depend (urpDeps u)
    depend (urpLibs u)
    shell [cmd|touch @inp|]

  rule' $ do
    let cpy = [cmd|cat $inp|] :: CommandGen' (Make' IO)
    let l = foldl' (\a p -> do
                            let l = makevar (map toUpper $ printf "lib%s" p) (printf "$(shell pkg-config --libs %s)" p)
                            [cmd| $a | sed 's@@$(string $ maskPkgCfg p)@@$l@@'  |]
                            ) cpy pkgcfg
    shell [cmd| $l > @urpfile |]

  return $ UWLib u

uwapp :: String -> File -> UrpGen (Make' IO) () -> Make UWExe
uwapp opts urpfile m = do
  (UWLib u') <- uwlib urpfile m
  let u = u' { uexe = Just (urpfile .= "exe") }
  rule $ do
    depend urpfile
    produce (urpExe u)
    case urpSql' u of
      Nothing -> return ()
      Just sql -> produce sql
    depend (makevar "URVERSION" "$(shell urweb -version)")
    unsafeShell [cmd|urweb $(string opts) $((takeDirectory urpfile)</>(takeBaseName urpfile))|]
  return $ UWExe u

liftUrp m = m

addHdr h = modify $ \s -> let u = urpst s in s { urpst = u { uhdr = (uhdr u) ++ [h] } }
addMod m = modify $ \s -> let u = urpst s in s { urpst = u { umod = (umod u) ++ [m] } }

database :: (MonadMake m) => String -> UrpGen m ()
database dbs = addHdr $ UrpDatabase dbs
  
allow :: (MonadMake m) => UrpAllow -> String -> UrpGen m ()
allow a s = addHdr $ UrpAllow a s

rewrite :: (MonadMake m) => UrpRewrite -> String -> UrpGen m ()
rewrite a s = addHdr $ UrpRewrite a s

urpUp :: File -> FilePath
urpUp f = F.joinPath $ map (const "..") $ filter (/= ".") $ F.splitDirectories $ F.takeDirectory $ toFilePath f

-- | Dir name , file to embed
-- data UrEmbed = Urembed File File
--   deriving (Show)

-- data UrpLibReference
--   = UrpLibStandaloneMake File 
--   | UrpLibStandaloneMake2 File 
--   | UrpLibInternal UWLib
--   | UrpLibEmbed File File
--   deriving(Show)

-- | A general method of including a library into the UrWeb project.
library' :: (MonadMake m)
  => Make [File] -- ^ A monadic action, returning a list of libraries to include
  -> UrpGen m ()
library' ml = do
  ls <- liftMake ml
  forM_ ls $ \l -> do
    when ((takeExtension l) /= ".urp") $ do
      fail $ printf "library declaration for %s should ends with '.urp'" (toFilePath l)
    addHdr $ UrpLibrary l

-- | Include a library defined somewhere in the current project
library :: (MonadMake m) => UWLib -> UrpGen m ()
library (UWLib u) = library' $ do
  return [urp u]

-- | Build a file using external Makefile facility.
externalMake' ::
     File -- ^ External Makefile
  -> File -- ^ External file to refer to
  -> Make [File]
externalMake' mk f = do
  prebuild [cmd|$(make) -C $(string $ toFilePath $ takeDirectory mk) -f $(string $ takeFileName mk)|]
  return [f]

-- | Build a file from external project. It is expected, that this project has a
-- 'Makwfile' in it's root directory
externalMake ::
     File -- ^ File from the external project to build
  -> Make [File]
externalMake f = externalMake' (takeDirectory f </> "Makefile") f

-- | Build a file from external project. It is expected, that this project has a
-- fiel.mk (a Makefile with an unusual name) in it's root directory
externalMake2 :: File -> Make [File]
externalMake2 f = externalMake' ((takeDirectory f </> takeFileName f) .= "mk") f

ur, module_ :: (MonadMake m) => UrpModToken -> UrpGen m ()
module_ = addMod
ur = addMod

pair f = UrpModule2 (f.="ur") (f.="urs")
single f = UrpModule1 f
sys s = UrpModuleSys s

debug :: (MonadMake m) => UrpGen m ()
debug = addHdr $ UrpDebug

include :: (MonadMake m) => File -> UrpGen m ()
include f = addHdr $ UrpInclude f

link' :: (MonadMake m) => File -> String -> UrpGen m ()
link' f fl = addHdr $ UrpLink f fl

link :: (MonadMake m) => File -> UrpGen m ()
link f = link' f []

csrc'  :: (MonadMake m) => File -> String -> String -> UrpGen m ()
csrc' f cfl lfl = addHdr $ UrpSrc f cfl lfl

csrc  :: (MonadMake m) => File -> UrpGen m ()
csrc f = csrc' f [] []

ffi :: (MonadMake m) => File -> UrpGen m ()
ffi s = addHdr $ UrpFFI s

sql :: (MonadMake m) => File -> UrpGen m ()
sql f = addHdr $ UrpSql f
  
jsFunc m u j = addHdr $ UrpJSFunc m u j

safeGet s = addHdr $ UrpSafeGet s

url = UrpUrl

mime = UrpMime

style = UrpStyle

all = UrpAll

responseHeader = UrpResponseHeader

script :: (MonadMake m) => String -> UrpGen m ()
script s = addHdr $ UrpScript s

guessMime inf = fixup $ BS.unpack (defaultMimeLookup (fromString inf)) where
  fixup "application/javascript" = "text/javascript"
  fixup m = m

pkgconfig :: (MonadMake m) => String -> UrpGen m ()
pkgconfig l = addHdr $ UrpPkgConfig l

data JSFunc = JSFunc {
    urdecl :: String -- ^ URS declaration for this function
  , urname :: String -- ^ UrWeb name of this function
  , jsname :: String -- ^ JavaScript name of this function
  } deriving(Show)

data JSType = JSType {
    urtdecl :: String
  } deriving(Show)

-- | Parse the JavaScript file, extract top-level functions, convert their
-- signatures into Ur/Web format, return them as the list of strings
parse_js :: BS.ByteString -> Make (Either String ([JSType],[JSFunc]))
parse_js contents = do
  runErrorT $ do
    c <- either fail return (parse (BS.unpack contents) "<urembed_input>")
    f <- concat <$> (forM (findTopLevelFunctions c) $ \f@(fn:_) -> (do
      ts <- mapM extractEmbeddedType (f`zip`(False:repeat True))
      let urdecl_ = urs_line ts
      let urname_ = (fst (head ts))
      let jsname_ = fn
      return [JSFunc urdecl_ urname_ jsname_]
      ) `catchError` (\(e::String) -> do
        err $ printf "ignoring function %s, reason:\n\t%s" fn e
        return []))
    t <- concat <$> (forM (findTopLevelVars c) $ \vn -> (do
      (n,t) <- extractEmbeddedType (vn,False)
      return [JSType $ printf "type %s" t]
      )`catchError`  (\(e::String) -> do
        err $ printf "ignoring variable %s, reason:\n\t%s" vn e
        return []))
    return (t,f)

  where
    urs_line :: [(String,String)] -> String
    urs_line [] = error "wrong function signature"
    urs_line ((n,nt):args) = printf "val %s : %s" n (fmtargs args) where
      fmtargs :: [(String,String)] -> String
      fmtargs ((an,at):as) = printf "%s -> %s" at (fmtargs as)
      fmtargs [] = let pf = L.stripPrefix "pure_" nt in
                   case pf of
                     Just p -> p
                     Nothing -> printf "transaction %s" nt

    extractEmbeddedType :: (Monad m) => (String,Bool) -> m (String,String)
    extractEmbeddedType ([],_) = error "BUG: empty identifier"
    extractEmbeddedType (name,fallback) = check (msum [span2  "__" name , span2 "_as_" name]) where
      check (Just (n,t)) = return (n,t)
      check _ | fallback == True = return (name,name)
              | fallback == False = fail $ printf "Can't extract the type from the identifier '%s'" name

    findTopLevelFunctions :: JSNode -> [[String]]
    findTopLevelFunctions top = map decls $ listify is_func top where
      is_func n@(JSFunction a b c d e f) = True
      is_func _ = False
      decls (JSFunction a b c d e f) = (identifiers b) ++ (identifiers d)

    findTopLevelVars :: JSNode -> [String]
    findTopLevelVars top = map decls $ listify is_var top where
      is_var n@(JSVarDecl a []) = True
      is_var _ = False
      decls (JSVarDecl a _) = (head $ identifiers a);
      
    identifiers x = map name $ listify ids x where
      ids i@(JSIdentifier s) = True
      ids _ = False
      name (JSIdentifier n) = n

    err,out :: (MonadIO m) => String -> m ()
    err = hio stderr
    out = hio stdout

    span2 :: String -> String -> Maybe (String,String)
    span2 inf s = span' [] s where
      span' _ [] = Nothing
      span' acc (c:cs)
        | L.isPrefixOf inf (c:cs) = Just (acc, drop (length inf) (c:cs))
        | otherwise = span' (acc++[c]) cs

    hio :: (MonadIO m) => Handle -> String -> m ()
    hio h = liftIO . hPutStrLn h

bin :: (MonadIO m, MonadMake m) => File -> File -> UrpGen m ()
bin dir src = do
  c <- readFileForMake src
  bin' dir (toFilePath src) c

bin' :: (MonadIO m, MonadMake m) => File -> FilePath -> BS.ByteString -> UrpGen m ()
bin' dir src_name src_contents = do

  let mime = guessMime src_name
  let mn = (mkname src_name)
  let wrapmod ext = (dir </> mn) .= ext
  let binmod ext = (dir </> (mn ++ "_c")) .= ext
  let jsmod ext = (dir </> (mn ++ "_js")) .= ext

  -- Binary module
  let binfunc = printf "uw_%s_binary" (modname binmod)
  let textfunc = printf "uw_%s_text" (modname binmod)
  toFile (binmod ".c") $ do
    line $ "/* Thanks, http://stupefydeveloper.blogspot.ru/2008/08/cc-embed-binary-data-into-elf.html */"
    line $ "#include <urweb.h>"
    line $ "#include <stdio.h>"
    line $ printf "#define BLOBSZ %d" (BS.length src_contents)
    line $ "static char blob[BLOBSZ];"
    line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit)"
    line $ "{"
    line $ "  uw_Basis_blob uwblob;"
    line $ "  uwblob.data = &blob[0];"
    line $ "  uwblob.size = BLOBSZ;"
    line $ "  return uwblob;"
    line $ "}"
    line $ ""
    line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit) {"
    line $ "  char* data = &blob[0];"
    line $ "  size_t size = sizeof(blob);"
    line $ "  char * c = uw_malloc(ctx, size+1);"
    line $ "  char * write = c;"
    line $ "  int i;"
    line $ "  for (i = 0; i < size; i++) {"
    line $ "    *write =  data[i];"
    line $ "    if (*write == '\\0')"
    line $ "    *write = '\\n';"
    line $ "    *write++;"
    line $ "  }"
    line $ "  *write=0;"
    line $ "  return c;"
    line $ "  }"
    line $ ""

  let append f wr = liftIO $ BS.appendFile f $ execWriter $ wr
  append (toFilePath (binmod ".c")) $ do
    let line s = tell ((BS.pack s)`mappend`(BS.pack "\n"))
    line $ ""
    line $ "static char blob[BLOBSZ] = {"
    let buf = reverse $ BS.foldl (\a c -> (BS.pack (printf "0x%02X ," c)) : a) [] src_contents
    tell (BS.concat buf)
    line $ "};"
    line $ ""

  toFile (binmod ".h") $ do
    line $ "#include <urweb.h>"
    line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit);"
    line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit);"

  toFile (binmod ".urs") $ do
    line $ "val binary : unit -> transaction blob"
    line $ "val text : unit -> transaction string"

  include (binmod ".h")
  link (binmod ".o")
  ffi (binmod ".urs")

  -- JavaScript FFI Module
  (jstypes,jsdecls) <- if ((takeExtension src_name) == ".js") then do
                          e <- liftMake $ parse_js src_contents
                          case e of
                            Left e -> do
                              fail $ printf "Error while parsing %s" src_name
                            Right decls -> do
                              return decls
                       else
                          return ([],[])

  toFile (jsmod ".urs") $ do
    forM_ jstypes $ \decl -> line (urtdecl decl)
    forM_ jsdecls $ \decl -> line (urdecl decl)
  
  -- Wrapper module
  toFile (wrapmod ".urs") $ do
    line $ "val binary : unit -> transaction blob"
    line $ "val text : unit -> transaction string"
    line $ "val blobpage : unit -> transaction page"
    line $ "val geturl : url"
    forM_ jstypes $ \decl -> line (urtdecl decl)
    forM_ jsdecls $ \d -> line (urdecl d)

  toFile (wrapmod ".ur") $ do
    line $ "val binary = " ++ modname binmod ++ ".binary"
    line $ "val text = " ++ modname binmod ++ ".text"
    forM_ jsdecls $ \d ->
      line $ printf "val %s = %s.%s" (urname d) (modname jsmod) (urname d)
    line $ printf "fun blobpage {} = b <- binary () ; returnBlob b (blessMime \"%s\")" mime
    line $ "val geturl = url(blobpage {})"

  forM_ jsdecls $ \decl -> do
    addHdr $ UrpJSFunc (modname jsmod) (urname decl) (jsname decl)
  ffi (jsmod ".urs")

  safeGet $ printf "%s/blobpage" (modname wrapmod)
  safeGet $ printf "%s/blob" (modname wrapmod)
  module_ (pair $ wrapmod ".ur")

  where

    mkname :: FilePath -> String
    mkname = upper1 . notnum . map under . takeFileName where
      under c | c`elem`"_-. /" = '_'
              | otherwise = c
      upper1 [] = []
      upper1 (x:xs) = (toUpper x) : xs
      notnum n@(x:xs) | isDigit x = "f" ++ n
                      | otherwise = n

    modname :: (String -> File) -> String
    modname f = upper1 . takeBaseName $ f ".urs" where
      upper1 [] = []
      upper1 (x:xs) = (toUpper x) : xs