module MagicHaskeller.ExpToHtml(expSigToString, refer, pprnn, annotateFree) 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)
import Data.Char(isAlpha, ord)
import qualified Data.Map
import Data.Generics

expToString :: Exp -> String
-- expToString = ('\n':) . pprint
-- expToString = (\xs -> '(':xs++")<br>") . {- replaceRightArrow . -} pprint . annotateEverywhere -- simple and stupid
expToString = (\xs -> '(':xs++")<br>") . filter (/='\n') . {- replaceRightArrow . -} pprint . annotateFree [] -- no buttons
expSigToString predStr sig expr 
  = mkButton predStr sig expr (pprnn (annotateFree [] expr)) -- 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) = "&rarr;"++replaceRightArrow xs
replaceRightArrow (x:xs)       = x : replaceRightArrow xs


-- Unfortunately, w3m does not understand <button>. 
-- mkButton sig expr body = "<button type='submit' name='predicate' value='(" ++  concatMap escapeQuote (filter (/='\n') (pprint expr)) ++ ") :: "++  sig  ++ "'>details</button>"++body ++ "<br>"
mkButton predStr sig expr body = "<FORM"++ (if isAbsent expr then " class='absent'" else "") ++"><input type='submit' value='Details'><input type=hidden name='predicate' value='" ++  concatMap escapeQuote predStr ++ "'><input type=hidden name='candidate' value='" ++ concatMap escapeQuote (pprnn expr) ++ " :: "++  sig  ++ "'> &nbsp;&nbsp;"++body++"</FORM>"
-- <FORM>でやる場合、 <br>をつけると改行しすぎ。


escapeQuote '\'' = "&apos;"
escapeQuote c    = [c]

annotateEverywhere = everywhere (mkT annotateName)

annotateFree :: [String] -> TH.Exp -> TH.Exp
annotateFree names v@(VarE name) | show name `elem` names = v
                                 | otherwise              = VarE $ annotateName name
annotateFree _     (ConE name)         = ConE $ annotateName name
annotateFree _     l@(LitE _)          = l
annotateFree names (AppE f e)          = annotateFree names f `AppE` annotateFree names e
annotateFree names (InfixE mbf op mbe) = InfixE (fmap (annotateFree names) mbf) (annotateFree names op) (fmap (annotateFree names) mbe)
annotateFree names (LamE pats e)       = LamE pats $ annotateFree (patsToNames pats names) e
annotateFree names (TupE es)           = TupE $ map (annotateFree names) es
annotateFree names (CondE b t f)       = CondE (annotateFree names b) (annotateFree names t) (annotateFree names f)
annotateFree names (ListE es)          = ListE $ map (annotateFree names) es
annotateFree names (SigE e t)          = SigE (annotateFree names e) t
annotateFree names e                   = annotateEverywhere e  -- bothered....

patsToNames []          = id
patsToNames (p:ps)      = patToNames p . patsToNames ps
patToNames (VarP name)    = (show name :)
patToNames (TupP ps)      = patsToNames ps
patToNames (ConP _ ps)    = patsToNames ps
patToNames (InfixP p _ q) = patsToNames [p,q]
patToNames (TildeP p)     = patToNames p
patToNames (AsP name p)   = (show name :) . patToNames p
patToNames (ListP ps)     = patsToNames ps
patToNames (SigP p _)     = patToNames p
patToNames _              = id


-- 名前の1文字目が記号だとbinary operator扱いになってカッコがついてしまうので．
annotateName :: TH.Name -> TH.Name
annotateName name = case nameBase name of nameStr@(c:cs) | isAlpha c                        -> mkName $ c : refLink nameStr cs
                                                         | c `elem` "=+!@#$%^&*-\\|:/?<>.~" -> mkName $ refLink nameStr $ stringToHtmlString nameStr
                                          _              -> name        -- special names like [] and ()
refLink nameStr body = "<a href=\""++refer nameStr ++ "\">" ++ body ++ "</a>"
refer str = case Data.Map.lookup str mapNameModule of Nothing -> referHoogle str
                                                      Just f  -> f str
mapNameModule :: Data.Map.Map String (String->String)
mapNameModule = Data.Map.fromList $
                mkAssoc "base" "Prelude"    preludeNameBases ++ 
                mkAssoc "base" "Data-List"  (primssToStrs fromDataList) ++
                mkAssoc "base" "Data-Char"  (primssToStrs fromDataChar) ++
                mkAssoc "base" "Data-Maybe" (primssToStrs fromDataMaybe)
mkAssoc package mod namebases = [ (str, referHackage package mod) | str <- namebases ]

preludeNameBases = ["iterate", "!!", "id", "$", "const", ".", "flip", "subtract", "maybe", "foldr", "zipWith"] ++   -- These are not included in the component library, but introduced by MagicHaskeller.LibTH.postprocess.
                   primssToStrs fromPrelude

primssToStrs = map TH.nameBase . primsToNames . concat
primsToNames  :: [Primitive] -> [TH.Name]
primsToNames ps = [ name | (_, VarE name, _) <- ps ] ++ [ name | (_, ConE name, _) <- ps ]
                  ++ [ name | (_, _ `AppE` VarE name, _) <- ps ] -- ad hoc approach to the (flip foo) cases:)

-- So far this should work:
referHackage package modulename str = "http://hackage.haskell.org/packages/archive/"++package++"/latest/doc/html/"++modulename++".html#v:"++hackageEncode str
hackageEncode cs@(a:_) | isAlpha a = cs
                       | otherwise = concatMap (\c -> '-' : shows (ord c) "-") cs

-- But this is more generic:)
referHoogle  str = "http://www.haskell.org/hoogle/?hoogle=" ++ escapeURIString isUnreserved str