activehs-0.3: Converter.hs

{-# LANGUAGE PatternGuards, ViewPatterns, NamedFieldPuns #-}

module Converter
    ( convert
    ) where

import Parse

import Smart (TaskChan, restart, mkId, interp)
import Result (hasError)
import Html
import Lang
import Args

import qualified Language.Haskell.Exts.Pretty as HPty
import qualified Language.Haskell.Exts.Syntax as HSyn

{- Agda support (unfinished) 
import qualified Agda.Syntax.Concrete as ASyn
import qualified Agda.Utils.Pretty as AUtil
-}

import Text.XHtml.Strict hiding (lang)
import Text.Pandoc

import System.Process (readProcessWithExitCode)
import System.Cmd
import System.FilePath
import System.Exit
import System.Directory (getTemporaryDirectory, getModificationTime, doesFileExist, getTemporaryDirectory, createDirectoryIfMissing)
import System.Time (diffClockTimes, noTimeDiff) 

import Control.Monad
import Data.List

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

convert :: TaskChan -> Args -> String -> IO ()
convert ghci args@(Args {magicname, sourcedir, gendir, recompilecmd, verbose}) what = do
    whenOutOfDate () output input $ do
        whenOutOfDate () object input $ do
            when verbose $ putStrLn $ object ++ " is out of date, regenerating"
--            x <- system $ recompilecmd ++ " " ++ input
            let (ghc:args) = words recompilecmd -- !!!
            (x, out, err) <- readProcessWithExitCode ghc (args ++ [input]) ""
            if x == ExitSuccess 
                then do
                    restart ghci
                    return ()
                else fail $ unlines [unwords [recompilecmd, input], show x, out, err]
        when verbose $ putStrLn $ output ++ " is out of date, regenerating"
        mainParse HaskellMode input  >>= extract HaskellMode verbose ghci args what
    whenOutOfDate () output input2 $ do
    -- watch object code (*.lagdai?) like in haskell mode?
        when verbose $ putStrLn $ output ++ " is out of date, regenerating"
        mainParse AgdaMode input2 >>= extract AgdaMode verbose ghci args what
--        return True
 where
    input  = sourcedir  </> what <.> "lhs"
    input2 = sourcedir  </> what <.> "lagda"
    output = gendir     </> what <.> "xml"
    object = sourcedir  </> what <.> "o"


extract :: ParseMode -> Bool -> TaskChan -> Args -> Language -> Doc -> IO ()
extract mode verbose ghci (Args {lang, templatedir, sourcedir, exercisedir, gendir, magicname}) what (Doc meta modu ss) = do

    writeEx (what <.> ext) [showEnv $ importsHiding []]
    ss' <- zipWithM processBlock [1..] $ preprocessForSlides ss
    ht <- readFile' $ templatedir </> lang' ++ ".template"

    writeFile' (gendir </> what <.> "xml") $ flip writeHtmlString (Pandoc meta $ concat ss')
      $ defaultWriterOptions
        { writerStandalone      = True
        , writerTableOfContents = True
        , writerSectionDivs     = True
        , writerTemplate        = ht
        }

 where
    ext = case mode of
        HaskellMode -> "hs"
        AgdaMode    -> "agda"
    
    lang' = case span (/= '_') . reverse $ what of
        (l, "")                -> lang
        (l, _) | length l > 2  -> lang
        (x, _)                 -> reverse x

    writeEx f l =
        writeFile' (exercisedir </> f) $ intercalate delim l

    writeFile' f s = do
        when verbose $ putStrLn $ f ++ " is written."
        createDirectoryIfMissing True (dropFileName f)
        writeFile f s

    readFile' f = do
        when verbose $ putStrLn $ f ++ " is to read..."
        readFile f

    system' s = do
        when verbose $ putStrLn $ "executing " ++ s
        system s

    importsHiding funnames = case mode of
        HaskellMode -> HPty.prettyPrint $ 
            HSyn.Module loc (HSyn.ModuleName "Main") directives Nothing Nothing
              ([mkImport modname funnames, mkImport_ ('X':magicname) modname] ++ imps) []
        AgdaMode    -> ""
        where
            HaskellModule (HSyn.Module loc (HSyn.ModuleName modname) directives _ _ imps _) = modu

    mkCodeBlock l =
        [ CodeBlock ("", ["haskell"], []) $ intercalate "\n" l | not $ null l ]

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

    processBlock :: Int -> BBlock -> IO [Block]

    processBlock _ (Exercise visihidden _ _ funnames is)
        | null funnames || null is
        = return $ mkCodeBlock $ visihidden

    processBlock _ (Exercise _ visi hidden funnames is) = do
        let i = show $ mkId $ unlines funnames
            j = "_j" ++ i
            fn = what ++ "_" ++ i <.> "hs"
            (static_, inForm, rows) = if null hidden
                then ([], visi, length visi) 
                else (visi, [], 2 + length hidden)

        writeEx fn  [ showEnv $ importsHiding funnames ++ "\n" ++ unlines static_
                    , unlines $ hidden, show $ map parseQuickCheck is, j, i
                    , show funnames ]
        return
            $  mkCodeBlock static_
            ++ showBlockSimple lang' fn i rows (intercalate "\n" inForm)

    processBlock ii (OneLineExercise 'H' erroneous exp) 
        = return []
    processBlock ii (OneLineExercise p erroneous exp) = do
        let m5 = mkId $ show ii ++ exp
            i = show m5
            fn = what ++ (if p == 'R' then "_" ++ i else "") <.> "hs"
            act = getOne "eval" fn i i

        when (p == 'R') $ writeEx fn [showEnv $ importsHiding [], "\n" ++ magicname ++ " = " ++ exp]
        (b, exp') <- if p == 'F' && all (==' ') exp 
                    then return (True, [])
                    else do
                        when verbose $ putStrLn $ "interpreting  " ++ exp
                        r <- interp False m5 lang' ghci (exercisedir </> fn) exp $ \a -> return $ return []

                        return $ (not $ hasError r, take 1 r)

        when (erroneous /= b) 
            $ error $ translate lang' "Erroneous evaluation"  ++ ": " ++ exp ++ " ; " ++ showHtmlFragment (renderResults_ exp')

        return [rawHtml $ showHtmlFragment $ showInterpreter lang' 60 act i p exp exp']

    processBlock _ (Text (CodeBlock ("",[t],[]) l)) 
        | t `elem` ["dot","neato","twopi","circo","fdp","dfdp","latex"] = do
            tmpdir <- getTemporaryDirectory
            let i = show $ mkId $ t ++ l
                fn = what ++ i
                imgname = takeFileName fn <.> "png"
                outfile = gendir </> fn <.> "png"
                tmpfile = tmpdir </> takeFileName fn <.> if t=="latex" then "tex" else t

            writeFile' tmpfile $ unlines $ case t of
                "latex" -> 
                    [ "\\documentclass{article}"
                    , "\\usepackage{ucs}"
                    , "\\usepackage[utf8x]{inputenc}"
                    , "\\usepackage{amsmath}"
                    , "\\pagestyle{empty}"
                    -- , "\\newcommand{\\cfrac}[2]{\\displaystyle\\frac{#1}{#2}}"
                    , "\\begin{document}"
                    , "$$", l, "$$"
                    , "\\end{document}" ]
                _ ->
                    ["digraph G {", l, "}"]

            createDirectoryIfMissing True (dropFileName outfile)

            x <- system' $ unwords $ case t of
                "latex" ->  [ "(", "cd", dropFileName tmpfile, "&&"
                            , "latex -halt-on-error", takeFileName tmpfile, "2>&1 >/dev/null", ")"
                            , "&&", "(", "dvipng -D 150 -T tight", "-o", outfile
                            , replaceExtension tmpfile "dvi", "2>&1 >/dev/null",")"]
                _       ->  [ t, "-Tpng", "-o", outfile, tmpfile, "2>&1 >/dev/null" ]

            if x == ExitSuccess 
                then return [Para [Image [Str imgname] (imgname, "")]]
                else fail $ "processDot " ++ tmpfile ++ "; " ++ show x

    processBlock _ (Text l)
        = return [l]


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

