{-# OPTIONS_GHC -fglasgow-exts -cpp -fallow-overlapping-instances #-}
{-|
External call utilities.
> To the Sea, to the Sea! The white gulls are crying,
> The wind is blowing, and the white foam is flying.
> West, west away, the round sun is falling.
> Grey ship, grey ship, do you hear them calling?
-}
module Pugs.External where
import Pugs.Internals
import Pugs.AST
import Pugs.External.Haskell (externalizeHaskell, loadHaskell)
externalize :: String -> Exp -> IO String
externalize mod stmts = externExternalize backend mod code
where
(backend, code)
| null things = error "no inline found"
| [_] <- things = head things
| otherwise = error "multiple inline found"
things = [ (backend, code)
| (Syn "inline" [Val (VStr backend), Val (VStr code)]) <- flatten stmts
]
flatten (Stmts cur rest) = (cur:flatten rest)
flatten exp = [exp]
externExternalize :: String -> String -> String -> IO String
externExternalize "Haskell" = externalizeHaskell
externExternalize backend = error $ "Unrecognized inline backend: " ++ backend
externLoad :: String -> FilePath -> IO [(String, [Val] -> Eval Val)]
externLoad "Haskell" = loadHaskell
externLoad backend = error $ "Unrecognized inline backend: " ++ backend
externRequire :: String -> FilePath -> Eval ()
externRequire lang name = do
glob <- asks envGlobal
bindings <- liftIO $ externLoad lang name
liftSTM $ do
newSyms <- mapM gen bindings
modifyTVar glob (\pad -> combine newSyms pad)
where
gen (name, fun) = genSym (cast ('&':name)) . codeRef $ mkPrim
{ subName = cast name
, subParams = [buildParam "List" "" "*@?1" (Val VUndef)]
, subBody = (Prim fun)
}