-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

-- Allow us to use string literals for Text
{-# LANGUAGE OverloadedStrings #-}

module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where

import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (.), ($), show, pure, (<>), reverse, fst, snd, readFile, filter, length, (&&), (==), (/=), fmap, notElem, elem, not, zip, init, last, null, String, (*>), (<$>), traverse, (<$))

import Graphics.Implicit.ExtOpenScad.Definitions (
                                                  Statement(Include, (:=), If, NewModule, ModuleCall, DoNothing),
                                                  Pattern(Name),
                                                  Expr(LitE),
                                                  OVal(OBool, OUModule, ONModule, OVargsModule),
                                                  VarLookup(VarLookup),
                                                  StatementI(StatementI),
                                                  Symbol(Symbol),
                                                  Message(Message),
                                                  ScadOpts(importsAllowed),
                                                  StateC,
                                                  CompState(CompState, sourceDir),
                                                  varUnion, runImplicitCadM
                                                 )

import Graphics.Implicit.ExtOpenScad.Util.OVal (getErrors)
import Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, defaultTo, argMap)
import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, warnC, modifyVarLookup, scadOptions, lookupVar, pushVals, getRelPath, withPathShiftedBy, getVals, putVals, addMessage, getVarLookup)
import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat)
import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)

import Data.List (intercalate)

import Data.Map (union, fromList, toList)

import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes)

import Control.Monad (when, unless)

import Control.Monad.State (gets, liftIO)

import Data.Foldable (traverse_, for_)

import Data.Traversable (for)

import Data.Text.Lazy (unpack, pack)

import System.Directory (doesFileExist)

import System.FilePath (takeDirectory)
import Control.Monad.Reader.Class (MonadReader(ask))

-- | Run statements out of the OpenScad file.
runStatementI :: StatementI -> StateC ()
runStatementI (StatementI sourcePos (pat := expr)) = do
    -- Interpret variable assignment
    val <- evalExpr sourcePos expr
    let posMatch = matchPat pat val
    case (getErrors val, posMatch) of
        (Just err,  _ ) -> errorC sourcePos err
        (_, Just (VarLookup match)) ->
          for_ (toList match) $ \(Symbol varName, _) -> do
            maybeVar <- lookupVar (Symbol varName)
            when (isJust maybeVar)
              (warnC sourcePos $ "redefining already defined object: " <> varName)
            modifyVarLookup $ varUnion (VarLookup match)
        (_,   Nothing ) -> errorC sourcePos "pattern match failed in assignment"

runStatementI (StatementI sourcePos (If expr a b)) = do
    -- Interpret an if conditional statement.
    val <- evalExpr sourcePos expr
    case (getErrors val, val) of
        (Just err,  _  )  -> errorC sourcePos ("In conditional expression of if statement: " <> err)
        (_, OBool True )  -> runSuite a
        (_, OBool False)  -> runSuite b
        _                 -> pure ()

