{-# LANGUAGE GADTs #-}

-----------------------------------------------------------------------------

-- Copyright 2018, 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)

--

-- Services using XML notation

--

-----------------------------------------------------------------------------



module Ideas.Encoding.DecoderXML

   ( XMLDecoder, xmlDecoder

   ) where



import Control.Monad

import Data.Char

import Ideas.Common.Library

import Ideas.Common.Traversal.Navigator

import Ideas.Encoding.Encoder

import Ideas.Encoding.OpenMathSupport

import Ideas.Encoding.Request

import Ideas.Service.State

import Ideas.Service.Types

import Ideas.Text.MathML

import Ideas.Text.OpenMath.Object

import Ideas.Text.XML



type XMLDecoder a = Decoder a XML



xmlDecoder :: TypedDecoder a XML

xmlDecoder tp =

   case tp of

      Tag s (Const String) ->

         decodeChild s decodeData

       `mplus`

         decodeAttribute s

      Tag s t

         | s == "answer" ->

              decodeChild "answer" (xmlDecoder t)

         | s == "Difficulty" -> do

              g <- equalM tDifficulty tp

              a <- decoderFor (findAttribute "difficulty")

              maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)

         | otherwise ->

              decodeChild s (xmlDecoder t)

      Iso p t  -> from p <$> xmlDecoder t

      List t -> do

         x  <- xmlDecoder t

         xs <- xmlDecoder (List t)

         return (x:xs)

       `mplus`

         return []

      Pair t1 t2 -> do

         x <- xmlDecoder t1

         y <- xmlDecoder t2

         return (x, y)

      t1 :|: t2 ->

         (Left  <$> xmlDecoder t1) `mplus`

         (Right <$> xmlDecoder t2)

      Unit -> return ()

      Const ctp ->

         case ctp of

            State       -> decodeState

            Context     -> decodeContext

            Rule        -> decodeRule

            Environment -> decodeArgEnvironment

            Term        -> decoderFor (fromXML >=> fromOMOBJ)

            Location    -> decodeLocation

            StratCfg    -> decodeConfiguration

            QCGen       -> getQCGen

            Script      -> getScript

            Exercise    -> getExercise

            Id          -> -- improve!

                           decodeChild "location" $

                              makeDecoder (newId . getData)

            MathML      -> decodeMathML

            String      -> decodeData

            _ -> fail $ "No support for argument type in XML: " ++ show tp

      _ -> fail $ "No support for argument type in XML: " ++ show tp



-- <ruleid>

decodeRule :: XMLDecoder a (Rule (Context a))

decodeRule = decodeChild "ruleid" $ do

   ex <- getExercise

   decoderFor (getRule ex . newId . getData)



-- <location>

decodeLocation :: XMLDecoder a Location

decodeLocation = decodeChild "location" $

   makeDecoder (toLocation . read . getData)



-- <state>

decodeState :: XMLDecoder a (State a)

decodeState = decodeChild "state"  $ do

   ex  <- getExercise

   ps  <- decodePaths

   ctx <- decodeContext

   let prf = replayPaths ps (strategy ex) ctx

   return (makeState ex prf ctx)



-- <prefix>

decodePaths :: XMLDecoder a [Path]

decodePaths = do

   prefixText <- makeDecoder (maybe "" getData . findChild "prefix")

   if all isSpace prefixText

      then return [emptyPath]

      else if prefixText ~= "no prefix"

      then return []

      else readPaths prefixText

 where

   a ~= b = g a == g b

   g = map toLower . filter (not . isSpace)



decodeContext :: XMLDecoder a (Context a)

decodeContext = do

   ex   <- getExercise

   expr <- decodeExpression

   env  <- decodeEnvironment

   let ctx    = setEnvironment env (inContext ex expr)

       locRef = makeRef "location"

   case locRef ? env of

      Just s  -> maybe (fail "invalid location") return $ do

         loc <- toLocation <$> readM s

         navigateTo loc (deleteRef locRef ctx)

      Nothing ->

         return ctx



