module Text.ParserCombinators.PArrow.ToJavaScript
(JSCompiler, JSFun, newJSCompiler, compileJS, dumpBodies
) where
import Control.Monad.State
import Data.IORef
import Data.List (intersperse)
import GHC.Prim (unsafeCoerce#)
import qualified Data.IntMap as I
import System.Mem.StableName
import Text.ParserCombinators.PArrow.MD (MD(..))
newtype JSFun = JSFun Int
newtype JSCompiler = JSC (IORef JSCompState)
type JSComp a = StateT JSCompState IO a
data INVALID = INVALID
type SN = StableName (MD INVALID INVALID)
data JSCompState = JSCompState { bodies :: I.IntMap String,
defs :: I.IntMap [(SN,JSFun)],
count :: Int,
prefix :: String
}
newJSCompiler :: String -> IO (JSCompiler, JSFun -> String)
newJSCompiler pref = do c <- newIORef (JSCompState I.empty I.empty 1 pref)
return (JSC c, \(JSFun i) -> pref++show i)
compileJS :: JSCompiler -> MD i o -> IO JSFun
compileJS (JSC jsc) p = do s <- readIORef jsc
(v,s') <- runStateT (toJavaScriptJSFun p) s
writeIORef jsc s'
return v
dumpBodies :: JSCompiler -> IO [(JSFun,String)]
dumpBodies (JSC jsc) = readIORef jsc >>= return . map (\(a,b) -> (JSFun a,b)) . I.toList . bodies
toJavaScriptSingle :: JSFun -> MD i o -> JSComp String
toJavaScriptSingle n (MEqual ch) = cfun n ["{return (s.charAt(i)==",show ch,")?i+1:-1}"]
toJavaScriptSingle n (MEmpty) = cfun n ["{return i}"]
toJavaScriptSingle n (MPure _ _) = toJavaScriptSingle n MEmpty
toJavaScriptSingle n (MSeq a b) = do af <- toJavaScriptFunRef a
bf <- toJavaScriptFunRef b
cfun n ["{return ",bf,"(s,",af,"(s,i))}"]
toJavaScriptSingle n (MCSet cs) = cfun n ["{return (s.charAt(i).search(/^",show cs,"/)!=-1?i+1:-1)}"]
toJavaScriptSingle n (MStar p) = do pf <- toJavaScriptFunRef p
cfun n ["{for(j=i;j>=0;){i=j;j=",pf,"(s,j)}return i}"]
toJavaScriptSingle n (MChoice cs)= do rfs <- mapM toJavaScriptFunRef cs
cfun n ["{a=[",concat (intersperse "," rfs),"];",
"for(j=0;j<a.length;j++){",
"r=a[j](s,i);if(r>=0){return r}}",
"return -1}"]
toJavaScriptSingle n (MJoin a b) = do af <- toJavaScriptFunRef a
bf <- toJavaScriptFunRef b
cfun n ["{return ",bf,"(s,",af,"(s,i))}"]
toJavaScriptSingle n (MNot p) = do pf <- toJavaScriptFunRef p
cfun n ["{return (",pf,"(s,i)>=0?-1:i)}"]
cfun :: JSFun -> [String] -> JSComp String
cfun n lst = do cn <- jsFunName n
return $ concat ("function ":cn:"(s,i) ":lst)
jsFunName :: (MonadState JSCompState m) => JSFun -> m String
jsFunName (JSFun v) = gets prefix >>= \e -> return (e ++ show v)
toJavaScriptFunRef :: MD i o -> JSComp String
toJavaScriptFunRef p = toJavaScriptJSFun p >>= jsFunName
toJavaScriptJSFun :: MD i o -> JSComp JSFun
toJavaScriptJSFun p = do
cache <- gets defs
psn <- makeSN p
case I.lookup (hashStableName psn) cache >>= lookup psn of
Nothing -> insertFunRef psn p
Just x -> return x
insertFunRef :: SN -> MD i o -> JSComp JSFun
insertFunRef psn p = do
ci <- gets count
modify (\s -> s { defs = I.insertWith (++) (hashStableName psn) [(psn,JSFun ci)] (defs s), count = ci+1 })
pval <- toJavaScriptSingle (JSFun ci) p
modify (\s -> s { bodies = I.insert ci pval (bodies s) })
return (JSFun ci)
makeSN :: MD i o -> JSComp SN
makeSN md = liftIO (unsafeCoerce# (makeStableName md))