├── .gitignore ├── Example.hs ├── LICENSE ├── README.markdown ├── Setup.hs ├── ghcjs-ffiqq.cabal └── src └── GHCJS └── Foreign └── QQ.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | *.js_hi 3 | *.hi 4 | *.o 5 | *.js_o 6 | *.jsexe 7 | .fuse_hidden* 8 | *~ 9 | \#* 10 | .#* 11 | -------------------------------------------------------------------------------- /Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import Prelude hiding (log) 4 | import GHCJS.Foreign.QQ 5 | 6 | log :: String -> IO () 7 | log msg = [js_| console.log(`msg); |] 8 | 9 | delay :: Int -> IO () 10 | delay ms = [jsi_| setTimeout($c, `ms); |] 11 | 12 | plus :: Int -> Int -> Int 13 | plus x y = [js'| `x + `y |] 14 | 15 | main :: IO () 16 | main = do 17 | log "hello, world!" 18 | delay 1000 19 | print (1 `plus` 2) 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Luite Stegeman 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | This is an experimental QuasiQuoter for the GHCJS foreign function interface. It allows 2 | you to call JavaScript inline, with named parameters. The QuasiQuoter automatically 3 | splices the top-level foreign imports. 4 | 5 | The current version is not yet ready for production, since it uses experimental 6 | pure marshalling typeclasses. 7 | 8 | Example: 9 | 10 | ```haskell 11 | {-# LANGUAGE QuasiQuotes #-} 12 | 13 | import Prelude hiding (log) 14 | import GHCJS.Foreign.QQ 15 | 16 | log :: String -> IO () 17 | log msg = [js_| console.log(`msg); |] 18 | 19 | delay :: Int -> IO () 20 | delay ms = [jsi_| setTimeout($c, `ms); |] 21 | 22 | plus :: Int -> Int -> Int 23 | plus x y = [js'| `x + `y |] 24 | 25 | main :: IO () 26 | main = do 27 | log "hello, world!" 28 | delay 1000 29 | print (1 `plus` 2) 30 | ``` 31 | 32 | # todo 33 | 34 | - make marshalling safer and improve underlying infrastructure 35 | - add a good JavaScript parser with good error reporting 36 | - export a way to let users make custom QuasiQuoters, so they can choose their own marshalling, possibly based on types 37 | - support a combination of named arguments and positional placeholders so that all of these mean the same thing: 38 | 39 | ```haskell 40 | plus1, plus2, plus3 :: Int -> Int -> Int 41 | plus1 x y = [js'| `x + `y |] 42 | plus2 x = [js'| `x + $1 |] 43 | plus3 = [js'| $1 + $2 |] 44 | ``` 45 | 46 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ghcjs-ffiqq.cabal: -------------------------------------------------------------------------------- 1 | name: ghcjs-ffiqq 2 | version: 0.1.0.0 3 | synopsis: FFI QuasiQuoter for GHCJS 4 | license: MIT 5 | license-file: LICENSE 6 | author: Luite Stegeman 7 | maintainer: stegeman@gmail.com 8 | copyright: Luite Stegeman 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | flag build-example 14 | description: build the example program 15 | default: False 16 | manual: True 17 | 18 | library 19 | exposed-modules: GHCJS.Foreign.QQ 20 | build-depends: base >= 4.8 && < 5, 21 | template-haskell >= 2.10, 22 | ghcjs-base >= 0.2, 23 | split, 24 | containers, 25 | text, 26 | ghc-prim 27 | hs-source-dirs: src 28 | default-language: Haskell2010 29 | ghcjs-options: -O2 30 | 31 | Executable example 32 | if !flag(build-example) 33 | buildable: False 34 | Main-Is: Example.hs 35 | Default-Language: Haskell2010 36 | hs-source-dirs: . 37 | Build-Depends: base >= 4 && < 5, 38 | ghcjs-ffiqq 39 | GHC-Options: -O -Wall 40 | -------------------------------------------------------------------------------- /src/GHCJS/Foreign/QQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, TemplateHaskell, DeriveDataTypeable #-} 2 | {-# LANGUAGE MagicHash, UnboxedTuples #-} 3 | 4 | {- | An experimental quasiquoter for more convenient FFI 5 | 6 | This is mostly a demonstration of the approach, not production ready! 7 | -} 8 | 9 | module GHCJS.Foreign.QQ (js, js', js_, jsu, jsu', jsu_, jsi, jsi', jsi_) where 10 | 11 | import Control.Applicative 12 | 13 | import Data.Char 14 | import Data.List.Split 15 | import qualified Data.List as L 16 | import qualified Data.Map as M 17 | import Data.Maybe 18 | import Data.Typeable 19 | 20 | import Language.Haskell.TH.Quote 21 | import Language.Haskell.TH.Syntax 22 | import Language.Haskell.TH 23 | 24 | import GHCJS.Types 25 | import GHCJS.Marshal.Pure 26 | 27 | -- result: PFromJSVal a => IO a 28 | js :: QuasiQuoter 29 | js = mkFFIQQ False True Safe 30 | 31 | -- result: PFromJSVal a => a 32 | js' :: QuasiQuoter 33 | js' = mkFFIQQ False False Safe 34 | 35 | -- result: IO () 36 | js_ :: QuasiQuoter 37 | js_ = mkFFIQQ True True Safe 38 | 39 | -- result: PFromJSVal a => IO a 40 | jsu :: QuasiQuoter 41 | jsu = mkFFIQQ False True Unsafe 42 | 43 | -- result: PFromJSVal a => a 44 | jsu' :: QuasiQuoter 45 | jsu' = mkFFIQQ False False Unsafe 46 | 47 | -- result: IO () 48 | jsu_ :: QuasiQuoter 49 | jsu_ = mkFFIQQ True True Unsafe 50 | 51 | -- result: PFromJSVal a => IO a 52 | jsi :: QuasiQuoter 53 | jsi = mkFFIQQ False True Interruptible 54 | 55 | -- result: PFromJSVal a => a 56 | jsi' :: QuasiQuoter 57 | jsi' = mkFFIQQ False False Interruptible 58 | 59 | -- result: IO () 60 | jsi_ :: QuasiQuoter 61 | jsi_ = mkFFIQQ True True Interruptible 62 | 63 | mkFFIQQ :: Bool -> Bool -> Safety -> QuasiQuoter 64 | mkFFIQQ isUnit isIO s = QuasiQuoter { quoteExp = jsExpQQ isUnit isIO s } 65 | 66 | newtype QQCounter = QQCounter { getCount :: Int } deriving (Typeable, Show) 67 | 68 | jsExpQQ :: Bool -> Bool -> Safety -> String -> Q Exp 69 | jsExpQQ isUnit isIO s pat = do 70 | c <- maybe 0 getCount <$> qGetQ 71 | n <- newName ("__ghcjs_foreign_qq_spliced_" ++ show c) 72 | let (p:ps) = linesBy (=='`') pat 73 | isNameCh c = isAlphaNum c || c `elem` "_" 74 | names = L.nub (map (takeWhile isNameCh) ps) 75 | nameMap = M.fromList $ zip names [1..] 76 | ffiDecl = ForeignD (ImportF JavaScript s pat' n (importTy returnTy (length names) [])) 77 | importTy :: Type -> Int -> [Name] -> Type 78 | importTy t n xs = fst (importTy' t n xs) 79 | importTy' :: Type -> Int -> [Name] -> (Type, [Name]) 80 | importTy' t 0 xs = (t,xs) 81 | importTy' t n xs = 82 | let v = mkName ('b':show n) 83 | (t', xs') = importTy' t (n-1) xs 84 | in (AppT (AppT ArrowT (ConT ''JSVal)) t', v:xs') 85 | convertRes r | isUnit = r 86 | | isIO = AppE (AppE (VarE 'fmap) (LamE [VarP $ mkName "l"] (uref (VarE (mkName "l"))))) r 87 | | otherwise = uref r 88 | where uref r = AppE (VarE 'pFromJSVal) r 89 | ffiCall = convertRes (ffiCall' (VarE n) names) 90 | ffiCall' x [] = x 91 | ffiCall' f (x:xs) = ffiCall' (AppE f (toJSValE x)) xs 92 | toJSValE n = AppE (VarE 'pToJSVal) (VarE $ mkName n) 93 | jsRefT v = ConT ''JSVal 94 | returnTy = let r = if isUnit then ConT ''() else ConT ''JSVal 95 | in if isIO then AppT (ConT ''IO) r else r 96 | pat' = p ++ concatMap (\nr -> let (n,r) = break (not . isNameCh) nr in namePl n ++ r) ps 97 | namePl n = '$':show (fromJust (M.lookup n nameMap)) 98 | qAddTopDecls [ffiDecl] 99 | qPutQ (QQCounter (c+1)) 100 | return ffiCall 101 | 102 | 103 | --------------------------------------------------------------------------------