{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# Language OverloadedStrings #-}
{-# 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
  , validateSettingsAndCompile
  , validDescription
  ) where


import Control.Monad.Catch          (throwM, catch)
import Control.Exception            (ErrorCall, displayException, evaluate)
import Control.Monad                (unless, void)
import Control.Monad.IO.Class       (liftIO)
import Control.Monad.Identity       (runIdentity)
import Control.Monad.Random         (evalRandT, mkStdGen)
import Control.OutputCapable.Blocks.Type
import Control.OutputCapable.Blocks (OutputCapable, LangM, code)
import Data.Digest.Pure.SHA         (sha256, showDigest)
import Data.List.Extra              (headDef, intercalate, replace)
import Data.Map                     (elems, fromList)
import Data.Maybe                   (isJust)
import Data.String.Interpolate      (i)
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 FlexTask.Types (
  CommonModules(..),
  FlexConf(..),
  FlexInst(..),
  ValidationFlag(..),
  )
import FlexTask.Processing.Text    (removeUnicodeEscape)



{- |
-}
validateSettingsAndCompile
  :: FlexConf
  -> IO (Either InterpreterError (Bool,[Output]))
validateSettingsAndCompile :: FlexConf -> IO (Either InterpreterError (Bool, [Output]))
validateSettingsAndCompile FlexConf {validation :: FlexConf -> ValidationFlag
validation = ValidationFlag
AssumeValid} = Either InterpreterError (Bool, [Output])
-> IO (Either InterpreterError (Bool, [Output]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError (Bool, [Output])
 -> IO (Either InterpreterError (Bool, [Output])))
-> Either InterpreterError (Bool, [Output])
-> IO (Either InterpreterError (Bool, [Output]))
forall a b. (a -> b) -> a -> b
$ (Bool, [Output]) -> Either InterpreterError (Bool, [Output])
forall a b. b -> Either a b
Right (Bool
True, [])
validateSettingsAndCompile conf :: FlexConf
conf@FlexConf {commonModules :: FlexConf -> CommonModules
commonModules = CommonModules{[Char]
[([Char], [Char])]
taskName :: [Char]
globalModule :: [Char]
settingsModule :: [Char]
descriptionModule :: [Char]
parseModule :: [Char]
extraModules :: [([Char], [Char])]
extraModules :: CommonModules -> [([Char], [Char])]
parseModule :: CommonModules -> [Char]
descriptionModule :: CommonModules -> [Char]
settingsModule :: CommonModules -> [Char]
globalModule :: CommonModules -> [Char]
taskName :: CommonModules -> [Char]
..}} = do
    instOrError <- FlexConf -> Int -> IO (Either InterpreterError FlexInst)
genFlexInstOrInterpreterError FlexConf
conf Int
0
    case instOrError of
      Left InterpreterError
iError -> Either InterpreterError (Bool, [Output])
-> IO (Either InterpreterError (Bool, [Output]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError (Bool, [Output])
 -> IO (Either InterpreterError (Bool, [Output])))
-> Either InterpreterError (Bool, [Output])
-> IO (Either InterpreterError (Bool, [Output]))
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Either InterpreterError (Bool, [Output])
forall a b. a -> Either a b
Left InterpreterError
iError
      Right (FlexInst {[Char]
checkModule :: [Char]
checkModule :: FlexInst -> [Char]
checkModule}) -> do
        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]
"Description", [Char]
descriptionModule)
          , ([Char]
"Parse", [Char]
parseModule)
          , ([Char]
"Check", [Char]
checkModule)
          ] [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extraModules
        runWithPackageDB (loadModules filePaths >> 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"]
      out <- [Char] -> Interpreter (LangM' (ReportT Output Identity) ())
forall a. Typeable a => [Char] -> Interpreter a
interpretHandleError [Char]
"validateSettings"
      pure $ first (isJust @()) $ runIdentity $ getOutputSequenceWithResult out

{- |
Use a `FlexConf` to generate a `FlexInst`.
Interprets `taskDataModule` to generate the input form and task data.
The given Integer is used as a seed for the generator.
-}
genFlexInst
  :: FlexConf
  -> Int          -- ^ Generator seed
  -> IO FlexInst
genFlexInst :: FlexConf -> Int -> IO FlexInst
genFlexInst conf :: FlexConf
conf@FlexConf {commonModules :: FlexConf -> CommonModules
commonModules = CommonModules
commonModules} Int
seed = do
  taskAndFormResult <- FlexConf -> Int -> IO (Either InterpreterError FlexInst)
genFlexInstOrInterpreterError FlexConf
conf Int
seed
  pure $ handleInterpreterError
    (\[Char]
message -> FlexInst
      { form :: ([Text], [[Text]], HtmlDict)
form = ([],[],) (HtmlDict -> ([Text], [[Text]], HtmlDict))
-> HtmlDict -> ([Text], [[Text]], HtmlDict)
forall a b. (a -> b) -> a -> b
$ [(Text, [Char])] -> HtmlDict
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Text, [Char])] -> HtmlDict) -> [(Text, [Char])] -> HtmlDict
forall a b. (a -> b) -> a -> b
$ (Text -> (Text, [Char])) -> [Text] -> [(Text, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (,[Char]
message) [Text
"de", Text
"en"]
      , taskData :: [Char]
taskData = [Char]
message
      , checkModule :: [Char]
checkModule = [Char]
message
      , CommonModules
commonModules :: CommonModules
commonModules :: CommonModules
commonModules
      }
    )
    taskAndFormResult


genFlexInstOrInterpreterError
  :: FlexConf
  -> Int          -- ^ Generator seed
  -> IO (Either InterpreterError FlexInst)
genFlexInstOrInterpreterError :: FlexConf -> Int -> IO (Either InterpreterError FlexInst)
genFlexInstOrInterpreterError
  FlexConf{ commonModules :: FlexConf -> CommonModules
commonModules = commonModules :: CommonModules
commonModules@CommonModules{
    [Char]
taskName :: CommonModules -> [Char]
taskName :: [Char]
taskName,
    [Char]
globalModule :: CommonModules -> [Char]
globalModule :: [Char]
globalModule,
    [Char]
settingsModule :: CommonModules -> [Char]
settingsModule :: [Char]
settingsModule,
    [([Char], [Char])]
extraModules :: CommonModules -> [([Char], [Char])]
extraModules :: [([Char], [Char])]
extraModules
    },
    [Char]
ValidationFlag
validation :: FlexConf -> ValidationFlag
taskDataModule :: FlexConf -> [Char]
validation :: ValidationFlag
taskDataModule :: [Char]
..}
  Int
seed
  = do
      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
      helperPath <- cacheHelper "GenerationHelper" []
      runWithPackageDB $ loadModules (helperPath : filePaths) >> tfInter
    where
      tfInter :: Interpreter FlexInst
      tfInter :: Interpreter FlexInst
tfInter = do
        [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setTopLevelModules [[Char]
"TaskData", [Char]
"Global", [Char]
"TaskSettings", [Char]
"GenerationHelper"]
        [[Char]] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setImports [
            [Char]
"Control.Monad.Random"
          , [Char]
"Data.Generics.Text"
          , [Char]
"Data.Map"
          , [Char]
"Data.Text"
          , [Char]
"Data.Tuple.Extra"
          ]
        gen <- [Char]
-> Interpreter
     (RandT StdGen IO ([Char], [Char], IO ([Text], [[Text]], HtmlDict)))
forall a. Typeable a => [Char] -> Interpreter a
interpretHandleError [Char]
"third3 getFormData . first3 gshow <$> getTask "
        liftIO $ do
          (taskData,checkModule,io) <- evalRandT gen $ mkStdGen seed
          form <- io
          pure $ FlexInst {
            form,
            taskData,
            checkModule,
            commonModules
          }


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
    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
    runWithPackageDB $ loadModules filePaths >> 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.PlantUml.IO"
        , [Char]
"Capabilities.WriteFile.IO"
        , [Char]
"Control.OutputCapable.Blocks.Generic.Type"
        , [Char]
"Data.Generics.Text"
        , [Char]
"Data.List.Extra"
        , [Char]
"Data.Text"
        ]
      [Char] -> Interpreter (LangM m)
forall a. Typeable a => [Char] -> Interpreter a
interpretHandleError ([Char] -> Interpreter (LangM m))
-> [Char] -> Interpreter (LangM m)
forall a b. (a -> b) -> a -> b
$
        [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)



{- |
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
        ]
  cDir <- [Char] -> IO [Char]
cacheDir [Char]
taskName
  let path = [Char]
cDir [Char] -> [Char] -> [Char]
</> [Char]
fileName
  isThere <- doesFileExist path
  if isThere
    then do
      output <- read <$> readFile path
      let fileLinks = [Output] -> [[Char]]
imageLinks [Output]
output
      exist <- mapM doesFileExist fileLinks
      if and exist
        then
          return $ toOutputCapable output
        else
          makeDescAndWrite (Just output) path
    else
      makeDescAndWrite Nothing path
  where
    makeDescAndWrite :: Maybe [Output] -> [Char] -> IO (LangM m)
makeDescAndWrite Maybe [Output]
mOldOutput [Char]
p = do
      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 <- getOutputSequence $ handleInterpreterError code res
      unless (mOldOutput == Just output) $ writeFile p $ show output
      return $ toOutputCapable 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
  path <- [Char] -> IO [Char]
getEnv [Char]
"FLEX_PKGDB"
  unsafeRunInterpreterWithArgs ["-package-db " <> path] 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
    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
    helperPath <- cacheHelper "EvaluationHelper" ["syntaxAndSemantics"]
    runWithPackageDB (loadModules (helperPath : filePaths) >> runCheck) >>= 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.PlantUml.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]
"EvaluationHelper", [Char]
"Parse"]
      [Char]
-> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
forall a. Typeable a => [Char] -> Interpreter a
interpretHandleError ([Char]
 -> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output]))))
-> [Char]
-> Interpreter (IO ([Output], Maybe (Maybe Rational, [Output])))
forall a b. (a -> b) -> a -> b
$
        [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

    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
    paths <- [([Char], [Char])] -> IO [([Char], [Char])]
getCachePaths [([Char], [Char])]
xs
    writeUncachedFiles paths
    pure $ map fst paths
  where
    getCachePaths :: [(String,String)] -> IO [(FilePath,String)]
    getCachePaths :: [([Char], [Char])] -> IO [([Char], [Char])]
getCachePaths [([Char], [Char])]
files = do
      dir <- [Char] -> IO [Char]
cacheDir [Char]
cachePrefix
      pure $ 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)) 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))



handleInterpreterError :: (String -> a) -> Either InterpreterError a -> a
handleInterpreterError :: forall a. ([Char] -> a) -> Either InterpreterError a -> a
handleInterpreterError [Char] -> a
f = (InterpreterError -> a)
-> (a -> a) -> Either InterpreterError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> a
f ([Char] -> a)
-> (InterpreterError -> [Char]) -> InterpreterError -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> [Char]
prettyError) a -> a
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
  temporary <- IO [Char]
