{-# LANGUAGE CPP, TemplateHaskell #-}
module MagicHaskeller.ExpToHtml(QueryOptions(..), defaultQO,
review,
expToPlainString, expSigToString, refer, pprnn, annotateFree, annotateString, Language(..)) where
import Language.Haskell.TH as TH
import Language.Haskell.TH.PprLib(to_HPJ_Doc)
import Text.PrettyPrint
import Network.URI(escapeURIString, isUnreserved)
import Text.Html(stringToHtmlString)
import MagicHaskeller.LibTH(fromPrelude, fromDataList, fromDataChar, fromDataMaybe, Primitive, ords, prelOrdRelated, prelEqRelated, dataListOrdRelated, dataListEqRelated, fromPrelDouble, fromPrelRatio, fromDataRatio)
import Data.Char(isAlpha, ord, isDigit, isSpace, toUpper)
import qualified Data.Map
import qualified Data.IntSet as IS
import Data.Generics
import MagicHaskeller.CoreLang(stripByd_)
import Data.Hashable
import Data.List((\\))
import Control.Monad(mplus)
-- Maybe QueryOptions should be put in a new module.
data QueryOptions = Q {depth :: Int, absents :: Bool} deriving (Read, Show)
defaultQO = Q {depth = 7, absents = False}
data Language = LHaskell | LExcel | LJavaScript deriving (Read, Show, Eq)
-- | 'review' makes sure the predicate string does not use either let or where, and may correct grammatical mistakes.
-- This check should be done on both the CGI frontend side and the backend server side.
review :: Monad m => String -> m (String,Bool)
review "" = return ("",False)
review xs = case lex xs of
[("let", _)] -> fail "let"
[("where", _)] -> fail "where"
[("=", rest)] -> do (zs,_) <- review rest
return ("~= "++zs, True)
[("&", rest)] -> do (zs,_) <- review rest
return ("&& "++zs, True)
[("NaN",rest)] -> do (zs,_) <- review rest
return ("(0/0) "++zs, True)
[("Infinity",rest)] -> do (zs,_) <- review rest
return ("(1/0) "++zs, True)
[(tkn, rest)] -> do (zs,repl) <- review rest
return (tkn++' ':zs, repl)
expToPlainString, expToString :: Exp -> String
expToPlainString = ('\n':) . pprint
-- expToString = (\xs -> '(':xs++")
") . {- replaceRightArrow . -} pprint . annotateEverywhere -- simple and stupid
expToString = (\xs -> '(':xs++")
") . filter (/='\n') . {- replaceRightArrow . -} annotateString LHaskell. pprnn -- no buttons
expSigToString = mkButton -- with buttons
pprnn = renderStyle style{mode=OneLineMode} . to_HPJ_Doc . pprExp 4
isAbsent :: TH.Exp -> Bool
isAbsent (LamE pats e) = any (==WildP) pats || isAbsent e
isAbsent (VarE name) = nameBase name == "const"
isAbsent _ = False
-- どうも ->をescapeする必要はないみたい.ま,<->みたいな演算子はescapeされているはずだし,みたいなコメントはないはずなので,→で置き換えても害はなさそう.
-- と思ったけど,コピペするのに不便.
replaceRightArrow "" = ""
replaceRightArrow ('-':'>':xs) = "→"++replaceRightArrow xs
replaceRightArrow (x:xs) = x : replaceRightArrow xs
-- Unfortunately, w3m does not understand