decodeExpression :: XMLDecoder a a

decodeExpression = withOpenMath f

 where

   f True  = decodeOMOBJ

   f False = decodeChild "expr" $ do

      ex <- getExercise

      decoderFor $ either fail return . parser ex . getData



decodeOMOBJ :: XMLDecoder a a

decodeOMOBJ = decodeChild "OMOBJ" $ decoderFor $ \xml -> do

   ex    <- getExercise

   omobj <- fromXML xml

   case fromOpenMath ex omobj of

      Just a  -> return a

      Nothing -> fail "Invalid OpenMath object for this exercise"



decodeMathML :: XMLDecoder a MathML

decodeMathML = decodeFirstChild "math" $ decoderFor fromXML



decodeEnvironment :: XMLDecoder a Environment

decodeEnvironment =

   decodeChild "context" (decoderFor $ foldM add mempty . children)

   <|> return mempty

 where

   add env item = do

      unless (name item == "item") $

         fail $ "expecting item tag, found " ++ name item

      n   <- findAttribute "name"  item

      req <- getRequest

      case findChild "OMOBJ" item of

         -- OpenMath object found inside item tag

         Just this | useOpenMath req ->

            case xml2omobj this >>= fromOMOBJ of

               Left err -> fail err

               Right term ->

                  return $ insertRef (makeRef n) (term :: Term) env

         -- Simple value in attribute

         _ -> do

            value <- findAttribute "value" item

            return $ insertRef (makeRef n) value env



-- <configuration>

decodeConfiguration :: XMLDecoder a StrategyCfg

decodeConfiguration = decodeChild "configuration" $

   decoderFor $ \xml ->

      mconcat <$> mapM decodeAction (children xml)

 where

   decodeAction item = do

      guard (null (children item))

      action <- readM (name item)

      cfgloc <- findAttribute "name" item

      return (action `byName` newId cfgloc)



decodeArgEnvironment :: XMLDecoder a Environment

decodeArgEnvironment = decoderFor $

   fmap makeEnvironment . mapM (decodeBinding //) . findChildren "argument"



decodeBinding :: XMLDecoder a Binding

decodeBinding = decoderFor $ \xml -> do

   a   <- findAttribute "description" xml

   req <- getRequest

   case findChild "OMOBJ" xml of

      -- OpenMath object found inside tag

      Just this | useOpenMath req ->

         case xml2omobj this >>= fromOMOBJ of

            Left err   -> fail err

            Right term -> return (termBinding a term)

      -- Simple value

      _ -> return (makeBinding (makeRef a) (getData xml))

 where

   termBinding :: String -> Term -> Binding

   termBinding = makeBinding . makeRef



decodeData :: XMLDecoder a String

decodeData = split $ \xml ->

   case content xml of

      Left s:rest -> Right (s, xml {content = rest})

      _           -> Left "Could not find data"



decodeChild :: String -> XMLDecoder a b -> XMLDecoder a b

decodeChild s m = split f >>= (m //)

 where

   p     = either (const False) ((==s) . name)

   f xml = case break p (content xml) of

              (xs, Right y:ys) -> Right (y, xml { content = xs ++ ys })

              _ -> Left $ "Could not find child " ++ s



decodeFirstChild :: String -> XMLDecoder a b -> XMLDecoder a b

decodeFirstChild s m = split f >>= (m //)

 where

   f xml = case content xml of

              Right y:ys | name y == s -> Right (y, xml { content = ys })

              _ -> Left $ "Could not find first child " ++ s



decodeAttribute :: String -> XMLDecoder a String

decodeAttribute s = split $ \xml ->

   case break p (attributes xml) of

      (xs, (_ := val):ys) -> Right (val, xml {attributes = xs ++ ys })

      _ -> Left $ "Could not find attribute " ++ s

 where

   p (n := _) = n == s