getTemporaryDirectory
  let dir = [Char]
temporary [Char] -> [Char] -> [Char]
</> [Char]
"FlexCache" [Char] -> [Char] -> [Char]
</> [Char]
prefix
  createDirectoryIfMissing True dir
  pure 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 :: String -> [String] -> IO FilePath
cacheHelper :: [Char] -> [[Char]] -> IO [Char]
cacheHelper [Char]
moduleName [[Char]]
exports = [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]
moduleName,[Char]
helperCode)]
  where
    cachingError :: a
cachingError = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [i|Caching the internal #{moduleName} module failed.|]
    helperCode :: [Char]
helperCode = [i|
module #{moduleName} (#{intercalate "," exports}) where

import FlexTask.Interpreter.#{moduleName}
|]


{- |
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


interpretHandleError :: Typeable a => String -> Interpreter a
interpretHandleError :: forall a. Typeable a => [Char] -> Interpreter a
interpretHandleError [Char]
run = do
  result <- [Char] -> a -> InterpreterT IO a
forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
[Char] -> a -> m a
interpret [Char]
run a
forall a. Typeable a => a
infer
  liftIO (evaluate result) `catch` \(ErrorCall
exception :: ErrorCall) ->
    InterpreterError -> InterpreterT IO a
forall e a. (HasCallStack, Exception e) => e -> InterpreterT IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (InterpreterError -> InterpreterT IO a)
-> InterpreterError -> InterpreterT IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> InterpreterError
UnknownError ([Char] -> InterpreterError) -> [Char] -> InterpreterError
forall a b. (a -> b) -> a -> b
$ [Char]
"runtime exception: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ErrorCall -> [Char]
forall e. Exception e => e -> [Char]
displayException ErrorCall
exception