-----------------------------------------------------------------------------
-- Copyright 2019, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Run a feedbackscript
--
-----------------------------------------------------------------------------

module Ideas.Service.FeedbackScript.Run
   ( Script
   , Environment(..), newEnvironment
   , feedbackDiagnosis, feedbackHint, feedbackHints
   , ruleToString, feedbackIds, attributeIds, conditionIds
   , eval
   ) where

import Data.List
import Data.Maybe
import Ideas.Common.Library hiding (ready, Environment)
import Ideas.Service.BasicServices
import Ideas.Service.Diagnose
import Ideas.Service.FeedbackScript.Syntax
import Ideas.Service.State

data Environment a = Env
   { oldReady   :: Bool
   , expected   :: Maybe (Rule (Context a))
   , recognized :: Maybe (Rule (Context a))
   , motivation :: Maybe (Rule (Context a))
   , diffPair   :: Maybe (String, String)
   , before     :: Maybe Term
   , after      :: Maybe Term
   , afterText  :: Maybe String
   }

newEnvironment :: State a -> Maybe (Rule (Context a)) -> Environment a
newEnvironment st motivationRule = newEnvironmentFor st motivationRule next
  where
    next = either (const Nothing) Just (onefirst st)

newEnvironmentFor :: State a -> Maybe (Rule (Context a)) -> Maybe ((Rule (Context a), b, c), State a) -> Environment a
newEnvironmentFor st motivationRule next = Env
  { oldReady   = finished st
  , expected   = fmap (\((x,_,_),_) -> x) next
  , motivation = motivationRule
  , recognized = Nothing
  , diffPair   = Nothing
  , before     = f st
  , after      = fmap snd next >>= f
  , afterText  = fmap snd next >>= g
  }
 where
  f s  = fmap (`build` stateTerm s) (hasTermView (exercise s))
  g s  = return $ prettyPrinter (exercise s) (stateTerm s)

toText :: Environment a -> Script -> Text -> Maybe Text
toText env script = eval env script . Right

ruleToString :: Environment a -> Script -> Rule b -> String
ruleToString env script r =
   let f = eval env script . Left . getId
   in maybe (showId r) show (f r)

eval :: Environment a -> Script -> Either Id Text -> Maybe Text
eval env script = either (return . findIdRef) evalText
 where
   evalText :: Text -> Maybe Text
   evalText = fmap mconcat . mapM unref . textItems
    where
      unref (TextRef a)
         | a == expectedId   = fmap (findIdRef . getId) (expected env)
         | a == recognizedId = fmap (findIdRef . getId) (recognized env)
         | a == diffbeforeId = fmap (TextString . fst) (diffPair env)
         | a == diffafterId  = fmap (TextString . snd) (diffPair env)
         | a == beforeId     = fmap TextTerm (before env)
         | a == afterId      = fmap TextTerm (after env)
         | a == afterTextId  = fmap TextString (afterText env)
         | a == motivationId = fmap (findIdRef . getId) (motivation env)
         | otherwise         = findRef (==a)
      unref t = Just t

   evalBool :: Condition -> Bool
   evalBool (RecognizedIs a) = maybe False (eqId a . getId) (recognized env)
   evalBool (MotivationIs a) = maybe False (eqId a . getId) (motivation env)
   evalBool (CondNot c)      = not (evalBool c)
   evalBool (CondConst b)    = b
   evalBool (CondRef a)
      | a == oldreadyId        = oldReady env
      | a == hasexpectedId     = isJust (expected env)
      | a == hasrecognizedId   = isJust (recognized env)
      | a == hasmotivationId   = isJust (motivation env)
      | a == recognizedbuggyId = maybe False isBuggy (recognized env)
      | otherwise              = False

   namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ]

   -- equality with namespaces
   eqId :: Id -> Id -> Bool
   eqId a b = any (\n -> n#a == b) namespaces

   findIdRef :: Id -> Text
   findIdRef x = fromMaybe (TextString (showId x)) (findRef (`eqId` x))

   findRef :: (Id -> Bool) -> Maybe Text
   findRef p = listToMaybe $ catMaybes
      [ evalText t
      | (as, c, t) <- allDecls
      , any p as && evalBool c
      ]

   allDecls =
      let f (Simple _ as t)   = [ (as, CondConst True, t) ]
          f (Guarded _ as xs) = [ (as, c, t) | (c, t) <- xs ]
          f _ = []
      in concatMap f (scriptDecls script)

feedbackDiagnosis :: Diagnosis a -> Environment a -> Script -> Text
feedbackDiagnosis diagnosis env =
   case diagnosis of
      SyntaxError s    -> const (makeText s)
      Buggy _ r        -> makeWrong "buggy"     env {recognized = Just r}
      NotEquivalent s  -> makeNotEq s "noteq"   env
      Expected _ _ r   -> makeOk    "ok"        env {recognized = Just r}
      WrongRule _ _ mr -> makeWrong "wrongrule" env {recognized = mr}
      Similar _ _      -> makeOk    "same"      env
      Detour _ _ _ r   -> makeOk    "detour"    env {recognized = Just r}
      Correct _ _      -> makeOk    "correct"   env
      Unknown _ _      -> makeOk    "unknown"   env
 where
   makeOk    = makeDefault "Well done!"
   makeWrong = makeDefault "This is incorrect."
   makeNotEq s = if null s then makeWrong else makeDefault s
   makeDefault dt s e = fromMaybe (TextString dt) . make (newId s) e

feedbackHint :: Id -> Environment a -> Script -> Text
feedbackHint feedbackId env script =
   fromMaybe (defaultHint env script) $ make feedbackId env script

feedbackHints :: Id -> [((Rule (Context a), b, c), State a)] -> State a -> Maybe (Rule (Context a)) -> Script -> [Text]
feedbackHints feedbackId nexts state motivationRule script =
   map (\env -> fromMaybe (defaultHint env script) $
     make feedbackId env script) envs
  where
    envs = map (newEnvironmentFor state motivationRule . Just) nexts

defaultHint :: Environment a -> Script -> Text
defaultHint env script = makeText $
   case expected env of
      Just r  -> ruleToString env script r
      Nothing -> "Sorry, no hint available."

make :: Id -> Environment a -> Script -> Maybe Text
make feedbackId env script = toText env script (TextRef feedbackId)

feedbackIds :: [Id]
feedbackIds = map newId
   ["same", "noteq", "correct", "unknown", "ok", "buggy", "detour", "wrongrule", "hint", "step", "label"]

attributeIds :: [Id]
attributeIds =
   [expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId, motivationId]

conditionIds :: [Id]
conditionIds = [oldreadyId, hasexpectedId, hasrecognizedId, hasmotivationId, recognizedbuggyId]

expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId, motivationId :: Id
expectedId   = newId "expected"
recognizedId = newId "recognized"
diffbeforeId = newId "diffbefore"
diffafterId  = newId "diffafter"
beforeId     = newId "before"
afterId      = newId "after"
afterTextId  = newId "aftertext"
motivationId = newId "motivation"

oldreadyId, hasexpectedId, hasrecognizedId, hasmotivationId, recognizedbuggyId :: Id
oldreadyId        = newId "oldready"
hasexpectedId     = newId "hasexpected"
hasrecognizedId   = newId "hasrecognized"
hasmotivationId   = newId "hasmotivation"
recognizedbuggyId = newId "recognizedbuggy"