{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-
  Copyright 2020 The CodeWorld Authors. All Rights Reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}
module Blocks.CodeGen (workspaceToCode) where

import Blockly.Block
import Blockly.Workspace hiding (workspaceToCode)
import Blocks.Parser
import qualified Blocks.Printer as PR
import Control.Monad
import Control.Monad.State.Lazy (get, put)
import qualified Control.Monad.State.Lazy as S
import Data.JSString.Text
import qualified Data.Map as M
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Prelude as P
import Prelude hiding ((<>), show)

pack = textToJSString

unpack = textFromJSString

show :: Show a => a -> T.Text
show = T.pack . P.show

errc :: T.Text -> Block -> SaveErr Expr
errc msg block = SE Comment $ Just $ Error msg block

type Code = T.Text

class Pretty a where
  pretty :: a -> PR.Printer

-- instance Pretty Product where
--  pretty (Product s tps) = s <> " " <> T.concat (map pretty tps)

instance Pretty Type where
  pretty (Type s) = PR.write_ s
  pretty (Sum typeName []) = PR.write_ $ "data " <> typeName -- Empty data declaration
  pretty (Sum typeName (tp : tps)) = do
    PR.write_ $ "data " <> typeName <> " ="
    c <- PR.getCol
    PR.write_ " "
    pretty tp
    mapM_ (\t -> PR.setCol (c -1) >> PR.writeLine "" >> PR.write "|" >> pretty t) tps
  pretty (Product s tps) = do
    PR.write_ s
    when (length tps > 0) $ do
      PR.write_ "("
      PR.intercalation "," tps pretty
      PR.write_ ")"
    PR.write_ " "
  pretty (ListType t) = do
    PR.write_ "["
    pretty t
    PR.write_ "]"

instance Pretty Expr where
  pretty (LiteralS s) = PR.write_ s
  pretty (LiteralN d) =
    PR.write_ $
      if d == fromInteger (truncate d)
        then show $ truncate d
        else show d
  pretty (LocalVar name) = PR.write_ $ name
  pretty (CallFunc name vars_) = do
    PR.write_ name
    case vars_ of
      [] -> return ()
      _ -> do
        PR.write_ "("
        PR.intercalation "," vars_ pretty
        PR.write_ ")"
  pretty (CallConstr name vars_) = do
    PR.write name
    case vars_ of
      [] -> return ()
      _ -> do
        PR.write_ "("
        PR.intercalation "," vars_ pretty
        PR.write_ ")"
  pretty (CallFuncInfix name left right) = do
    shouldParenth left
    PR.makeSpace
    PR.write name -- SPACES between?
    PR.makeSpace
    shouldParenth right
    where
      getPrec (CallFuncInfix name _ _) = infixP name
      getPrec _ = 9
      cur = infixP name
      shouldParenth expr =
        let prec = getPrec expr
         in if prec < cur then parenthesize expr else pretty expr
      parenthesize expr = do
        PR.write_ "("
        pretty expr
        PR.write_ ")"
  pretty (FuncDef name vars expr) = do
    let varCode =
          if not $ null vars
            then "(" <> T.intercalate "," vars <> ")"
            else ""
    PR.write_ name
    if null vars then return () else PR.write_ varCode
    PR.write_ " = "
    pretty expr
  pretty (If cond th el) = do
    PR.push
    PR.write "if"
    pretty cond
    PR.reset
    PR.write "then"
    pretty th
    PR.reset
    PR.write "else"
    pretty el
    PR.pop
  pretty (Case expr rows) = do
    col <- PR.getCol
    PR.write "case"
    PR.makeSpace
    pretty expr
    PR.makeSpace
    PR.write "of"
    mapM_
      ( \(con, vars, expr) -> do
          PR.setCol (col + 4)
          PR.writeLine ""
          PR.write con
          PR.makeSpace
          when (length vars > 0) $ do
            PR.write_ "("
            PR.write_ $ T.intercalate "," vars
            PR.write_ ")"
          PR.write "->"
          pretty expr
      )
      rows
    PR.pop
  pretty (UserType tp) = pretty tp
  pretty (Tuple exprs) = do
    PR.write_ "("
    PR.intercalation "," exprs pretty
    PR.write_ ")"
  pretty (ListCreate exprs) = do
    PR.write_ "["
    PR.intercalation "," exprs pretty
    PR.write_ "]"
  pretty (ListSpec left right) = do
    PR.write_ "["
    pretty left
    PR.write_ " .. "
    pretty right
    PR.write_ "]"
  pretty (ListSpecStep left next right) = do
    PR.write_ "["
    pretty left
    PR.write_ ", "
    pretty next
    PR.write_ " .. "
    pretty right
    PR.write_ "]"
  pretty (ListComp act vars_ guards) = do
    PR.write_ "["
    pretty act
    PR.write_ " | "
    PR.intercalation ", " vars_ (\(var, expr) -> PR.write_ var >> PR.write_ " <- " >> pretty expr)
    when (length guards > 0) $ do
      PR.write_ ","
      PR.makeSpace
      PR.intercalation ", " guards pretty
    PR.write_ "]"
  pretty Comment = PR.write_ ""

infixP "-" = 6
infixP "+" = 6
infixP "*" = 7
infixP "/" = 7
infixP "^" = 8
infixP "&" = 8
infixP "<>" = 8
infixP _ = 9

workspaceToCode :: Workspace -> IO (Code, [Error])
workspaceToCode workspace = do
  topBlocks <- getTopBlocksTrue workspace >>= return . filter (not . isDisabled)
  let exprs = map blockToCode topBlocks
  let errors =
        map (\(SE code (Just e)) -> e) $
          filter (\c -> case c of SE code Nothing -> False; _ -> True) exprs
  let code = T.intercalate "\n\n" $ map (\(SE expr _) -> PR.run $ pretty expr) exprs
  return (code, errors)
  where
    blockToCode :: Block -> SaveErr Expr
    blockToCode block = do
      let blockType = getBlockType block
      case M.lookup blockType blockCodeMap of
        Just func ->
          let (SE code err) = func block
           in SE code err
        Nothing -> errc "No such block in CodeGen" block
