{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# Language QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}

{- |
Functions using `Interpreter` to run time compile and evaluate various aspects of a task.
The interpreted code is usually supplied by accessing data stored in `FlexInst` or `FlexConf`.
-}

module FlexTask.Interpreter
  ( checkSolution
  , genFlexInst
  , prettyError
  , validateSettings
  , validDescription
  ) where


import Control.Monad                (unless, void)
import Control.Monad.Identity       (runIdentity)
import Control.Monad.Random         (RandT, StdGen, evalRandT, mkStdGen)
import Control.OutputCapable.Blocks.Type
import Control.OutputCapable.Blocks (OutputCapable, LangM)
import Data.Digest.Pure.SHA         (sha256, showDigest)
import Data.List.Extra              (headDef, intercalate, replace)
import Data.Map                     (elems)
import Data.Maybe                   (isJust)
import Data.Text                    (Text)
import Data.Text.Lazy.Encoding      (encodeUtf8)
import Data.Text.Lazy               (pack)
import Data.Typeable                (Typeable)
import Data.Tuple.Extra             (first)
import Language.Haskell.Interpreter (
    GhcError(errMsg),
    Interpreter,
    InterpreterError(..),
    infer,
    interpret,
    loadModules,
    parens,
    setImports,
    setTopLevelModules
    )
import Language.Haskell.Interpreter.Unsafe (
    unsafeRunInterpreterWithArgs
    )
import System.Directory (
    createDirectoryIfMissing,
    doesFileExist,
    getTemporaryDirectory,
    )
import System.Environment          (getEnv)
import System.FilePath             ((</>), (<.>))
import Text.RawString.QQ (rQ)

import FlexTask.Types (
  CommonModules(..),
  FlexConf(..),
  FlexInst(..),
  HtmlDict,
  )
import FlexTask.Processing.Text    (removeUnicodeEscape)




type GenOutput = (String, String, IO ([[Text]], HtmlDict))


{- |
-}
validateSettings
  :: String   -- ^ The task identifier used for caching
  -> String   -- ^ Global module
  -> String   -- ^ Module containing configuration options
  -> [(String,String)] -- ^ Additional code modules
  -> IO (Either InterpreterError (Bool,[Output]))
validateSettings :: [Char]
-> [Char]
-> [Char]
-> [([Char], [Char])]
-> IO (Either InterpreterError (Bool, [Output]))
validateSettings [Char]
taskName [Char]
globalCode [Char]
settingsCode [([Char], [Char])]
extraCode = do
    [[Char]]
filePaths <- [Char] -> [([Char], [Char])] -> IO [[Char]]
writeUncachedAndGetPaths [Char]
taskName ([([Char], [Char])] -> IO [[Char]])
-> [([Char], [Char])] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
      [ ([Char]
"Global", [Char]
globalCode)
      , ([Char]
"TaskSettings", [Char]
settingsCode)
      ] [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extraCode
    Interpreter (Bool, [Output])
-> IO (Either InterpreterError (Bool, [Output]))
forall a. Interpreter a -> IO (Either InterpreterError a)
runWithPackageDB ([[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
loadModules [[Char]]
filePaths InterpreterT IO ()
-> Interpreter (Bool, [Output]) -> Interpreter (Bool, [Output])
forall a b.
InterpreterT IO a -> InterpreterT IO b -> InterpreterT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Interpreter (Bool, [Output])
validate)
  where
    validate :: Interpreter (Bool, [Output])
validate = do
      [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setImports
        [ [Char]
"Control.Monad.Identity"
        , [Char]
"Control.OutputCapable.Blocks.Generic.Type"
        , [Char]
"Control.OutputCapable.Blocks"
        , [Char]
"Data.Text"
        ]
      [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setTopLevelModules [[Char]
"TaskSettings", [Char]
"Global"]
      LangM' (ReportT Output Identity) ()
out <- [Char]
-> LangM' (ReportT Output Identity) ()
-> InterpreterT IO (LangM' (ReportT Output Identity) ())
forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
[Char] -> a -> m a
interpret [Char]
"validateSettings" LangM' (ReportT Output Identity) ()
forall a. Typeable a => a
infer
      (Bool, [Output]) -> Interpreter (Bool, [Output])
forall a. a -> InterpreterT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, [Output]) -> Interpreter (Bool, [Output]))
-> (Bool, [Output]) -> Interpreter (Bool, [Output])
forall a b. (a -> b) -> a -> b
$ (Maybe () -> Bool) -> (Maybe (), [Output]) -> (Bool, [Output])
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (forall a. Maybe a -> Bool
isJust @()) ((Maybe (), [Output]) -> (Bool, [Output]))
-> (Maybe (), [Output]) -> (Bool, [Output])
forall a b. (a -> b) -> a -> b
$ Identity (Maybe (), [Output]) -> (Maybe (), [Output])
forall a. Identity a -> a
runIdentity (Identity (Maybe (), [Output]) -> (Maybe (), [Output]))
-> Identity (Maybe (), [Output]) -> (Maybe (), [Output])
forall a b. (a -> b) -> a -> b
$ LangM' (ReportT Output Identity) ()
-> Identity (Maybe (), [Output])
forall (m :: * -> *) a.
Functor m =>
LangM' (ReportT Output m) a -> m (Maybe a, [Output])
getOutputSequenceWithResult LangM' (ReportT Output Identity) ()
out

{- |
Use a `FlexConf` to generate a `FlexInst`.
Interprets `taskDataModule` to generate the input form and task data.
Apply the given method to run the generator with a seed.
-}
genFlexInst
  :: FlexConf
  -> Int          -- ^ Generator seed
  -> IO FlexInst
genFlexInst :: FlexConf -> Int -> IO FlexInst
genFlexInst
  FlexConf{ commonModules :: FlexConf -> CommonModules
commonModules = commonModules :: CommonModules
commonModules@CommonModules{
    [Char]
taskName :: [Char]
taskName :: CommonModules -> [Char]
taskName,
    [Char]
globalModule :: [Char]
globalModule :: CommonModules -> [Char]
globalModule,
    [Char]
settingsModule :: [Char]
settingsModule :: CommonModules -> [Char]
settingsModule,
    [([Char], [Char])]
extraModules :: [([Char], [Char])]
extraModules :: CommonModules -> [([Char], [Char])]
extraModules
    },
    [Char]
taskDataModule :: FlexConf -> [Char]
taskDataModule :: [Char]
..}
  Int
seed
  = do
      [[Char]]
filePaths <- [Char] -> [([Char], [Char])] -> IO [[Char]]
writeUncachedAndGetPaths [Char]
taskName ([([Char], [Char])] -> IO [[Char]])
-> [([Char], [Char])] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
        [ ([Char]
"Global", [Char]
globalModule)
        , ([Char]
"TaskSettings", [Char]
settingsModule)
        , ([Char]
"TaskData", [Char]
taskDataModule)
        ] [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extraModules
      [Char]
helperPath <- IO [Char]
cacheHelper
      Either InterpreterError (RandT StdGen IO GenOutput)
taskAndFormResult <- Interpreter (RandT StdGen IO GenOutput)
-> IO (Either InterpreterError (RandT StdGen IO GenOutput))
forall a. Interpreter a -> IO (Either InterpreterError a)
runWithPackageDB (Interpreter (RandT StdGen IO GenOutput)
 -> IO (Either InterpreterError (RandT StdGen IO GenOutput)))
-> Interpreter (RandT StdGen IO GenOutput)
-> IO (Either InterpreterError (RandT StdGen IO GenOutput))
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
loadModules ([Char]
helperPath [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
filePaths) InterpreterT IO ()
-> Interpreter (RandT StdGen IO GenOutput)
-> Interpreter (RandT StdGen IO GenOutput)
forall a b.
InterpreterT IO a -> InterpreterT IO b -> InterpreterT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Interpreter (RandT StdGen IO GenOutput)
tfInter
      let gen :: RandT StdGen IO GenOutput
gen = Either InterpreterError (RandT StdGen IO GenOutput)
-> RandT StdGen IO GenOutput
forall c. Either InterpreterError c -> c
extract Either InterpreterError (RandT StdGen IO GenOutput)
taskAndFormResult
      ([Char]
taskData, [Char]
checkModule, IO ([[Text]], HtmlDict)
io) <- RandT StdGen IO GenOutput -> StdGen -> IO GenOutput
forall (m :: * -> *) g a. Monad m => RandT g m a -> g -> m a
evalRandT RandT StdGen IO GenOutput
gen (StdGen -> IO GenOutput) -> StdGen -> IO GenOutput
forall a b. (a -> b) -> a -> b
$ Int -> StdGen
mkStdGen Int
seed
      ([[Text]], HtmlDict)
form <- IO ([[Text]], HtmlDict)
io
      FlexInst -> IO FlexInst
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlexInst -> IO FlexInst) -> FlexInst -> IO FlexInst
forall a b. (a -> b) -> a -> b
$ FlexInst {
        ([[Text]], HtmlDict)
form :: ([[Text]], HtmlDict)
form :: ([[Text]], HtmlDict)
form,
        [Char]
taskData :: [Char]
taskData :: [Char]
taskData,
        [Char]
checkModule :: [Char]
checkModule :: [Char]
checkModule,
        CommonModules
commonModules :: CommonModules
commonModules :: CommonModules
commonModules
      }
    where
      tfInter :: Interpreter (RandT StdGen IO GenOutput)
      tfInter :: Interpreter (RandT StdGen IO GenOutput)
tfInter = do
        [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setTopLevelModules [[Char]
"TaskData", [Char]
"Global", [Char]
"TaskSettings", [Char]
"Helper"]
        [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setImports [
            [Char]
"Capabilities.Alloy.IO"
          , [Char]
"Capabilities.Diagrams.IO"
          , [Char]
"Capabilities.Graphviz.IO"
          , [Char]
"Control.Monad.Random"
          , [Char]
"Data.Generics.Text"
          , [Char]
"Data.Map"
          , [Char]
"Data.Text"
          , [Char]
"Data.Tuple.Extra"
          ]
        [Char]
-> RandT StdGen IO GenOutput
-> Interpreter (RandT StdGen IO GenOutput)
forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
[Char] -> a -> m a
interpret [Char]
"third3 getFormData . first3 gshow <$> getTask " RandT StdGen IO GenOutput
forall a. Typeable a => a
infer



makeDescription
  :: (OutputCapable m, Typeable m)
  => String
  -> String
  -> String
  -> String
  -> String
  -> [(String,String)]
  -> FilePath
  -> IO (Either InterpreterError (LangM m))
makeDescription :: forall (m :: * -> *).
(OutputCapable m, Typeable m) =>
[Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [([Char], [Char])]
-> [Char]
-> IO (Either InterpreterError (LangM m))
makeDescription [Char]
taskName [Char]
taskData [Char]
global [Char]
settings [Char]
description [([Char], [Char])]
extras [Char]
picPath = do
    [[Char]]
filePaths <- [Char] -> [([Char], [Char])] -> IO [[Char]]
writeUncachedAndGetPaths [Char]
taskName ([([Char], [Char])] -> IO [[Char]])
-> [([Char], [Char])] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
          [ ([Char]
"Global", [Char]
global)
          , ([Char]
"TaskSettings", [Char]
settings)
          , ([Char]
"Description", [Char]
description)
          ] [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extras
    Interpreter (LangM m) -> IO (Either InterpreterError (LangM m))
forall a. Interpreter a -> IO (Either InterpreterError a)
runWithPackageDB (Interpreter (LangM m) -> IO (Either InterpreterError (LangM m)))
-> Interpreter (LangM m) -> IO (Either InterpreterError (LangM m))
forall a b. (a -> b) -> a -> b
$ [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
loadModules [[Char]]
filePaths InterpreterT IO ()
-> Interpreter (LangM m) -> Interpreter (LangM m)
forall a b.
InterpreterT IO a -> InterpreterT IO b -> InterpreterT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Interpreter (LangM m)
descInter
  where
    descInter :: Interpreter (LangM m)
descInter = do
      [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setTopLevelModules [[Char]
"Description", [Char]
"Global", [Char]
"TaskSettings"]
      [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setImports
        [ [Char]
"Capabilities.Graphviz.IO"
        , [Char]
"Capabilities.Cache.IO"
        , [Char]
"Capabilities.Diagrams.IO"
        , [Char]
"Capabilities.LatexSvg.IO"
        , [Char]
"Capabilities.WriteFile.IO"
        , [Char]
"Control.OutputCapable.Blocks.Generic.Type"
        , [Char]
"Data.Generics.Text"
        , [Char]
"Data.List.Extra"
        , [Char]
"Data.Text"
        ]
      [Char] -> LangM m -> Interpreter (LangM m)
forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
[Char] -> a -> m a
interpret ([Char]
"description " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
picPath [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
parens ([Char] -> [Char]
greadError [Char]
taskData)) LangM m
forall a. Typeable a => a
infer



{- |
Produce the task description by using task data
and two interpreted modules or restore a cached result.
Should the solution not yet exist on disc,
then it will be created by interpreting /description/ and saved in a file.
If the task description already exists on disc, it is read.
Then, if any of the image links of that description are invalid (have been deleted),
the description is interpreted again to regenerate the missing files.
-}
validDescription
  :: OutputCapable m
  => String       -- ^ The task identifier used for caching
  -> String       -- ^ Data available for making the description
  -> String       -- ^ Global module
  -> String       -- ^ Settings module
  -> String       -- ^ Module containing the /description/ function
  -> [(String,String)] -- ^ Additional code modules
  -> FilePath     -- ^ Path images will be stored in
  -> IO (LangM m) -- ^ `OutputCapable` representation of task description
validDescription :: forall (m :: * -> *).
OutputCapable m =>
[Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [([Char], [Char])]
-> [Char]
-> IO (LangM m)
validDescription [Char]
taskName [Char]
taskData [Char]
globalModule [Char]
settingsModule [Char]
descModule [([Char], [Char])]
extras [Char]
picPath = do
  let ([[Char]]
firstHalf,[[Char]]
secondHalf) = Int -> [[Char]] -> ([[Char]], [[Char]])
forall a. Int -> [a] -> ([a], [a])
splitAt ([([Char], [Char])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], [Char])]
extras Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) ([[Char]] -> ([[Char]], [[Char]]))
-> [[Char]] -> ([[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd [([Char], [Char])]
extras
  let fileName :: [Char]
fileName = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"DescriptionCache" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
forall a. Show a => a -> [Char]
hash
        [ [Char]
descModule [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
firstHalf
        , [Char]
taskData [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
secondHalf
        , [Char]
globalModule [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
settingsModule
        ]
  [Char]
cDir <- [Char] -> IO [Char]
cacheDir [Char]
taskName
  let path :: [Char]
path = [Char]
cDir [Char] -> [Char] -> [Char]
</> [Char]
fileName
  Bool
isThere <- [Char] -> IO Bool
doesFileExist [Char]
path
  if Bool
isThere
    then do
      [Output]
output <- [Char] -> [Output]
forall a. Read a => [Char] -> a
read ([Char] -> [Output]) -> IO [Char] -> IO [Output]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile [Char]
path
      let fileLinks :: [[Char]]
fileLinks = [Output] -> [[Char]]
imageLinks [Output]
output
      [Bool]
exist <- ([Char] -> IO Bool) -> [[Char]] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO Bool
doesFileExist [[Char]]
fileLinks
      if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
exist
        then
          LangM m -> IO (LangM m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LangM m -> IO (LangM m)) -> LangM m -> IO (LangM m)
forall a b. (a -> b) -> a -> b
$ [Output] -> LangM m
forall (m :: * -> *). OutputCapable m => [Output] -> LangM m
toOutputCapable [Output]
output
        else
          Maybe [Output] -> [Char] -> IO (LangM m)
forall {m :: * -> *}.
OutputCapable m =>
Maybe [Output] -> [Char] -> IO (LangM m)
makeDescAndWrite ([Output] -> Maybe [Output]
forall a. a -> Maybe a
Just [Output]
output) [Char]
path
    else
      Maybe [Output] -> [Char] -> IO (LangM m)
forall {m :: * -> *}.
OutputCapable m =>
Maybe [Output] -> [Char] -> IO (LangM m)
makeDescAndWrite Maybe [Output]
forall a. Maybe a
Nothing [Char]
path
  where
    makeDescAndWrite :: Maybe [Output] -> [Char] -> IO (LangM m)
makeDescAndWrite Maybe [Output]
mOldOutput [Char]
p = do
      Either InterpreterError (LangM (ReportT Output IO))
res <- [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [([Char], [Char])]
-> [Char]
-> IO (Either InterpreterError (LangM (ReportT Output IO)))
forall (m :: * -> *).
(OutputCapable m, Typeable m) =>
[Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [([Char], [Char])]
-> [Char]
-> IO (Either InterpreterError (LangM m))
makeDescription [Char]
taskName [Char]
taskData [Char]
globalModule [Char]
settingsModule [Char]
descModule [([Char], [Char])]
extras [Char]
picPath
      [Output]
output <- LangM (ReportT Output IO) -> IO [Output]
forall (m :: * -> *).
Functor m =>
LangM (ReportT Output m) -> m [Output]
getOutputSequence (LangM (ReportT Output IO) -> IO [Output])
-> LangM (ReportT Output IO) -> IO [Output]
forall a b. (a -> b) -> a -> b
$ Either InterpreterError (LangM (ReportT Output IO))
-> LangM (ReportT Output IO)
forall c. Either InterpreterError c -> c
extract Either InterpreterError (LangM (ReportT Output IO))
res
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [Output]
mOldOutput Maybe [Output] -> Maybe [Output] -> Bool
forall a. Eq a => a -> a -> Bool
== [Output] -> Maybe [Output]
forall a. a -> Maybe a
Just [Output]
output) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFile [Char]
p ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Output] -> [Char]
forall a. Show a => a -> [Char]
show [Output]
output
      LangM m -> IO (LangM m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LangM m -> IO (LangM m)) -> LangM m -> IO (LangM m)
forall a b. (a -> b) -> a -> b
$ [Output] -> LangM m
forall (m :: * -> *). OutputCapable m => [Output] -> LangM m
toOutputCapable [Output]
output



{- |
Run the interpreter with a custom package database.
The filepath is given externally via an environment variable /FLEX_PKGDB/.
-}
runWithPackageDB :: Interpreter a -> IO (Either InterpreterError a)
runWithPackageDB :: forall a. Interpreter a -> IO (Either InterpreterError a)
runWithPackageDB Interpreter a
interpreter = do
  [Char]
path <- [Char] -> IO [Char]
getEnv [Char]
"FLEX_PKGDB"
  [[Char]] -> Interpreter a -> IO (Either InterpreterError a)
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[[Char]] -> InterpreterT m a -> m (Either InterpreterError a)
unsafeRunInterpreterWithArgs [[Char]
"-package-db " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
path] Interpreter a
interpreter



{- |
Use task data and interpret three code modules to evaluate a submission.
The submission ist parsed by function /parseSubmission/.
The result is evaluated by functions /checkSyntax/ and /checkSemantics/.
The result is a tuple of syntax feedback and optional semantics feedback.
If the syntax check fails, then no semantics feedback is provided.
Semantics feedback is coupled with a rating given as a Rational (0 to 1).
-}
checkSolution
  :: String   -- ^ The task identifier used for caching
  -> String   -- ^ Data made available to checker functions
  -> String   -- ^ Global module
  -> String   -- ^ Module containing configuration options
  -> String   -- ^ Module containing /parseSubmission/
  -> String   -- ^ Module containing /checkSyntax/ and /checkSemantics/
  -> [(String,String)] -- ^ Additional code modules
  -> String   -- ^ Student solution
  -> FilePath -- ^ Path images will be stored in
  -> IO (Either InterpreterError ([Output], Maybe (Maybe Rational, [Output])))
checkSolution :: [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [([Char], [Char])]
-> [Char]
-> [Char]
-> IO
     (Either
        InterpreterError ([Output], Maybe (Maybe Rational, [Output])))
checkSolution [Char]
taskName [Char]
taskData [Char]
globalCode [Char]
settingsCode [Char]
parseCode [Char]
checkCode [([Char], [Char])]
extraCode [Char]
submission [Char]
picPath = do
    [[Char]]
filePaths <- [Char] -> [([Char], [Char])] -> IO [[Char]]
writeUncachedAndGetPaths [Char]
taskName ([([Char], [Char])] -> IO [[Char]])
-> [([Char], [Char])] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
      [ ([Char]
"Global", [Char]
globalCode)
      , ([Char]
"TaskSettings", [Char]
settingsCode)
      , ([Char]
"Parse", [Char]
parseCode)
      , ([Char]
"Check", [Char]
checkCode)
      ] [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extraCode
    [Char]
helperPath <- IO [Char]
cacheHelper
    Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
-> IO
     (Either
        InterpreterError (IO ([Output], Maybe (Maybe Rational, [Output]))))
forall a. Interpreter a -> IO (Either InterpreterError a)
runWithPackageDB ([[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
loadModules ([Char]
helperPath [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
filePaths) InterpreterT IO ()
-> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
-> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
forall a b.
InterpreterT IO a -> InterpreterT IO b -> InterpreterT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
runCheck) IO
  (Either
     InterpreterError (IO ([Output], Maybe (Maybe Rational, [Output]))))
-> (Either
      InterpreterError (IO ([Output], Maybe (Maybe Rational, [Output])))
    -> IO
         (Either
            InterpreterError ([Output], Maybe (Maybe Rational, [Output]))))
-> IO
     (Either
        InterpreterError ([Output], Maybe (Maybe Rational, [Output])))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either
  InterpreterError (IO ([Output], Maybe (Maybe Rational, [Output])))
-> IO
     (Either
        InterpreterError ([Output], Maybe (Maybe Rational, [Output])))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
Either InterpreterError (m a) -> m (Either InterpreterError a)
sequence
  where
    runCheck :: Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
runCheck = do
      [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setImports
        [ [Char]
"Capabilities.Cache.IO"
        , [Char]
"Capabilities.Diagrams.IO"
        , [Char]
"Capabilities.LatexSvg.IO"
        , [Char]
"Capabilities.Graphviz.IO"
        , [Char]
"Capabilities.WriteFile.IO"
        , [Char]
"Control.OutputCapable.Blocks.Generic.Type"
        , [Char]
"Control.OutputCapable.Blocks"
        , [Char]
"Data.Generics.Text"
        , [Char]
"Data.List.Extra"
        , [Char]
"Data.Ratio"
        , [Char]
"Data.Text"
        ]
      [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setTopLevelModules [[Char]
"Check", [Char]
"Global", [Char]
"Helper", [Char]
"Parse"]
      [Char]
-> IO ([Output], Maybe (Maybe Rational, [Output]))
-> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
[Char] -> a -> m a
interpret ([Char]
"syntaxAndSemantics parseSubmission checkSyntax checkSemantics " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
input [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tData) IO ([Output], Maybe (Maybe Rational, [Output]))
forall a. Typeable a => a
infer

    tData :: [Char]
tData = [Char] -> [Char]
parens ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
greadError [Char]
taskData
    input :: [Char]
input = [Char] -> [Char]
removeUnicodeEscape ([Char] -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> [Char]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [Char]
"\\\\" [Char]
"\\" [Char]
submission)
    path :: [Char]
path = [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
picPath



writeUncachedAndGetPaths :: FilePath -> [(String, String)] -> IO [FilePath]
writeUncachedAndGetPaths :: [Char] -> [([Char], [Char])] -> IO [[Char]]
writeUncachedAndGetPaths [Char]
cachePrefix [([Char], [Char])]
xs = do
    [([Char], [Char])]
paths <- [([Char], [Char])] -> IO [([Char], [Char])]
getCachePaths [([Char], [Char])]
xs
    [([Char], [Char])] -> IO ()
writeUncachedFiles [([Char], [Char])]
paths
    [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst [([Char], [Char])]
paths
  where
    getCachePaths :: [(String,String)] -> IO [(FilePath,String)]
    getCachePaths :: [([Char], [Char])] -> IO [([Char], [Char])]
getCachePaths [([Char], [Char])]
files = do
      [Char]
dir <- [Char] -> IO [Char]
cacheDir [Char]
cachePrefix
      [([Char], [Char])] -> IO [([Char], [Char])]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([([Char], [Char])] -> IO [([Char], [Char])])
-> [([Char], [Char])] -> IO [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ (([Char], [Char]) -> ([Char], [Char]))
-> [([Char], [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
prefix, [Char]
content) ->
        ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
prefix [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
hash [Char]
content [Char] -> [Char] -> [Char]
<.> [Char]
"hs",[Char]
content)) [([Char], [Char])]
files

    writeUncachedFiles :: [(FilePath,String)] -> IO ()
    writeUncachedFiles :: [([Char], [Char])] -> IO ()
writeUncachedFiles = IO [()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [()] -> IO ())
-> ([([Char], [Char])] -> IO [()]) -> [([Char], [Char])] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> IO ()) -> [([Char], [Char])] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ ([Char]
path,[Char]
content) ->
      [Char] -> IO Bool
doesFileExist [Char]
path IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> [Char] -> IO ()
writeFile [Char]
path [Char]
content))



extract :: Either InterpreterError c -> c
extract :: forall c. Either InterpreterError c -> c
extract = (InterpreterError -> c)
-> (c -> c) -> Either InterpreterError c -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c)
-> (InterpreterError -> [Char]) -> InterpreterError -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> [Char]
prettyError) c -> c
forall a. a -> a
id


hash :: Show a => a -> String
hash :: forall a. Show a => a -> [Char]
hash = Digest SHA256State -> [Char]
forall t. Digest t -> [Char]
showDigest (Digest SHA256State -> [Char])
-> (a -> Digest SHA256State) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256State
sha256 (ByteString -> Digest SHA256State)
-> (a -> ByteString) -> a -> Digest SHA256State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack ([Char] -> Text) -> (a -> [Char]) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show



cacheDir :: FilePath -> IO FilePath
cacheDir :: [Char] -> IO [Char]
cacheDir [Char]
prefix = do
  [Char]
temporary <- IO [Char]
getTemporaryDirectory
  let dir :: [Char]
dir = [Char]
temporary [Char] -> [Char] -> [Char]
</> [Char]
"FlexCache" [Char] -> [Char] -> [Char]
</> [Char]
prefix
  Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
  [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
dir



imageLinks :: [Output] -> [FilePath]
imageLinks :: [Output] -> [[Char]]
imageLinks = (Output -> [[Char]]) -> [Output] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Output -> [[Char]]) -> [Output] -> [[Char]])
-> (Output -> [[Char]]) -> [Output] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [[Char]] -> [[Char]])
-> (Output -> [[Char]]) -> Output -> [[Char]]
forall a element.
(a -> a -> a)
-> (SpecialOutput element -> a) -> SpecialOutput element -> a
foldMapOutputBy [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
(++) (\case
  Image [Char]
l       -> [[Char]
l]
  Images Map [Char] [Char]
m      -> Map [Char] [Char] -> [[Char]]
forall k a. Map k a -> [a]
elems Map [Char] [Char]
m
  YesNo {}      -> []
  Paragraph {}  -> []
  Enumerated {} -> []
  Itemized {}   -> []
  Indented {}   -> []
  Folded {}     -> []
  Latex {}      -> []
  Code {}       -> []
  Translated {} -> []
  Special {}    -> []
  )


cacheHelper :: IO FilePath
cacheHelper :: IO [Char]
cacheHelper = [Char] -> [[Char]] -> [Char]
forall a. a -> [a] -> a
headDef [Char]
forall {a}. a
cachingError ([[Char]] -> [Char]) -> IO [[Char]] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [Char] -> [([Char], [Char])] -> IO [[Char]]
writeUncachedAndGetPaths [Char]
"" [([Char]
"Helper",[Char]
helperCode)]
  where
    cachingError :: a
cachingError = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Caching the internal Helper module failed."

    helperCode :: [Char]
helperCode = [Char]
[rQ|
module Helper (syntaxAndSemantics) where

import FlexTask.InterpreterHelper
|]



{- |
Custom display of Hint InterpreterError messages.
-}
prettyError :: InterpreterError -> String
prettyError :: InterpreterError -> [Char]
prettyError (UnknownError [Char]
s) = [Char]
"Unknown error:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
prettyError (NotAllowed [Char]
s) = [Char]
"Not allowed:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
prettyError (GhcException [Char]
s) = [Char]
"GHC exception occurred:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
prettyError (WontCompile [GhcError]
ghcErrors) = [Char]
"Won't compile:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines ((GhcError -> [Char]) -> [GhcError] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map GhcError -> [Char]
errMsg [GhcError]
ghcErrors)


greadError :: String -> String
greadError :: [Char] -> [Char]
greadError [Char]
term = [Char]
"fst $ headDef (error " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
errorMessage [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
") $ gread " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
term [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: TaskData"
  where
    errorMessage :: [Char]
errorMessage = [Char]
"Failed reading stored TaskData. Encountered this: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
term