-----------------------------------------------------------------------------
-- Copyright 2014, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Analysis of a feedbackscript
--
-----------------------------------------------------------------------------
--  $Id: Analysis.hs 6540 2014-05-14 15:13:00Z bastiaan $

module Ideas.Service.FeedbackScript.Analysis
   ( -- Analysis functions
     makeScriptFor, parseAndAnalyzeScript, analyzeScript
     -- Message type
   , Message(..)
   ) where

import Data.Either
import Data.List
import Ideas.Common.Library
import Ideas.Common.Utils (Some(..))
import Ideas.Common.Utils.Uniplate
import Ideas.Service.DomainReasoner
import Ideas.Service.FeedbackScript.Parser
import Ideas.Service.FeedbackScript.Run
import Ideas.Service.FeedbackScript.Syntax

makeScriptFor :: IsId a => DomainReasoner -> a -> IO ()
makeScriptFor dr exId = do
   Some ex <- findExercise dr (newId exId)
   let (brs, nrs) = partition isBuggy (ruleset ex)
   print $ makeScript $
      Supports [getId ex] :
      [ feedbackDecl s mempty | s <- feedbackIds ] ++
      [ textForIdDecl r (makeText (description r)) | r <- nrs ] ++
      [ textForIdDecl r (makeText (description r)) | r <- brs ]

parseAndAnalyzeScript :: DomainReasoner -> FilePath -> IO ()
parseAndAnalyzeScript dr file = do
   putStrLn $ "Parsing " ++ show file
   script <- parseScript file
   let exs = [ maybe unknown Right (findExercise dr a)
              | Supports as <- scriptDecls script
              , a <- as
              , let unknown = Left (UnknownExercise a)
              ]
   let ms = lefts exs ++ analyzeScript (rights exs) script
   putStrLn $ unlines $ map show ms
   putStrLn $ "(errors: " ++ show (length ms) ++ ")"

analyzeScript :: [Some Exercise] -> Script -> [Message]
analyzeScript exs script =
   map FeedbackUndefined (filter (`notElem` fbids) feedbackIds) ++
   map UnknownFeedback   (filter (`notElem`feedbackIds ) fbids) ++
   [ NoTextForRule (getId r) (getId ex)
   | Some ex <- exs, r <- ruleset ex, noTextFor (getId r)
   ] ++
   [ UnknownAttribute a | a <- textRefs
   , a `notElem` feedbackIds ++ attributeIds ++ strids ] ++
   [ UnknownCondAttr a | a <- condRefs, a `notElem` conditionIds ]
 where
   decls = scriptDecls script
   fbids = [ a | Simple  Feedback as _ <- decls, a <- as ] ++
           [ a | Guarded Feedback as _ <- decls, a <- as ]
   txids = [ a | Simple  TextForId as _ <- decls, a <- as ] ++
           [ a | Guarded TextForId as _ <- decls, a <- as ]
   strids = [ a | Simple  StringDecl as _ <- decls, a <- as ] ++
            [ a | Guarded StringDecl as _ <- decls, a <- as ]
   namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ]
   noTextFor a = null [ () | n <- namespaces, b <- txids, n#b == a ]

   texts = [ t | Simple  _ _ t <- decls ] ++
           [ t | Guarded _ _ xs <- decls, (_, t) <- xs ]
   textRefs = [ a | t <- texts, TextRef a <- universe t ]

   conditions  = [ c | Guarded _ _ xs <- decls , (c, _) <- xs ]
   condRefs = [ a | c <- conditions, CondRef a <- universe c ]

data Message = UnknownExercise   Id
             | UnknownFeedback   Id
             | FeedbackUndefined Id
             | NoTextForRule Id Id
             | UnknownAttribute Id
             | UnknownCondAttr  Id

instance Show Message where
   show message =
      case message of
         UnknownExercise a   -> "Unknown exercise id " ++ show a
         UnknownFeedback a   -> "Unknown feedback category " ++ show a
         FeedbackUndefined a -> "Feedback category " ++ show a ++ " is not defined"
         NoTextForRule a b   -> "No text for rule " ++ show a ++ " of exercise " ++ show b
         UnknownAttribute a  -> "Unknown attribute @" ++ show a ++ " in text"
         UnknownCondAttr a   -> "Unknown attribute @" ++ show a ++ " in condition"