preprocessForSlides :: [BBlock] -> [BBlock]
preprocessForSlides x = case span (not . isLim) x of
    (a, []) -> a
    (a, b) -> a ++ case span (not . isHeader) b of
        (c, d) -> [Text $ rawHtml "<div class=\"handout\">"] ++ c 
               ++ [Text $ rawHtml "</div>"] ++ preprocessForSlides d
 where
    isLim (Text HorizontalRule) = True
    isLim _ = False

    isHeader (Text (Header _ _)) = True
    isHeader _ = False

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

rawHtml :: String -> Block
rawHtml x = RawBlock "html" x

showBlockSimple :: Language -> String -> String -> Int -> String -> [Block]

showBlockSimple lang fn i rows_ cont = (:[]) $ rawHtml $ showHtmlFragment $ indent $
  [ form
    ! [ theclass $ if null cont then "interpreter" else "resetinterpreter"
      , action $ getOne "check" fn i i
      ]
    <<[ textarea 
        ! [ cols "80"
          , rows $ show rows_
          , identifier $ "tarea" ++ i
          ]
        << cont
      , br
      , input ! [thetype "submit", value $ translate lang "Check"]
      ]
  , thediv ! [theclass "answer", identifier $ "res" ++ i] << ""
  ]

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

showEnv :: String -> String
showEnv prelude
    =  "{-# LINE 1 \"testenv\" #-}\n"
    ++ prelude
    ++ "\n{-# LINE 1 \"input\" #-}\n"

mkImport :: String -> [Name] -> HSyn.ImportDecl
mkImport m d 
    = HSyn.ImportDecl
        { HSyn.importLoc = undefined
        , HSyn.importModule = HSyn.ModuleName m
        , HSyn.importQualified = False
        , HSyn.importSrc = False
        , HSyn.importPkg = Nothing
        , HSyn.importAs = Nothing
        , HSyn.importSpecs = Just (True, map (HSyn.IVar . HSyn.Ident) d)
        }

mkImport_ :: String -> String -> HSyn.ImportDecl
mkImport_ magic m 
    = (mkImport m []) { HSyn.importQualified = True, HSyn.importAs = Just $ HSyn.ModuleName magic }

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

whenOutOfDate :: b -> FilePath -> FilePath -> IO b -> IO b
whenOutOfDate def x src m = do
    a <- modTime x
    b <- modTime src
    case (a, b) of
        (Nothing, Just _) -> m
        (Just t1, Just t2) | diffClockTimes t2 t1 > noTimeDiff -> m
        _   -> return def
 where
    modTime f = do
        a <- doesFileExist f
        if a then fmap Just $ getModificationTime f else return Nothing


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