runStatementI (StatementI sourcePos (NewModule name argTemplate suite)) = do
    -- Interpret a module declaration.
    argTemplate' <- for argTemplate $ \(argName, defexpr) -> do
        defval <- traverse (evalExpr sourcePos) defexpr
        pure (argName, defval)
    argNames <-  for argTemplate $ \(argName, defexpr) -> do
      defval <- traverse (evalExpr sourcePos) defexpr
      let
        hasDefault = isJust defval
      pure (argName, hasDefault)
    runStatementI . StatementI sourcePos $ (Name name :=) $ LitE $ OUModule name (Just argNames) $ \(VarLookup varlookup) -> do
        newNameVals <- for argTemplate' $ \(argName, maybeDef) -> do
            val <- case maybeDef of
                Just def -> argument argName `defaultTo` def
                Nothing  -> argument argName
            pure (argName, val)
        let
            varlookup' = union (fromList newNameVals) varlookup
        pure $ runSuiteCapture (VarLookup varlookup') suite

runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) = do
        -- Interpret a call to a module.
        maybeMod <- lookupVar (Symbol name)
        varlookup <- getVarLookup
        newVals  <- case maybeMod of
            Just (OUModule _ args mod') -> do
              optionsMatch <- checkOptions args True
              unless optionsMatch (errorC sourcePos $ "Options check failed when executing user-defined module " <> name <> ".")
              evaluatedArgs <- evalArgs argsExpr
              varLookup <- getVarLookup
              -- Evaluate the suite.
              --suiteResults <- runSuiteCapture varlookup suite
              when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")
              -- Run the module.
              let
                argsMapped = argMap evaluatedArgs $ mod' varLookup
              for_ (pack <$> snd argsMapped) $ errorC sourcePos
              fromMaybe (pure []) (fst argsMapped)
            Just (ONModule _ implementation forms) -> do
              possibleInstances <- selectInstances forms
              let
                suiteInfo = case possibleInstances of
                  [(_, suiteInfoFound)]   -> suiteInfoFound
                  []                      -> Nothing
                  ((_, suiteInfoFound):_) -> suiteInfoFound
              when (null possibleInstances) (do
                                                errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> pack (show (ONModule (Symbol name) implementation forms))
                                                traverse_ ((`checkOptions` True) . Just . fst) forms
                                            )
              -- Ignore this for now, because all instances we define have the same suite requirements.
              {-
              when (length possibleInstances > 1) (do
                                                      errorC sourcePos $ "too many instances of " <> name <> " have been found that match given parameters."
                                                      traverse_ (`checkOptions` True) $ fmap (Just . fst) possibleInstances)
              -}
              -- Evaluate all of the arguments.
              evaluatedArgs <- evalArgs argsExpr
              -- Evaluate the suite.
              vals <- runSuiteCapture varlookup suite
              suiteResults <- case suiteInfo of
                              Just True -> do
                                when (null vals) (errorC sourcePos "Suite required, but none provided.")
                                pure vals
                              Just False -> pure vals
                              _ -> do
                                when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")
                                pure []
              -- Run the module.
              let
                argsMapped = argMap evaluatedArgs $ implementation sourcePos suiteResults
              for_ (pack <$> snd argsMapped) $ errorC sourcePos
              fromMaybe (pure []) (fst argsMapped)
            Just (OVargsModule modname mod') -> do
              -- Evaluate all of the arguments.
              evaluatedArgs <- evalArgs argsExpr
              -- Run the module, which evaluates it's own suite.
              _ <- mod' modname sourcePos evaluatedArgs suite runSuite -- no values are pureed
              pure []
            Just foo -> do
                    case getErrors foo of
                        Just err -> errorC sourcePos err
                        Nothing  -> errorC sourcePos $ "Object " <> name <> " is not a module!"
                    pure []
            _ -> do
                errorC sourcePos $ "Module " <> name <> " not in scope."
                pure []
        pushVals newVals
          where
            selectInstances :: [([(Symbol, Bool)], Maybe Bool)] -> StateC [([(Symbol, Bool)], Maybe Bool)]
            selectInstances instances = do
              validInstances <- for instances
                    ( \(args, suiteInfo) -> do
                        res <- checkOptions (Just args) False
                        pure $ if res then Just (args, suiteInfo) else Nothing
                    )
              pure $ catMaybes validInstances
            checkOptions :: Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
            checkOptions args makeWarnings = do
              let
                -- Find what arguments are satisfied by a default value, were given in a named parameter, or were given.. and count them.
                valDefaulted ,valNotDefaulted, valNamed, mappedDefaulted, mappedNotDefaulted, notMappedNotDefaultable :: [Symbol]
                -- function definition has a default value.
                valDefaulted  = fmap fst $ filter snd $ fromMaybe [] args
                -- function definition has no default value.
                valNotDefaulted = fmap fst $ filter (not.snd) $ fromMaybe [] args
                -- function call has a named expression bound to this symbol.
                valNamed = namedParameters argsExpr
                -- function call has a named expression, function definition has an argument with this name, AND there is a default value for this argument.
                mappedDefaulted = filter (`elem` valNamed) valDefaulted
                -- function call has a named expression, function definition has an argument with this name, AND there is NOT a default value for this argument.
                mappedNotDefaulted = filter (`elem` valNamed) valNotDefaulted
                -- arguments we need to find a mapping for, from the unnamed expressions.
                notMappedNotDefaultable = filter (`notElem` mappedNotDefaulted) valNotDefaulted
                -- expressions without a name.
                valUnnamed :: [Expr]
                valUnnamed = unnamedParameters argsExpr
                mapFromUnnamed :: [(Symbol, Expr)]
                mapFromUnnamed = zip notMappedNotDefaultable valUnnamed
                missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> fmap fst mapFromUnnamed)) valNotDefaulted
                extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr
                parameterReport =  "Passed " <>
                  (if null valNamed && null valUnnamed then "no parameters" else "" ) <>
                  (if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <>
                  (if not (null valNamed) && not (null valUnnamed) then ", and " else "") <>
                  (if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <>
                  (if not (null missingNotDefaultable) then
                      (if length missingNotDefaultable == 1
                       then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable)
                       else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> intercalate ", " (showSymbol <$> init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "."
                      ) else "") <>
                  (if not (null extraUnnamed) then
                      (if length extraUnnamed == 1
                       then " Had one extra parameter: " <> showSymbol (last extraUnnamed)
                       else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> intercalate ", " (showSymbol <$> init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "."
                      ) else "")
                showSymbol :: Symbol -> String
                showSymbol (Symbol sym) = show sym
                  {-
              when (makeWarnings)
                (errorC sourcePos $ foldMap show argsExpr)
              when (makeWarnings)
                (errorC sourcePos $ "valNamed: " <> show (length valNamed))
              when (makeWarnings)
                (errorC sourcePos $ "mappedDefaulted: " <> show (length mappedDefaulted))
              when (makeWarnings)
                (errorC sourcePos $ "mappedNotDefaulted: " <> show (length mappedNotDefaulted))
              when (makeWarnings)
                (errorC sourcePos $ "notMappedNotDefaultable: " <> show (length notMappedNotDefaultable))
              when (makeWarnings)
                (errorC sourcePos $ "mapFromUnnamed: " <> show (length mapFromUnnamed))
              when (makeWarnings)
                (errorC sourcePos $ "missingNotDefaultable: " <> show (length missingNotDefaultable))
                 -}
              when (not (null missingNotDefaultable) && makeWarnings)
                (errorC sourcePos $ "Insufficient parameters. " <> pack parameterReport)
              when (not (null extraUnnamed) && isJust args && makeWarnings)
                (errorC sourcePos $ "Too many parameters: " <> pack (show $ length extraUnnamed) <> " extra. " <> pack parameterReport)
              pure $ null missingNotDefaultable && null extraUnnamed
            namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
            namedParameters = mapMaybe fst
            unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]
            unnamedParameters = mapMaybe (
              \(argName, expr) ->
                case argName of
                  Just _  -> Nothing
                  Nothing -> Just expr
              )
            evalArgs :: [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
            evalArgs args = for args $ \(posName, expr) -> do
              val <- evalExpr sourcePos expr
              pure (posName, val)

runStatementI (StatementI sourcePos (Include name injectVals)) = do
    -- Interpret an include or use statement.
    opts <- scadOptions
    if importsAllowed opts
      then do
      name' <- getRelPath (unpack name)
      hasFile <- liftIO $ doesFileExist name'
      if not hasFile
        then warnC sourcePos $ "Not importing " <> name <> ": File not found."
        else do
          content <- liftIO $ readFile name'
          case parseProgram name' content of
            Left e -> errorC sourcePos $ "Error parsing " <> name <> ":" <> pack (show e)
            Right sts -> withPathShiftedBy (takeDirectory $ unpack name) $ do
                vals <- getVals
                putVals []
                runSuite sts
                if injectVals
                  then do
                    vals' <- getVals
                    putVals $ vals' <> vals
                  else putVals vals
      else warnC sourcePos $ "Not importing " <> name <> ": File import disabled."

runStatementI (StatementI _ DoNothing) = pure ()

runSuite :: [StatementI] -> StateC ()
runSuite = traverse_ runStatementI

runSuiteCapture :: VarLookup -> [StatementI] -> StateC [OVal]
runSuiteCapture varlookup suite = do
  opts <- ask
  (res, messages, _) <- do
    s <- gets mkSubState
    liftIO . runImplicitCadM opts s $ runSuite suite *> getVals
  reverse res <$ traverse moveMessage messages
    where
      mkSubState s = CompState varlookup [] (sourceDir s)
      moveMessage (Message mtype mpos text) = addMessage mtype mpos text
