Types.hs

-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me 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)
--
-----------------------------------------------------------------------------

module Service.Types where

import Ideas.Text.XML (ToXML, toXML, Attribute((:=)) )
import Ideas.Common.Library           hiding (recognize)
import Ideas.Service.Types            hiding (tUserId)
import Recognize.Data.Solution
import Util.String
import Bayes.StudentReport (StudentReport)
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import qualified Ideas.Text.XML as XML
import Recognize.Data.Entry (Entry, diagnoses)
import Recognize.Data.DiagnoseResult (evidence)
import Database.Data ( StudentID )

tSolution :: Type a Solution
tSolution = Tag "solution" $ Iso (f <-> g) tp
 where
   tp = tTuple4 tUserId tGroupId tLanguage (tList tInput)
   f (userId, groupId, lan, inps) = Solution userId groupId lan inps
   g (Solution userId groupId lan inps) = (userId, groupId, lan, inps)

tUserId :: Type a UserId
tUserId = tMaybe $ tAttr "userid"

tGroupId :: Type a GroupId
tGroupId = tMaybe $ tAttr "groupid"

tSource :: Type a Source
tSource = tMaybe $ tAttr "source"

tLanguage :: Type a (Maybe Language)
tLanguage = tMaybe $ Iso (f <-> g) $ tAttr "language"
 where
   f = read . strToUpper
   g = strToLower . show

tInput :: Type a Input
tInput = Tag "input" $ Iso (f <-> g) tp
 where
   tp = tPair tInputId (tList (tMathML :|: tString))
   f (inputId, xs) = Input inputId xs
   g (Input inputId xs) = (inputId, xs)

tInputId :: Type a Id
tInputId = Iso (newId.strToLower <-> show) $ tAttr "id"

tAttr :: String -> Type a String
tAttr s = Tag s tString

tStudentReport :: Type a StudentReport
tStudentReport = Tag "StudentReport" $ Iso (f <-> toXML) tXML
 where
   f = error "student report from xml not implemented" --either error id . Report.fromXML

tStudentReports :: Type a [StudentReport]
tStudentReports = Iso (f <-> g) tXML
   where
   f = error "student reports from xml not implemented"
   g reports = XML.makeXML "users" $ mconcat $ map (XML.builder . toXML) reports


-- | DiagnosisReply is a datatype that purely exists as an intermediate between
-- the date types we gather and the XML we show to the user.
data DiagnosisReply a = DiagnosisReply 
   { exercise :: Exercise a
   , solution :: Solution
   , entry :: Entry
   , source :: Maybe String
   , examinator :: Maybe String
   }

instance ToXML (DiagnosisReply a) where
   toXML diag = XML.makeXML "diagnosis" $ mconcat 
      [ "source"     XML..=. fromMaybe "" (source diag)
      , "user"       XML..=. fromMaybe "" (userId $ solution diag)
      , "exercise"   XML..=. showId (exercise diag)
      , "inputs"     XML..=. intercalate "," (map (showId . getInputId) (inputs $ solution diag))
      , "examinator" XML..=. fromMaybe "" (examinator diag)
      , XML.builder . XML.toXML . mconcat . map evidence . diagnoses . entry $ diag
      , XML.tag "debug" . XML.text . entry $ diag
      ]

tDiagnosis :: Type a (DiagnosisReply b)
tDiagnosis = Tag "Diagnosis" $ Iso (f <-> toXML) tXML
 where
   f = error "diagnosis from xml not implemented"



-- | UserRequest is a datatype that is used only to collect a group of users
-- and a language for the user-model requests.
data UserRequest = UserRequest
   { ids :: [String]
   , lang :: String
   }


tUserRequest :: Type a UserRequest
tUserRequest = Tag "users" $ Iso (f <-> g) tXML
   where
   g = error "UserRequest cannot be written to xml, only parsed"
   f xml = either error id $ do
      unless (XML.name xml == "users") $ fail "Expecting <users> tag" 
      lang' <- XML.findAttribute "language" xml
      let ids' = map XML.getData $ XML.findChildren "userid" xml
      return $ UserRequest { ids = ids', lang = lang' }


tUserIdTag :: Type a String
tUserIdTag = Tag "userid" $ Iso (f <-> g) tXML
   where
   g = error "StudentID cannot be written to xml, only parsed"
   f xml = do
            unless (XML.name xml == "userid") $ fail "expecting <userid> tag"
            XML.getData xml