Rlang-QQ 0.0.0.2 → 0.1.0.0
raw patch · 29 files changed
+1815/−110 lines, 29 filesdep +HListdep +MaybeTdep +arraydep ~basebinary-added
Dependencies added: HList, MaybeT, array, binary, doctest, haskell-src-meta, mtl, repa, syb, temporary, text, vector, zlib
Dependency ranges changed: base
Files
- Rlang-QQ.cabal +22/−5
- doctests.hs +7/−0
- examples/romberg.hs +124/−0
- examples/runexamples.hs +58/−0
- examples/test.hs +1/−0
- examples/test.png binary
- examples/test2.hs +25/−0
- examples/test2.ref +2/−0
- examples/test3.hs +16/−0
- examples/test3.ref +1/−0
- examples/test3_lens.hs +18/−0
- examples/test3_lens.ref +1/−0
- examples/test4.hs +52/−0
- examples/test4.ref +8/−0
- examples/test5.hs +31/−0
- examples/test5.ref +4/−0
- examples/test6.Rmd +25/−0
- examples/test7.Rmd +45/−0
- examples/test_alt.hs +14/−0
- rsrc/Tree.R +1/−1
- rsrc/parseTreeExample.R +2/−0
- src/HListExtras.hs +86/−0
- src/RlangQQ.hs +190/−24
- src/RlangQQ/Antiquote.hs +32/−0
- src/RlangQQ/Binary.hs +651/−0
- src/RlangQQ/FN.hs +24/−0
- src/RlangQQ/Internal.hs +315/−80
- src/RlangQQ/MakeRecord.hs +30/−0
- src/RlangQQ/NatQQ.hs +30/−0
Rlang-QQ.cabal view
@@ -1,5 +1,5 @@ name: Rlang-QQ-version: 0.0.0.2+version: 0.1.0.0 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -8,14 +8,17 @@ homepage: http://code.haskell.org/~aavogt/Rlang-QQ synopsis: quasiquoter for inline-R code description: This quasiquoter calls R (<http://www.r-project.org/>) from ghc.- Variables from the haskell-side are passed in. In the future,- variables created (or modified) could be returned as the value+ Variables from the haskell-side are passed in, and+ variables created (or modified) are returned as the value of the quasiquote. category: Development author: Adam Vogt <vogt.adam@gmail.com> data-dir: rsrc data-files: Tree.R parseTreeExample.R-extra-source-files: examples/test.hs+extra-source-files: examples/*.hs,+ examples/*.Rmd,+ examples/*.ref+ examples/*.png source-repository head type: darcs@@ -27,13 +30,27 @@ build-depends: base ==4.*, containers, template-haskell ==2.8.*, directory, process, trifecta ==1.1.*, utf8-string ==0.3.*, bytestring,- Cabal+ Cabal, syb, mtl, MaybeT,+ binary, vector, HList >= 0.3, temporary,+ text, array, zlib, repa,+ haskell-src-meta exposed-modules: RlangQQ.Internal+ RlangQQ.Binary+ RlangQQ.Antiquote+ RlangQQ.FN+ RlangQQ.NatQQ+ RlangQQ.MakeRecord RlangQQ+ HListExtras other-modules: Paths_Rlang_QQ exposed: True buildable: True +test-suite doctests+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: doctests.hs+ build-depends: base, doctest >= 0.8
+ doctests.hs view
@@ -0,0 +1,7 @@+import Test.DocTest+main = doctest $ "-isrc": "-idist/build/autogen":+ "examples/test2.hs":+ "examples/test4.hs":+ "examples/test5.hs":+ "src/RlangQQ.hs":+ []
+ examples/romberg.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE QuasiQuotes #-}++-- | example comparing the convergence of <http://en.wikipedia.org/wiki/Romberg's_method romberg integration>+-- in terms of the built-in error estimate as well as an \"exact\" solution ("Data.Number.CReal")+--+-- originally submitted to uwaterloo's CHE 322. Adapted plot to be done+-- with R.+module Main where++import Data.Number.CReal+import Data.List+import Data.Typeable+import RlangQQ++import Data.HList.CommonMain+import Control.Monad.State+import Data.Int+++main = do+ mkPlt 22 (1 :: Double)+ mkPlt 22 (1 :: Float)+++-- number of traces on the plots+-- ie. 1 = trapezoid only, 2 = trapezoid + simpsons+-- 3 = trapezoid + simpsons + simpsons 3/8+-- 4 = ...+nTraces = [n| 5 |]++mkPlt nMax proxy =+ let exact = exp 10 - 1+ calc = rombM exp 0 10+++ xs = listToRecN nTraces $ map (take nMax . map (\x -> toDouble $+ abs (tfr x - exact) / exact))+ (calc `asTypeOf` [[proxy]])+ es = listToRecN nTraces $ (map (take nMax . map tfr) $ getRombErr calc :: [[Double]])++ outputfile = "romberg_" ++ show (typeOf proxy) ++ ".pdf"++ ls = [1 .. hNat2Integral nTraces :: Int32]+ ns = [1 .. fromIntegral nMax :: Double]++ in+ [r|++ library(lattice); library(reshape); library(plyr);++ conv <- function(hsvar) { # should be a better way to get a data.frame+ x <- data.frame(hsvar)+ names(x) <- hs_ls+ x <- ddply(melt(x), .(variable), function(x)+ data.frame(x, refinements = hs_ns ))+ within(x, refinements <- as.integer(variable) + refinements)+ }++ es <- conv(hs_es)+ xs <- conv(hs_xs)++ pdf(hs_outputfile)++ plot(xyplot( value ~ refinements, xs, groups = variable,+ scales= list(y=list(log=T),x=list(log=T)), type='l',+ ylab='error', auto.key=list(title='order', type='l',+ columns= hs_ls[length(hs_ls)] ),+ main = hs_outputfile))++ plot(xyplot( xs$value ~ es$value, groups=xs$variable, type='b',+ scales=list(x=list(log=T), y=list(log=T)),+ ylab='actual error',+ xlab='estimated error',+ panel= function(...){+ panel.xyplot(...)+ panel.abline(a=0, b=1, col='black')+ }))++ dev.off()++ |]++++-- | trapezoid rule. doesn't reuse previous values+trap f a b n =+ let h = (b - a) / fromIntegral n+ xs = take (n-1) $ iterate (h+) (a+h)+ -- easier to see as [a+h, a+2*h .. b-h])+ -- but some interval arithmetic doesn't support [a..b]+ in h * (foldl' (\s x -> s + f x) ((f a + f b) / 2) xs)++rombM f a b =+ let is = map (\n -> trap f a b (2^n)) [0..]+ in map snd+ $ iterate+ (\(n,s) -> (n+1, zipWith (improve n) (tail s) s))+ (2,is)++romb f a b = map head $ rombM f a b++improve n x y = let c = 4^(n-1) in (c*x - y) / (c - 1)++getRombErr a = unStripe . map (\x -> zipWith (\a b -> abs (a - b)) x (tail x))+ $ stripe a++-- shorthand conversions+tfr x = fromRational (toRational x)+toDouble x = read (showCReal 100 x) :: Double+++-- succesful with infinite stripes only+unStripe ss = unfoldr (\xs -> case unzip (map (splitAt 1) xs) of+ (a,b) -> Just (concat a, b))+ ss++-- stolen from Control.Monad.Omega+stripe [] = []; stripe ([]:xss) = stripe xss+stripe ((x:xs):xss) = [x] : zipCons xs (stripe xss)++zipCons [] ys = ys; zipCons xs [] = map (:[]) xs+zipCons (x:xs) (y:ys) = (x:y) : zipCons xs ys++
+ examples/runexamples.hs view
@@ -0,0 +1,58 @@+-- same test runner as in HList+module Main where++import Control.Exception+import System.FilePath+import Test.Hspec+import System.Process+import System.Exit+import System.Directory+import Data.Maybe+import Control.Monad+import Control.Applicative++main = do++ es <- getDirectoryContents "examples"+++ print es+ -- very dumb+ es <- filterM (\e -> allM+ [return (takeExtension e == ".hs"),+ doesFileExist (dropExtension ("examples"</>e) ++ ".ref") ]) es++ print es++ hspec $ do+ mapM_ runghcwith es+++runghcwith f = describe f $ it "ok" $ checkResult $+ do+ let ex = ("examples" </>)+ let inFile = ex (takeBaseName f)+ outFile = dropExtension inFile ++ ".out"+ refFile = dropExtension inFile ++ ".ref"++ (ec, stdout, stderr) <- readProcessWithExitCode "cabal" ["repl","-v0",+ "--ghc-options", "-w -fcontext-stack=50 -iexamples -v0 "]+ (":set -package lens\n:load " ++ inFile ++ "\nmain")++ writeFile outFile stdout++ ofe <- doesFileExist refFile+ diff <- if ofe then fmap Just $+ readProcess "diff" ["-b", outFile, refFile] "" else return Nothing++ return (ec, stderr, diff)+ where+ checkResult io = blankStdout io `shouldReturn` (ExitSuccess, (), Just "")+ blankStdout x = fmap (\(a,b,c) -> (a, (), c)) x++++allM [] = return True+allM (x:xs) = do+ x <- x+ if x then allM xs else return False
examples/test.hs view
@@ -7,6 +7,7 @@ main = do [r| library(ggplot2)+ print('blahh') png(file='test.png') plot(qplot( hs_x, hs_y )) dev.off()
+ examples/test.png view
binary file changed (absent → 8518 bytes)
+ examples/test2.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+module Main where+import RlangQQ+import Data.HList+++x = [0 .. 10 :: Double]+y = map (sin . (*pi) . (/10)) x+++test = [r| print('hi'); hs_z <- hs_x + hs_y |]++test2 = fmap (.!. (Label :: Label "z")) test++test3 = print =<< (test2 :: IO [Double])+++main = do+ test3+ let hs = zipWith (+) x y+ let sse x y = sum $ zipWith (\a b -> (a-b)^2) x y+ fmap (sse hs) test2
+ examples/test2.ref view
@@ -0,0 +1,2 @@+[0.0,1.3090169943749475,2.5877852522924734,3.8090169943749475,4.951056516295154,6.0,6.951056516295154,7.8090169943749475,8.587785252292473,9.309016994374948,10.0]+0.0
+ examples/test3.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Main where+import RlangQQ+import GHC.TypeLits++makeLabels6 (words "x y z")++inRec = x .=. "xlabel" .*. y .=. [1,2,3::Double] .*. z .=. [3,2,1 :: Double] .*. emptyRecord++-- fixity is bad for .!. see test3_lens.hs for something better?+main = do+ o <- [r|+ print(hs_inRec)+ hs_inRec <- within(hs_inRec, y <- y + z) |]+ print ((o .!. (Label :: Label "inRec")) .!. y)
+ examples/test3.ref view
@@ -0,0 +1,1 @@+[4.0,4.0,4.0]
+ examples/test3_lens.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Main where+import RlangQQ+import GHC.TypeLits+import Control.Lens++makeLabelable "x y z"++inRec = x .==. "xlabel" .*. y .==. [1,2,3::Double] .*. z .==. [3,2,1 :: Double] .*. emptyRecord++main = do+ o <- [r|+ print(hs_inRec)+ hs_inRec <- within(hs_inRec, y <- y + z) |]+ let inR = hLens' (Label :: Label "inRec")+ print (o ^.inR.y)
+ examples/test3_lens.ref view
@@ -0,0 +1,1 @@+[4.0,4.0,4.0]
+ examples/test4.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds, TemplateHaskell, QuasiQuotes #-}+module Main where+import RlangQQ+import GHC.TypeLits -- ghc7.6 workaround+import Control.Monad++makeLabels6 (words "x y z")++inRec = x .=. "xlabel" .*. y .=. [1,2,3::Double] .*. z .=. [3,2,1 :: Double] .*. emptyRecord++inRecL = Label :: Label "inRec"++{- $test++note that the same R-session is run for all calls to f1,+that is why the results differ between f1 and f2:++>>> f1+[5.0,5.0,5.0]+[10.0,9.0,8.0]+[16.0,14.0,12.0]+[23.0,20.0,17.0]+++>>> f2+[5.0,5.0,5.0]+[6.0,6.0,6.0]+[7.0,7.0,7.0]+[8.0,8.0,8.0]++-}+f1 = do++ w <- newRChan++ [r| # this shouldn't be necessary to force INOUT+ print(hs_inRec)+ hs_inRec <- within(hs_inRec, y <- y + z + ch_w) |]+++ forM_ [1,2,3,4 :: Double] $ \n -> do+ o' <- sendRcv w n+ print ((o' .!. inRecL) .!. y)++f2 = forM_ [1,2,3,4 :: Double] $ \n -> do+ o' <- [r| # this shouldn't be necessary to force INOUT+ print(hs_inRec)+ hs_inRec <- within(hs_inRec, y <- y + z + hs_n) |]+ print ((o' .!. inRecL) .!. y)+++main = do f1;f2
+ examples/test4.ref view
@@ -0,0 +1,8 @@+[5.0,5.0,5.0]+[10.0,9.0,8.0]+[16.0,14.0,12.0]+[23.0,20.0,17.0]+[5.0,5.0,5.0]+[6.0,6.0,6.0]+[7.0,7.0,7.0]+[8.0,8.0,8.0]
+ examples/test5.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds, TemplateHaskell, QuasiQuotes #-}+module Main where+import RlangQQ+import GHC.TypeLits -- ghc7.6 workaround+import Control.Monad++makeLabels6 (words "x y z")++inRec = x .=. "xlabel" .*. y .=. [1,2,3::Double] .*. z .=. [3,2,1 :: Double] .*. emptyRecord++inRecL = Label :: Label "inRec"++f2 = forM_ [1,2,3,4 :: Double] $ \n -> do+ o' <- [r| # this shouldn't be necessary to force INOUT+ print(hs_inRec)+ hs_inRec <- within(hs_inRec, y <- y + z + $(n+1) ) |]+ print ((o' .!. inRecL) .!. y)+++{- $output+++>>> f2+[6.0,6.0,6.0]+[7.0,7.0,7.0]+[8.0,8.0,8.0]+[9.0,9.0,9.0]++-}++main = f2
+ examples/test5.ref view
@@ -0,0 +1,4 @@+[6.0,6.0,6.0]+[7.0,7.0,7.0]+[8.0,8.0,8.0]+[9.0,9.0,9.0]
+ examples/test6.Rmd view
@@ -0,0 +1,25 @@+# test 6+This file can be loaded into whatever editor you like to use for knitr. ghc is called for the second code block.++```{r engine='R'}+library(knitr)+opts_chunk$set(engine='haskell', engine.path='ghc')+```++```{r engine='haskell'}+:set -XQuasiQuotes+:module +RlangQQ+let fibs = 0.0:1: zipWith (+) fibs (drop 1 fibs)+[r| png('test6_fig1.png'); plot(1:20, $(take 20 fibs)); dev.off() |]+```++++## limitations++* This simple example works but unfortunately the haskell knitr engine doesn't allow newlines instead of semicolons in the quasiquote (`[r| |]`)+* Also note a comment from here <http://yihui.name/knitr/demo/engines/>:++ Except engine='R' (default), all chunks are executed in separate sessions, so the variables cannot be directly shared. If we want to make use of objects created in previous chunks, we usually have to write them to files (as side effects). For the bash engine, we can use Sys.setenv() to export variables from R to bash (example).++* Graphical output from haskell chunks has to be manually included.
+ examples/test7.Rmd view
@@ -0,0 +1,45 @@+# test 7+Same as test6, except needs a change to knitr as of October 2013 (ie. 1.5 is not good enough). [This commit is needed](https://github.com/yihui/knitr/pull/633).++This file can be loaded into whatever editor you like to use for knitr. I +use [vim-r-plugin](http://www.vim.org/scripts/script.php?script_id=2628), but+perhaps ESS or Rstudio can also work. After some set-up in the first block. ghc is called for the second code block.++```{r engine='R'}+library(knitr)+opts_chunk$set(engine='haskell', engine.path='ghc',+ engine.opts='-e ":set -XQuasiQuotes" -e "import RlangQQ"')++```+++```{r}++let fibs = 0.0:1: zipWith (+) fibs (drop 1 fibs)++[r| png('test6_fig1.png')+ plot(1:20, $(take 20 fibs))+ dev.off() |]++```++```{r}++do let x = 1+ print(1+x)+ print(2+x)++```++++## limitations++* each block is a separate session. You would have to manually save/load variables defined in the previous chunk to make things work as they do for R.++* code is interpreted, not compiled++* graphical output from haskell chunks has to be manually included++## raw code+See [here](test7.Rmd.html)
+ examples/test_alt.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE QuasiQuotes #-}+import RlangQQ++x = [0 .. 10 :: Double]++main = do+ [r|+ library(ggplot2)+ print('blahh')+ png(file='test.png')+ plot(qplot( hs_x, $( map (sin . (*pi) . (/10)) x) ))+ dev.off()+ |]+
rsrc/Tree.R view
@@ -1,5 +1,5 @@ -rlangQQ_show <- function(x) paste("'",gsub("'","\\\\'", x),"'", sep='')+rlangQQ_show <- function(x) paste("'",gsub("'","\\\\'", x, fixed=T),"'", sep='') rlangQQ_toTree <- function(e) if (is.symbol(e)) paste('Node', rlangQQ_show(e), '[]') else {
rsrc/parseTreeExample.R view
@@ -4,3 +4,5 @@ d$x+d$y ++stringSample <- 'hi \' \there " '
+ src/HListExtras.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}++module HListExtras where+import Data.HList.CommonMain+++data FApply = FApply+instance (ApplyAB f a b, ab ~ (a -> b)) => ApplyAB FApply f ab where+ applyAB _ = applyAB++class HReplicate2 (n ::HNat) e l | n e -> l, l -> n+ where hReplicate2 :: Proxy n -> e -> HList l+instance HReplicate2 HZero e '[] where+ hReplicate2 _ _ = HNil+instance (HReplicate2 n e es') => HReplicate2 (HSucc n) e (e ': es') where+ hReplicate2 n e = e `HCons` hReplicate2 (hPred n) e++-- hReplicateApp :: HReplicate2 (HLength r) e r' => e -> HList r+hReplicateApp e = let r = hMap FApply (hReplicate2 (hLength r) e) in r++-- | splitAt+hSplitAt n xs = hSplitAtAux n xs HNil++class HSplitAtAux (n :: HNat) l a0 a b | n -> l a0 a b where+ hSplitAtAux :: Proxy n -> HList l -> HList a0 -> (HList a, HList b)++instance (l ~ b, a ~ HRevApp a0 '[]) => HSplitAtAux HZero l a0 a b where+ hSplitAtAux _ l acc = (hReverse acc, l)++instance ( (x ': xs) ~ ls, acc' ~ (x ': acc),+ HSplitAtAux n xs acc' a b) => HSplitAtAux (HSucc n) ls acc a b where+ hSplitAtAux n (HCons x xs) acc = hSplitAtAux (hPred n) xs (HCons x acc)+++hEnumFromTo :: Proxy a -> Proxy b -> Proxy (HEnumFromTo a b)+hEnumFromTo a b = proxy++-- | [n1 .. n1 + n2]++type family HEnumFromTo (from::HNat) (to::HNat) :: [HNat]+type instance HEnumFromTo a HZero = '[a]+type instance HEnumFromTo a (HSucc b) = a ': HEnumFromTo (HSucc a) b+++-- this doesn't work any better... want ghc to be able to simplify+-- that (hReverse (hReverse x) `asTypeOf` x)+class (SameLength a b, SameLength b a) => HReverse2 a b | a -> b, b -> a where+ hReverse2 :: HList a -> HList b++instance (SameLength a b, SameLength b a, HRevApp a '[] ~ b, HRevApp b '[] ~ a) => HReverse2 a b where+ hReverse2 = hReverse+++class HMap1 f a b where hMap1 :: f -> HList a -> HList b++instance (a ~ '[]) => HMap1 f a '[] where+ hMap1 _ _ = HNil++instance (ApplyAB f a b, (a ': as) ~ aas, HMap1 f as bs) =>+ HMap1 f aas (b ': bs) where+ hMap1 f (HCons a as) = HCons (applyAB f a) (hMap1 f as)+++class HMap2 f a b where hMap2 :: f -> HList a -> HList b++instance (a ~ '[]) => HMap2 f '[] a where+ hMap2 _ _ = HNil++instance (ApplyAB f a b, (b ': bs) ~ bbs, HMap2 f as bs) =>+ HMap2 f (a ': as) bbs where+ hMap2 f (HCons a as) = HCons (applyAB f a) (hMap2 f as)+
src/RlangQQ.hs view
@@ -1,53 +1,219 @@-{- | A quasiquoter to help with calling R (<http://www.r-project.org/>) from ghc.+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{- | A quasiquoter to help with calling <http://www.r-project.org/ R> from ghc. -} module RlangQQ ( -- * the quasiquoter- r,+ r, rChan, - ToRVal,+ -- ** conversion of values+ -- $note+ -- values passed to R and returned by it should have types in these classes+ ToRDS, FromRDS, + -- ** records+ -- $records+ listToRecN,+ n,++ -- ** connecting to a single R session+ -- $chans+ newRChan, newRChan', sendRcv,++ module Data.HList.CommonMain,++ -- for ghc bug regarding lookupVers2+ module GHC.TypeLits,+ -- ** TODO -- $TODO ) where +import RlangQQ.Binary (ToRDS, FromRDS) import RlangQQ.Internal+import RlangQQ.MakeRecord+import RlangQQ.NatQQ import Language.Haskell.TH.Quote +import Data.HList.CommonMain -{- $TODO+import GHC.TypeLits -[R -> haskell] -Currently nothing is done to the output. It should be possible to return the-original hs_foo variables in an extensible record, (possibly limited to the-case where they have been modified?).+import Control.Concurrent -ie.if there is a @[r| hs_foo <- \"abc\" |]@, then at the very bottom of the-generated R file we should have be calling an R function like-@serialize(hs_foo)@. then on the haskell side we have: -> return (label foo $ deserialize "hs_foo" `asTypeOf` hs_foo,-> label abc $ deserialize "hs_abc" `asTypeOf` hs_abc,-> ... ) -Where the tuple is an extensible record, and the IO needed to-get the result is also sequenced. -Variables whose first occurence is an assignment do not need a corresponding-variable to be sent into R:+{- | Calls R with the supplied string. Variables in R prefixed hs_ cause+the corresponding (un-prefixed) variable to be converted. The variable(s) must+be in at least one class 'FromRDS' or 'ToRDS'. Currently the relation between+where variables are used and assigned to (using @<-@) determines the 'Intent'. -> [r| hs_x <- rnorm(5); hs_x <- sum(hs_x) |]+Expressions are also supported. These must be text between $( ), just like template+haskell. One condition is that the contents between the parentheses must be+parseable by haskell-src-meta/haskell-src-exts. So if you find the hs_ notation unpleasant+you can still interpolate using $(x). +An example of both styles is -[better IPC]+> {-# LANGUAGE QuasiQuotes #-}+> import RlangQQ+>+> x = [0 .. 10 :: Double]+>+> main = do+> [r|+> library(ggplot2)+> png(file='test.png')+> plot(qplot( hs_x, $(map (sin . (*pi) . (/10)) x) ))+> dev.off()+> |] -perhaps communicating through files is not the best idea. When there are-multiple quasi quotes, maybe they should be connecting to the same session.+You get a plot: <<http://code.haskell.org/~aavogt/Rlang-QQ/examples/test.png>> -Marshalling other types (Vector, Array, Map etc.).+While it is only somewhat usable, you can have Rnw/Rmd documents (knitr) that+include haskell code. One example is given+<http://code.haskell.org/~aavogt/Rlang-QQ/examples/test7.html here> -Use 'FromRVal'+-}+r = QuasiQuoter { quoteExp = \s -> do+ n <- getRlangQQ_n+ quoteRExpression2 n False ("print('');"++ s)+ -- the first expression gets dropped somewhere else+ -- this hack is easiest+ } ++-- | same as @[rChan| |]@ does the same as [r| |], except the+-- return value will be a @Chan (Record a)@.+rChan = QuasiQuoter { quoteExp = \s -> do+ n <- getRlangQQ_n+ quoteRExpression2 n True ("print('');"++ s)+ -- the first expression gets dropped somewhere else+ -- this hack is easiest+ }++{- $records++If the quasiquote assigns to variables @hs_x@ and @hs_y@, the result type will+be @IO (Record '[LVPair "x" x, LVPair "y" y])@. The types @x@ and @y@ have to be+determined on the haskell side. Here is a complete example:++>>> :set -XQuasiQuotes -XDataKinds -XNoMonomorphismRestriction+>>> let x = [2 :: Double]+>>> let q = [r| hs_y <- 1 + hs_x; hs_z <- 2 |]++These labels could be generated by template haskell with @$(makeLabels6 (words \"y z\"))@++>>> let y = Label :: Label "y"+>>> let z = Label :: Label "z"++>>> do o <- q; print (o .!. y ++ o .!. z :: [Double])+[3.0,2.0]+ -} ++{- $chans++Variables like @ch_x@ @ch_longVariableName@ inside the quasiquote generate references+to @x@ and @longVariableName@. These variables should have type @'Chan' (a, b -> 'IO' '()')@.+'newChan' can produce values of that type, but some versions with restricted+types are provided:++> do+> x <- newRChan+> longVariableName <- newRChan' (undefined :: Double)++The whole input to R is re-sent each time whenever a whole set of ch_ variables+is available. <http://code.haskell.org/~aavogt/Rlang-QQ/examples/test4.hs examples/test4.hs> has an a working example shows that+keeping the same R-session open is much faster, but that results may be confusing+since nothing explicitly says (besides this documentation here) that the same code+is re-sent.++-}+++-- | 'newChan' with a more restricted type+newRChan = newRChan' undefined++-- | @newRChan (undefined :: Double)@ produces an even more restricted type than+-- 'newRChan'', which can help make type errors more sensible and/or avoid+-- @ambiguous type variable@+newRChan' proxy = newChan `asTypeOf` r proxy+ where+ r :: a -> IO (Chan (a, b -> IO ()))+ r _ = undefined++-- | @y <- sendRcv c x@ sends the value @x@ using the chan @c@.+-- Provided that an @[r| |]@ quasiquote above refers to a @ch_c@,+-- the call to 'sendRcv' will eventually produce a 'Record' @y@+sendRcv :: Chan (t, b -> IO ()) -> t -> IO b+sendRcv ch e = do+ v <- newEmptyMVar+ writeChan ch (e, putMVar v)+ takeMVar v+++{- $TODO++[@debugging@] Write file that can be run to loading a quote into R interpreter+(ie the same thing as readProcess "R" "--no-save" ...). For now it's pretty+simple to just cd Rtmp and load/source things.+also, return R's stdout / stderr / exitcode in the HList. This won't be practical+for the Chan option since the stdout is getting consumed?++[@more examples@] conversion both ways etc.++[@read NULL as Maybe?@]++[@more datatypes@] support things like ??, ...++[@call R functions as if they were defined in haskell@]+This can be achievede already by doing something like++> x <- newRChan+> [r| hs_f <- ch_x + 1 |]+> let f :: Double -> IO Double+> f xVal = (.!. (Label :: Label "f")) `fmap` sendRcv x xVal++But perhaps something can be done to generate the above code from something+much shorter like:++> [r| hs_f <- function(x) x + 1 |]++Can this be made to work without looking at whether there is a function() after the <-?++++[@call hs functions as if they were defined in R@]+we might like to be able to have values like @f x = x + 1@+be callable by.++[@use libR.so@]+there is a <http://hackage.haskell.org/package/hR-0.1.1 hR package> which might+allow usage similar to hslua (ie. calling individual R functions)++one drawback is that it uses lists for vectors...++[@static analysis@]+(optionally?) call something like codetools on the generated R code+to infer result/argument types. Or perhaps translate R code into+some constraints:++> class RApp (x :: [*]) r++> instance (UpcastNumR a b ~ r, UpcastNumR b a ~ r) => RApp [Proxy "+", a, b] r++> type family UpcastNumR a b+> type instance UpcastNumR Double Int = Double+> type instance UpcastNumR Int Int = Int++the benefit here is that users could add their own RApp instances.+On the other hand, perhaps using a separate constraint solver will be less+confusing in terms of type errors (ie. failure to infer a type from R+which will happen (features like @do.call@) should not complicate the types+seen on the haskell side).++-}
+ src/RlangQQ/Antiquote.hs view
@@ -0,0 +1,32 @@+module RlangQQ.Antiquote (extractAntiquotes) where++import Language.Haskell.Meta+import Language.Haskell.TH+import Text.Trifecta+import Control.Applicative++extractAntiquotes :: Parser [Either Exp String]+extractAntiquotes = do+ a <- Right <$> many (noneOf "$")+ bc <- do+ string "$"+ b <- try (Left <$> antiquote) <|> pure (Right "$")+ c <- extractAntiquotes+ return (b:c)+ <|> ([] <$ eof)+ return (a:bc)++antiquote = do+ string "("+ firstExp ""++-- | repeatedly try 'parseExp' on input ending (not including) @)@, until the first success.+firstExp prev = do+ c <- many (noneOf ")")+ string ")"+ let cs = prev ++ c -- appending is the least of efficiency concerns here+ -- chances are that you only have a couple ')' characters+ -- inside the $( ) at most.+ case parseExp cs of+ Right x -> return x+ _ -> firstExp (cs ++ ")")
+ src/RlangQQ/Binary.hs view
@@ -0,0 +1,651 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}++{- | Conversions between R's RDS/RDA format and haskell data types.++tested with R 3.0.1+++Missing:++* Data.Map++* better error reporting when the format is bad?++* more tests++-}+module RlangQQ.Binary (+ -- * functions to serialize many variables+ -- $rdaFmt+ toRDA, fromRDA,++ -- * serializing a single variable+ ToRDS(..), FromRDS(..),++ -- * types / internal+ FromRDA, ToRDSRecord, RDSHLIST, RDA, IxSize(..),++ module Data.HList.CommonMain, ) where++import System.Process+import Unsafe.Coerce+import Control.Applicative+import qualified Data.ByteString.Lazy.UTF8 as B+import qualified Data.ByteString.UTF8 as BS (fromString, toString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as B8++import Data.Int+import Data.HList.CommonMain+import qualified Data.Vector as V+import qualified Data.Map as M++import Data.Binary+import Data.Binary.Get+import Data.Binary.Builder+import Data.Binary.Put+import qualified Data.Binary++import qualified Data.Text as T+import Data.Text.Encoding as E++import Control.Monad.Identity+import qualified Data.Array.Repa as R++import GHC.TypeLits++import qualified Data.Array as A+import qualified Language.Haskell.TH as TH++import qualified Codec.Compression.GZip as GZip++import HListExtras++data FLVPair = FLVPair+instance (LVPair l a ~ b) => ApplyAB FLVPair a b where+ applyAB FLVPair x = LVPair x++-- this should not be necessary+type family UnHMapFLVPair (a :: [*]) :: [*]+type instance UnHMapFLVPair (LVPair l a ': as) = a ': UnHMapFLVPair as+type instance UnHMapFLVPair '[] = '[]++-- | this seems to be a magic number. Corresponds to R 3.0.1+putVersion = put (262153 :: Int32)++-- | doesn't check+getVersion = get :: Get Int32++-- | same as Binary but should be compatible with R's @saveRDS@+-- binary mode, which is for single objects+class ToRDS a where+ toRDS :: a -> Put+class FromRDS a where+ fromRDS :: Get a++-- | the binary instance of Double produces 25 bytes, not the 8 bytes for ieee754+-- perhaps alternatives to binary do better (bytes, cereal etc).+putDouble = put . (unsafeCoerce :: Double -> Int64)+getDouble = fmap (unsafeCoerce :: Int64 -> Double) get++-- | becomes a numeric vector+instance ToRDS (V.Vector Double) where+ toRDS x = do+ put (14 :: Int32)+ put (fromIntegral $ V.length x :: Int32)+ V.mapM_ putDouble x+instance FromRDS (V.Vector Double) where+ fromRDS = do+ 14 <- get :: Get Int32+ len <- get :: Get Int32+ V.mapM (const getDouble) $ V.replicate (fromIntegral len) ()++-- | integer vector+instance ToRDS (V.Vector Int32) where+ toRDS x = do+ put (13 :: Int32)+ put (fromIntegral $ V.length x :: Int32)+ V.mapM_ put x+instance FromRDS (V.Vector Int32) where+ fromRDS = do+ 13 <- get :: Get Int32+ len <- get+ V.mapM (const get) $ V.replicate len ()++-- | character vector @c(\'ab\',\'cd\')@+instance ToRDS (V.Vector T.Text) where+ toRDS x = do+ put (16 :: Int32)+ put (fromIntegral (V.length x) :: Int32)+ V.mapM_ (\x -> do+ putVersion+ let x' = E.encodeUtf8 x+ put (fromIntegral $ BS.length x' :: Int32)+ putByteString x') x++instance FromRDS (V.Vector T.Text) where+ fromRDS = do+ 16 <- get :: Get Int32+ nstr <- get :: Get Int32+ V.mapM (const $ do+ get :: Get Int32 -- version+ len <- get :: Get Int32+ bs <- getBytes (fromIntegral len)+ return (E.decodeUtf8 bs)+ ) $ V.replicate (fromIntegral nstr) ()++-- | T.pack "abc" => @c(\'ab\')@+instance ToRDS T.Text where+ toRDS x = toRDS (V.singleton x)++instance FromRDS T.Text where+ fromRDS = (\(x:_) -> x) . V.toList <$> fromRDS++-- | @[\"abc\",\"def\"]@ => @c(\'abc\',\'def\')@+instance ToRDS [String] where+ toRDS x = toRDS $ V.fromList (map T.pack x)+instance FromRDS [String] where+ fromRDS = map T.unpack . V.toList <$> fromRDS++-- | "abc" => @c(\'ab\')@+instance ToRDS String where+ toRDS = toRDS . (:[])+instance FromRDS String where+ fromRDS = fmap (\(x:_) -> x) fromRDS+++data FToRDS = FToRDS+instance (ToRDS a, putm ~ Put) => ApplyAB FToRDS a putm where+ applyAB FToRDS x = toRDS x++data FFromRDS = FFromRDS+instance (FromRDS b, Get b ~ getB, a ~ ()) => ApplyAB FFromRDS a getB where+ applyAB FFromRDS _ = fromRDS+++type RDSHLIST xs' xs = (HNat2Integral (HLength xs), HFoldr (HSeq FToRDS) Put xs Put)++instance (RDSHLIST xs' xs) => ToRDS (LST xs) where+ toRDS (LST xs) = do+ put (531::Int32)+ let [(len,"")] = reads (drop 1 $ show (proxy :: Proxy (HLength xs)))+ put (fromIntegral (len - 2 :: Int) :: Int32)+ hFoldr (HSeq FToRDS) (return () :: Put) xs :: Put+ put (254::Int32)++type RDSHLIST2 b bs' l = (HSequence Get b l, HSequence ((->) ()) bs' b,+ HReplicate (HLength l) FFromRDS,+ HMapAux FApply (HReplicateR (HLength l) FFromRDS) bs',+ SameLength (HReplicateR (HLength l) FFromRDS) bs',+ SameLength bs' (HReplicateR (HLength l) FFromRDS),+ HNat2Integral (HLength l))++instance (RDSHLIST2 ___ __ l) => FromRDS (LST l) where+ fromRDS = withSelf $ \(self) -> do+ 531 <- get :: Get Int32+ let [(len,"")] = reads (drop 1 $ show (hLength self))+ len2 <- get :: Get Int32+ when (len /= len2) $ error $ "fromRDS expected length: " ++ show len ++ " rds file has length: " ++ show len2+ r <- hSequence (hSequence (hMap FApply $ hReplicate (hLength self) FFromRDS) ())+ 254 <- get :: Get Int32+ return (LST r)+ where+ withSelf :: forall (a::[*]) m. (HList a -> m (LST a)) -> m (LST a)+ withSelf x = x (error "RlangQQ.Binary.LST.self")++++-- | not to be constructed outside here+newtype LST (a :: [*]) = LST (HList a)++-- | @lab .=. val .*. 'emptyRecord'@ => @list(lab= ('toRDS' val) )@.+--+-- The type variables with underscores should be hidden+instance ToRDSRecord __ ___ xs => ToRDS (Record xs) where+ toRDS (Record xs) = toRDS $ LST $+ recordValues (Record xs) `hAppend`+ (ListStart `HCons` (Label :: Label "names") .=. (recordLabelsString (error "recLabs" :: Proxy (RecordLabels xs))) `HCons` HNil)++type ToRDSRecord __ ___ xs = (RDSHLIST __ ___, ToRDS (LST ___),+ RecordValues xs,+ HList ___ ~ (HList (RecordValuesR xs) `HAppendR` HList '[ListStart, LVPair "names" [String]]),+ RecordLabelsString (RecordLabels xs),+ HAppend (HList (RecordValuesR xs)) (HList '[ ListStart, LVPair "names" [String]]))++++-- | this signature shouldn't be necessary... it just repeats all the+-- functions called+type FromRDSRec a b as' as'2 bs' = (HSequence Get b as',+ HSequence ((->) ()) a b,+ -- HMap1 FLVPair as' bs',+ HMapAux FLVPair as' bs',+ SameLength as' bs',+ SameLength bs' as',++ HMapAux FApply as'2 a,+ SameLength as'2 a,+ SameLength a as'2,++ HMapOut (HComp FShowLabel FLabelLVPair) bs' String,+ RecordLabelsString (RecordLabels bs'),+ HNat2Integral (HLength bs'),+ HReplicate2 (HLength bs') FFromRDS as'2)++instance FromRDSRec a b as' as'2 bs' => FromRDS (Record bs') where+ fromRDS = do+ 531 <- get :: Get Int32+ let len = hNat2Integral (proxy :: Proxy (HLength bs'))+ len2 <- get :: Get Int32+ when (len /= len2) $ error $ "fromRDS expected length: " ++ show len ++ " rds file has length: " ++ show len2++ r <- hSequence+ (hSequence+ (hMap FApply+ (hReplicate2 (proxy :: Proxy (HLength bs')) FFromRDS) )+ ())+ getListHdr+ "names" <- getString+ names :: [String] <- fromRDS++ let names' = recordLabelsString (error "recLabs" :: Proxy (RecordLabels bs'))++ unless (names == names') $ error $ "fromRDS expected names( ): " ++ show names'+ ++ " rds file has names attribute : " ++ show names++ 254 <- get :: Get Int32+ return (Record (hMap FLVPair (r :: HList as')))+ -- this hMap1 can't be replaced by hMap?++class RecordLabelsString (a :: [Symbol]) where+ recordLabelsString :: Proxy a -> [String]++instance RecordLabelsString '[] where+ recordLabelsString _ = []++instance (ShowLabel x, RecordLabelsString xs)+ => RecordLabelsString (x ': xs) where+ recordLabelsString _ = showLabel (Label :: Label x) : recordLabelsString (proxy :: Proxy xs)++-- same as recordLabelsString, but less lazy+recLabs (Record xs) = hMapOut (HComp FShowLabel FLabelLVPair) xs++data FLabelLVPair = FLabelLVPair+instance(LVPair l a ~ x, y ~ Label l) => ApplyAB FLabelLVPair x y where+ applyAB FLabelLVPair = labelLVPair++data FShowLabel = FShowLabel+instance (string ~ String, ShowLabel l, ll ~ Label l) => ApplyAB FShowLabel ll string+ where applyAB _ = showLabel+++instance ToRDS [Double] where+ toRDS = toRDS . V.fromList++instance FromRDS [Double] where+ fromRDS = fmap V.toList $ fromRDS++instance ToRDS Double where toRDS = toRDS . (:[])+instance ToRDS Int32 where toRDS = toRDS . (:[])++instance FromRDS Int32 where+ fromRDS = do+ [x] <- fromRDS+ return x++instance FromRDS Double where+ fromRDS = do+ [x] <- fromRDS+ return x+++instance ToRDS [Int32] where+ toRDS = toRDS . V.fromList+instance FromRDS [Int32] where+ fromRDS = fmap V.toList $ fromRDS+++++putString s = do+ let s' = BS.fromString s+ put (fromIntegral $ BS.length s' :: Int32)+ putByteString s'+getString = do+ len <- get :: Get Int32+ string <- getBytes (fromIntegral len)+ return (BS.toString string)++confirmString s = do+ s' <- getString+ unless (s' == s) $ error $ "expected "++ s ++ ", got " ++ s'++data ListStart = ListStart+instance ToRDS ListStart where+ toRDS _ = putListHdr+instance FromRDS ListStart where+ fromRDS = do+ getListHdr+ return ListStart+++putListHdr = do+ put (1026 :: Int32)+ put (1 :: Int32)+ putVersion++getListHdr = do+ [1026, 1, 262153] <- replicateM 3 (get :: Get Int32)+ return ()+++-- | probably internal+instance forall t l. (ToRDS t, ShowLabel l) => ToRDS (LVPair l t) where+ toRDS (LVPair x) = do+ putString (showLabel (undefined :: Label l))+ toRDS x+-- | probably internal+instance forall t l. (FromRDS t, ShowLabel l) => FromRDS (LVPair l t) where+ fromRDS = do+ varName <- getString++ let s = showLabel (undefined :: Label l)+ unless (varName == s) $ fail $ unwords ["FromRDS: expecting label `", s , "', but got: `" , varName , "'"]++ x <- fromRDS+ return (LVPair x)++-- | labels are stored with the variables here. compare with the instance for 'Record' / 'LST' which collects+-- the labels and saves them as an attribute called \"names\"+newtype RDA a = RDA (HList a)++-- | internal+instance forall rs l2 t. (ToRDS t, ToRDS (RDA rs), ShowLabel l2) => ToRDS (RDA (LVPair l2 t ': rs)) where+ toRDS (RDA (x `HCons` xs)) = do+ putListHdr+ toRDS x+ toRDS (RDA xs)++-- | internal+instance forall rs l2 t. (FromRDS t, FromRDS (RDA rs), ShowLabel l2) => FromRDS (RDA (LVPair l2 t ': rs)) where+ fromRDS = do+ getListHdr+ x <- fromRDS :: Get (LVPair l2 t)+ RDA xs <- fromRDS :: Get (RDA rs)+ return (RDA (x `HCons` xs))++-- | internal+instance ToRDS (RDA '[]) where+ toRDS _ = put (254::Int32)++-- | internal+instance FromRDS (RDA '[]) where+ fromRDS = do+ 254 <- get :: Get Int32+ return (RDA HNil)+++-- | given 'A.bounds' of an array, produce a list of how many elements+-- are in each dimension. For example, a 3x2 array produces [3,2].+--+-- A single instance for \"linear\" indices would look like:+--+-- > instance (A.Ix i, Num i) => IxSize i where+-- > ixSize x = [fromIntegral (A.rangeSize x)]+-- > fromIxSize [n] = (0, n-1)+--+-- But to avoid overlapping instances all monomorphic index types likely+-- to be used are just repeated here. fromIxSize produces 0-based indexes+-- for instances of 'Num' ('Word', 'Int', 'Integer'), while 'minBound' is+-- used for other types.+--+-- R supports a dimnames attribute. This could be used but it is not so far.+class A.Ix i => IxSize i where+ ixSize :: (i,i) -> [Int32]+ fromIxSize :: [Int32] -> (i,i) -- ^ with 0-based indexes++fmap concat $ forM+ (map (\n -> ([| 0 |], [| fromIntegral |], n)) [''Word8, ''Word64, ''Word32, ''Word16, ''Word,+ ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Integer] +++ map (\n -> ([| minBound |], [| toEnum . fromIntegral |], n)) [''Ordering, ''Char, ''Bool, ''()]) $ \ (zero, fi, name) ->+ let ty = TH.conT name in+ [d| instance IxSize $ty where+ ixSize x = [fromIntegral (A.rangeSize x)]+ fromIxSize [x] = ($zero , $fi (x-1)) |]++instance (IxSize a, IxSize b) => IxSize (a,b) where+ ixSize ((a,b),(a',b')) = ixSize (a,a') ++ ixSize (b,b')+ fromIxSize [n1,n2] =+ let (a,a') = fromIxSize [n1]+ (b,b') = fromIxSize [n2]+ in ((a,b),(a',b'))++instance (IxSize a, IxSize b, IxSize c) => IxSize (a,b,c) where+ ixSize ((a,b,c),(a',b',c')) = ixSize (a,a') ++ ixSize (b,b') ++ ixSize (c,c')+ fromIxSize [n1,n2,n3] =+ let (a,a') = fromIxSize [n1]+ (b,b') = fromIxSize [n2]+ (c,c') = fromIxSize [n3]+ in ((a,b,c),(a',b',c'))++instance (IxSize a, IxSize b, IxSize c, IxSize d) => IxSize (a,b,c,d) where+ ixSize ((a,b,c,d),(a',b',c',d')) = ixSize (a,a') ++ ixSize (b,b') ++ ixSize (c,c') ++ ixSize (d,d')+ fromIxSize [n1,n2,n3,n4] =+ let (a,a') = fromIxSize [n1]+ (b,b') = fromIxSize [n2]+ (c,c') = fromIxSize [n3]+ (d,d') = fromIxSize [n4]+ in ((a,b,c,d),(a',b',c',d'))++instance (IxSize a, IxSize b, IxSize c, IxSize d, IxSize e) => IxSize (a,b,c,d,e) where+ ixSize ((a,b,c,d,e),(a',b',c',d',e')) = ixSize (a,a') ++ ixSize (b,b') ++ ixSize (c,c') ++ ixSize (d,d') ++ ixSize (e,e')+ fromIxSize [n1,n2,n3,n4,n5] =+ let (a,a') = fromIxSize [n1]+ (b,b') = fromIxSize [n2]+ (c,c') = fromIxSize [n3]+ (d,d') = fromIxSize [n4]+ (e,e') = fromIxSize [n5]+ in ((a,b,c,d,e),(a',b',c',d',e'))+++-- | @"Data.Array".Array@ become arrays in R+instance (IxSize i) => ToRDS (A.Array i Double) where+ toRDS arr = toRDSArray+ True+ (fromIntegral (A.rangeSize (A.bounds arr)))+ (mapM_ putDouble (A.elems arr))+ (ixSize (A.bounds arr))++toRDSArray :: Bool -- ^ is a double array (otherwise Int)+ -> Int32 -- ^ number of elements+ -> Put -- ^ put the elements+ -> [Int32] -- ^ bounds+ -> Put+toRDSArray isDouble size putElts bnds = do+ put (if isDouble then 526 else 524 :: Int32)+ put size+ putElts+ putListHdr+ putString "dim"+ toRDS bnds+ put (254 :: Int32)+++instance (IxSize i) => ToRDS (A.Array i Int32) where+ toRDS arr = toRDSArray+ False+ (fromIntegral (A.rangeSize (A.bounds arr)))+ (mapM_ put (A.elems arr))+ (ixSize (A.bounds arr))+++++++-- | note indices become 0-based (see 'IxSize')+instance (IxSize i) => FromRDS (A.Array i Double) where+ fromRDS = do+ (526 :: Int32) <- get+ (nel :: Int32) <- get+ els <- replicateM (fromIntegral nel) getDouble+ getListHdr+ "dim" <- getString+ bds <- fromRDS+ (254 :: Int32) <- get+ return (A.listArray (fromIxSize bds) els)++-- | note indices become 0-based (see 'IxSize')+instance (IxSize i) => FromRDS (A.Array i Int32) where+ fromRDS = do+ (524 :: Int32) <- get+ (nel :: Int32) <- get+ els <- replicateM (fromIntegral nel) get+ getListHdr+ "dim" <- getString+ bds <- fromRDS+ (254 :: Int32) <- get+ return (A.listArray (fromIxSize bds) els)++toRDSRepaArr b putFn arr =+ let nel = R.size (R.extent arr) in+ toRDSArray+ b+ (fromIntegral nel)+ (forM_ [0 .. nel - 1] (putFn . R.linearIndex arr))+ (map fromIntegral (R.listOfShape (R.extent arr)))++-- | repa+instance (R.Source r Double, R.Shape sh) => ToRDS (R.Array r sh Double) where+ toRDS = toRDSRepaArr True putDouble++-- | repa+instance (R.Source r Int32, R.Shape sh) => ToRDS (R.Array r sh Int32) where+ toRDS = toRDSRepaArr False put+++fromRDSRepa getElt = do+ (nel :: Int32) <- get+ els <- replicateM (fromIntegral nel) getElt+ getListHdr+ "dim" <- getString+ bds :: [Int32] <- fromRDS+ (254 :: Int32) <- get+ return (R.fromListUnboxed (R.shapeOfList (map fromIntegral bds)) els)+++-- | repa+instance R.Shape sh => FromRDS (R.Array R.U sh Double) where+ fromRDS = do+ (526 :: Int32) <- get+ fromRDSRepa getDouble++-- | repa+instance R.Shape sh => FromRDS (R.Array R.U sh Int32) where+ fromRDS = do+ (524 :: Int32) <- get+ fromRDSRepa get+++data AnyRDS where AnyRDS :: (ToRDS a) => a -> AnyRDS+instance ToRDS AnyRDS where toRDS (AnyRDS x) = toRDS x+-- need a witness, which isn't being passed in just yet,+-- or a parser into some intermediate format+-- instance FromRDS AnyRDS where fromRDS = AnyRDS `fmap` fromRDS++-- | @M.fromList [(\"a\",AnyRDS 1),(\"b\", AnyRDS 2)]@ becomes @list(a=1, b=2)@+instance ToRDS (M.Map String AnyRDS) where+ toRDS xs = do+ put (531::Int32)+ put (fromIntegral (M.size xs) :: Int32)+ mapM_ toRDS (M.elems xs)+ putListHdr+ putString "names"+ toRDS (M.keys xs)+ put (254 :: Int32)+++toRDA x = GZip.compress $ runPut $ do+ mapM_ put "RDX2\nX\n"+ put (2 :: Int32)+ put (196609 :: Int32)+ put (131840 :: Int32)+ toRDS (RDA (recordValues x))+++{- $rdaFmt++A typical type would be++> Record '[LVPair l1 (LVPair m1 x), LVPair l2 (LVPair m2 x)]++The outer labels (@l1@, @l2@) are the haskell-side. The inner labels+are the @m1@ @m2@ which are the names of the variables on the R side.+++-}+++-- why can't the __ type be inferred?+fromRDA :: forall __ r. FromRDA __ r => B.ByteString -> Record r+fromRDA x = ( $ GZip.decompress x) $ runGet $ do+ let hdr = "RDX2\nX\n"+ hdr' <- fmap (BS.toString) $ getBytes (BS.length (BS.fromString hdr))+ unless (hdr == hdr') $ fail "wrong header"+ [{- 2 , 196609, 131840 -} _, _, _ :: Int32 ] <- replicateM 3 get+ fmap (\(RDA a) -> Record (hMap1 FLVPair (a::HList __) )) fromRDS++type FromRDA a r = (HMap1 FLVPair a r, FromRDS (RDA a))++-- * tests++makeLabels6 (words "x abc lab2")++-- | are these records necessarily this noisy?+sampV1 = x .=. newLVPair x [1,2,3,4 :: Double] .*.+ abc .=. newLVPair abc (V.fromList [4 :: Double]) .*.+ emptyRecord++testPut = B.writeFile "/tmp/foo2" $ toRDA sampV1++roundtrip = toRDA ((fromRDA $ toRDA sampV1) `asTypeOf` sampV1) == toRDA sampV1++sampleList = Record (recordValues sampV1)++testPut2 = B.writeFile "/tmp/foo3" $ toRDA (abc .=. (abc .=. sampleList) .*. emptyRecord)++sampV2 = x .=. x .=. (x .=. sampleList) .*.+ abc .=. (abc .=. sampleList) .*. emptyRecord++sampV3 = x .=. newLVPair x [1,2,3,4 :: Double] .*.+ abc .=. newLVPair abc "hi" .*.+ lab2 .=. newLVPair lab2 sampArr .*.+ emptyRecord++sampArr :: A.Array (Int,Int) Double+sampArr = A.listArray ((0,0),(2,2)) [1 .. 9]++sampMap = M.fromList [("x", AnyRDS [2 :: Double]), ("y", AnyRDS sampArr) ]++testPut3 = do+ B.writeFile "/tmp/foo3" $ toRDA sampV3+ readProcess "R" ["--no-save"] "load('/tmp/foo3')"++testPut4 = do+ B.writeFile "/tmp/foo3" $ toRDA (x .=. (x .=. sampMap) .*. emptyRecord)+ readProcess "R" ["--no-save"] "load('/tmp/foo3')"
+ src/RlangQQ/FN.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | 'hMap' 'FN' drops the inner LVPair, which was+-- just used to keep track of the variable name on the+-- R side.+--+-- it could be replaced by unsafeCoerce with the+-- right type signature+module RlangQQ.FN where+import Data.HList.CommonMain+import GHC.TypeLits+data FN = FN++instance (a ~ (LVPair (t :: k) (LVPair (t2::k) x)), b ~LVPair t x) => ApplyAB FN a b where+ applyAB _ (LVPair (LVPair x)) = LVPair x++data NoLabel = NoLabel+instance (la ~ LVPair "" a) => ApplyAB NoLabel a la where+ applyAB _ x = LVPair x+
src/RlangQQ/Internal.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} module RlangQQ.Internal where -import Data.Char+import System.IO.Temp+import System.IO++import Control.Applicative import Data.List import Data.Maybe import Data.Monoid@@ -15,78 +21,252 @@ import Text.Printf import Text.Trifecta -import Data.ByteString.Lazy.UTF8 as B-import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.UTF8 as B import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8 +import Control.Monad.State+import Control.Monad.Maybe+import Data.Generics+import qualified Data.Traversable as T+import qualified Data.Map as M+import Data.Foldable (foldMap) + import Paths_Rlang_QQ -{- | Calls R with the supplied string. Variables in R prefixed hs_ cause-the corresponding (un-prefixed) variable to be converted. The variable(s) must-be in the class 'ToRVal'.+import RlangQQ.Binary+import RlangQQ.Antiquote+import RlangQQ.FN -For example, when this file <http://code.haskell.org/~aavogt/examples/test.hs> is run+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Concurrent -> {-# LANGUAGE QuasiQuotes #-}-> import RlangQQ->-> x = [0 .. 10 :: Double]-> y = map (sin . (*pi) . (/10)) x->-> main = do-> [r|-> library(ggplot2)-> png(file='test.png')-> plot(qplot( hs_x, hs_y ))-> dev.off()-> |]+import System.IO.Unsafe+import Data.IORef -The file is produced <<http://code.haskell.org/~aavogt/Rlang-QQ/examples/test.png>>+-- * the main quoter --}-r = QuasiQuoter { quoteExp = quoteRExpression 1 }+-- | going via binary serialization (classes from "RlangQQ.Binary"). This is used in 'RlangQQ.r'+quoteRExpression2 i returnChan str0 = do+ let rawFile, inputFile, inputFile2, outputFile :: String+ rawFile = printf "Rtmp/raw%d.R" (i :: Int)+ inputFile = printf "Rtmp/%d_hs.rdx" i+ inputFile2 = printf "Rtmp/%d_hs2.rdx" i+ outputFile = printf "Rtmp/%d_r.rdx" i -quoteRExpression i str = do- let rawFile = printf "Rtmp/raw%d.R" (i::Int) :: String- let hdrFile = printf "Rtmp/new%d.R" (i::Int) :: String+ (str, addAntiquotes) = withRawFile str0 - variablesToInput <- runIO $ do+ variables <- runIO $ do t <- getDataFileName "Tree.R" createDirectoryIfMissing False "Rtmp" writeFile rawFile str rt <- readProcess "R" ["--no-save","--quiet"] $ printf "source('%s'); rlangQQ_toTree(parse('%s'))" t rawFile case parseString parseTree mempty rt of- Success a -> return $ hsVars a+ Success a -> return $ hsClassify a Failure a -> do print a error "parse failure"- let varFiles = map (stringE . printf "Rtmp/%d_hs_%s" i) variablesToInput - writeVarFiles = [|- mapM_ (\(file,varName, value) -> B.writeFile file (toRVal varName value)) $- $(listE $ zipWith3 (\x y z -> [| ($x, $y, $z) |])- varFiles- (map (stringE . ("hs_"++)) variablesToInput)- (map (varE . mkName) variablesToInput))+ -- reify doesn't work well enough+ -- (chanVars, mVars, M.fromList -> variables) <- classifyByConT (M.toList variables) + (variables, chanVars) <- return $ M.partitionWithKey (\k _ -> "hs_" `isPrefixOf` k) variables++ let+ writeInputFile' :: FilePath -> M.Map String Intent -> ExpQ+ writeInputFile' inputFile vars = [|+ B.writeFile inputFile $+ $(appE [| toRDA . Record |] $+ mkHList+ [ [| $(label x) .=. ($(label' x) .=. $(var x)) |]+ | (x, intent) <- M.toList vars, notOut intent ]) |] - runR = [| readProcess "R" ["--no-save", "--quiet"]- $ concat- $ map (printf "source('%s');") $(listE varFiles)- ++ [ printf "source('%s')" rawFile] |]- [| do- writeFile hdrFile $ concatMap (printf "source('%s');") variablesToInput- $writeVarFiles- $runR+ writeChanInput :: ExpQ+ writeChanInput+ | M.size chanVars == 0 = [| return () |]+ | otherwise = do+ (withOutputs, binds) <- fmap unzip $ sequence [ do+ withOutput <- newName "writer"+ return (withOutput, bindS (tupP [varP (mkName (dropHS x)),+ varP withOutput]) [| readChan $(var x) |] )+ | (x, intent) <- M.toList chanVars, notOut intent ]+ let write = doE $ binds ++ [ noBindS (writeInputFile' inputFile2 chanVars),+ noBindS [|+ return $ \outputRecord -> $(doE+ [ noBindS [| $(varE oi)+ (outputRecord `asTypeOf` Record $sampOutput2) :: IO () |]+ | oi <- withOutputs ] )+ |] ]+ write++ writeInputFile :: ExpQ+ writeInputFile = writeInputFile' inputFile variables++ -- a record containing variables which were sent+ -- into R (intent InOut), or undefined for intent Out+ -- which will aid in type inference.+ sampOutput' :: (String -> ExpQ) -> ExpQ+ sampOutput' addLabels = mkHList+ [ [| $(addLabels x) $(case intent of+ Out -> [| undefined |] -- no input value whose+ -- type should unify with+ _ -> var x ) |]++ | (x, intent) <- M.toList variables, notIn intent ]++ sampOutput, sampOutput2 :: ExpQ+ sampOutput = sampOutput' $ \x -> [| \ y -> $(label x) .=. ($(label' x) .=. y) |]+ sampOutput2 = sampOutput' $ \x -> [| \ y -> $(label x) .=. ( y) |]+++ readOutputFile :: ExpQ+ readOutputFile = [|+ let mapSnd (Record x) = Record (hMap FN x)+ fixTy x = x `asTypeOf` Record $sampOutput+ fixTy2 x = x `asTypeOf` Record $sampOutput2+ in fixTy2 . mapSnd . fixTy . fromRDA <$> B.readFile outputFile |]++ outVars :: [String]+ outVars = [ s | (s, intent) <- M.toList variables+ ++ M.toList chanVars {- necessary? -}, notIn intent ]+++ writeOutputFile | [] <- outVars = [| "" |]+ | otherwise = stringE (printf "save(%s, file='%s', compress='gzip');"+ (intercalate "," $ reverse outVars)+ outputFile)++ runRNoChan :: ExpQ+ runRNoChan = [| readProcess "R" ["--no-save", "--quiet"] $ concat+ [ $(stringE (printf "load('%s');" inputFile)),+ $(stringE (printf "source('%s');" rawFile)),+ $writeOutputFile ]+ |]+++ whenOutVars :: ExpQ -> ExpQ+ whenOutVars e = unlessQ (null outVars) e++ runRChan :: ExpQ+ runRChan = do+ [| do+ chOut <- $(unlessQ (null outVars && not returnChan) [| newChan `asTypeOf`+ ((undefined :: HList a -> IO (Chan (Record a))) $sampOutput2) |])++ outVar <- $(whenOutVars [| newEmptyMVar |])++ forkIO $ void $ do+ -- binary/text IO instead?+ (i,o,err,pid) <- runInteractiveProcess "R" ["--no-save", "--quiet"] Nothing Nothing+ forkIO $ putStr =<< hGetContents err+ hPutStrLn i $ printf "load('%s');" inputFile+ hFlush i+ let uniqueDoneString = "\"done calculating signaled by a very unique\+ \ string that will never happen by chance\""+ forkIO $ forever $ do+ withOutputFn <- $writeChanInput+ hPutStrLn i $ printf "load('%s'); source('%s'); %s %s"+ inputFile2 rawFile $writeOutputFile+ uniqueDoneString+ hFlush i+ $(whenOutVars [| putMVar outVar withOutputFn |] )++ forkIO $ forever $ do+ oEOF <- hIsEOF o -- is this ok?+ when oEOF (killThread =<< myThreadId)+ o <- hGetLine o+ when (o == ("[1] "++uniqueDoneString))+ $(whenOutVars [| do+ ov <- takeMVar outVar+ output <- $readOutputFile++ ov output+ $(whenQ returnChan+ ([| (`writeChan` output) |] `appE` [| chOut |])+ -- should be writeChan chOut output+ -- but that doesn't typecheck here...+ )+ |])++ return chOut+ |]++ addAntiquotes [| do+ {- already done, but Rtmp could have moved+ since compile time -}+ createDirectoryIfMissing False "Rtmp"+ do+ f <- doesFileExist rawFile+ unless f $ writeFile rawFile str++ $writeInputFile+ $(if M.size chanVars == 0 then [| do+ $runRNoChan+ $( whenOutVars readOutputFile) |]+ else runRChan)+ |] +unlessQ, whenQ :: Bool -> ExpQ -> ExpQ+unlessQ b e | b = [| return () |] | otherwise = e+whenQ b e = unlessQ (not b) e +withRawFile :: String -> (String, ExpQ -> ExpQ)+withRawFile str =+ case parseString extractAntiquotes mempty str of+ Failure msg -> (str, \xp -> do+ reportWarning (show msg)+ xp)+ Success parsed ->+ (\(a,b,c) -> (a,b)) $+ foldr (\ chunk ~( str, ef, i) ->+ case chunk of+ Left x ->+ let v = "hs_interp" ++ show i in+ ( concat [v, " ", str],+ \e0 -> caseE (return x)+ [ match+ (mkName (dropHS v) `asP` varP (mkName v))+ (normalB (ef e0))+ [] ],+ i+1)+ Right s -> (s ++ str, ef, i))+ ("", id, 1)+ parsed ++-- ** utility functions+-- | go from the variable name used on the R-side to the one in the haskell side+dropHS x = fromMaybe x (foldMap stripPrefix prefixes x)+++prefixes = ["hs_","ch_"]++-- | HList label+label x = [| Label :: Label $(litT (strTyLit (dropHS x))) |]+label' x = [| Label :: Label $(litT (strTyLit x)) |]++var x = varE (mkName (dropHS x))++mkHList :: [ExpQ] -> ExpQ+mkHList = foldl (\ b a -> [| $a .*. $b |]) [| HNil |]++notOut Out = False+notOut _ = True++notIn In = False+notIn _ = True++++++ -- * converting R\'s AST parseTree' = do@@ -101,53 +281,108 @@ between (oneOf "\"") (oneOf "\"") parseTree' -parseTreeTest = do- t <- getDataFileName "Tree.R"- inputFile <- getDataFileName "parseTreeExample.R"- rt <- readProcess "R" ["--no-save","--quiet"] $ "source('"++ t ++ "'); rlangQQ_toTree(parse('"++ inputFile ++ "'))"- print rt- let r = parseString parseTree mempty rt :: Result (Tree String)-- print (fmap hsVars r)- -- | gets variables like @abc@ provided the R file contained @hs_abc@ hsVars :: Tree String -> [String]-hsVars = mapMaybe (stripPrefix "hs_") . F.toList+hsVars = mapMaybe (foldMap stripPrefix prefixes) . F.toList --- * classes for marshalling data+labelTree :: Tree String -> Tree (String, Int)+labelTree t = flip evalState 0 $ T.forM t $ \x -> do+ n <- get+ put (n+1)+ return (x, n) +-- | what is the usage of a @hs_@ variable on the R side?+data Intent = In -- ^ only read+ | Out -- ^ only assigned to+ | InOut -- ^ both+ deriving (Show, Eq) --- ** haskell -> R-class ToRVal a where- toRVal :: String -- ^ variable name- -> a- -> B.ByteString -instance ToRVal Int where toRVal x n = B.fromString $ x ++ "<-" ++ show n-instance ToRVal Integer where toRVal x n = B.fromString $ x ++ "<-" ++ show n-instance ToRVal Double where toRVal x n = B.fromString $ x ++ "<-" ++ show n-instance ToRVal String where toRVal x n = B.fromString $ x ++ "<-" ++ show n-instance ToRVal [Int] where toRVal = listToVec-instance ToRVal [Integer] where toRVal = listToVec-instance ToRVal [Double] where toRVal = listToVec-instance ToRVal [String] where toRVal = listToVec -listToVec x n = B8.unwords $- [B.fromString x,- B.fromString "<- c(",- B8.intercalate (B.fromString ",") (map (B.fromString . show) n),- B.fromString ")"]+classifyExp :: Tree String -> Maybe (String, Intent)+classifyExp (Node oper (a: _))+ | oper `elem` ["<-", "="],+ [r] <- filter (\x -> any (`isPrefixOf` x) prefixes) $ leftmosts a = Just (r, Out) --- ** R -> haskell+ where+ leftmosts (Node a []) = [a]+ leftmosts (Node n (a:_)) = n : leftmosts a --- | not used yet-class FromRVal a where fromRVal :: B.ByteString -> a-instance FromRVal Double where fromRVal = fromRValp double+classifyExp (Node n _) | any (`isPrefixOf` n) prefixes = Just (n, In)+classifyExp _ = Nothing -fromRValp p s =- case parseByteString p mempty (B.toStrict s) of- Success a -> a- Failure a -> error (show a)+hsClassify :: Tree String -> M.Map String Intent+hsClassify+ = M.fromListWith (flip merge)+ . mapMaybe classifyExp+ . toList++ where+ merge Out _ = Out+ merge In Out = InOut+ merge InOut _ = InOut+ merge _ InOut = InOut+ merge In In = In++ -- all Node being viewed+ toList :: Tree a -> [Tree a]+ toList a = a : concatMap toList (subForest a)++-- | this reify fails most of the time, since the type isn't+-- available in a quasiquote (run in the renamer) for things+-- declared in the same file.+getConTOf:: String -> Q (Maybe Name)+getConTOf x = runMaybeT $ do+ n <- MaybeT $ lookupValueName (dropHS x)+ VarI _ (AppT (ConT n) _) _ _ <- MaybeT $ (Just `fmap` reify n) `recover` return Nothing+ return n++classifyByConT =+ foldr (\ el lists -> do+ ~(x,y,z) <- lists+ ct <- getConTOf (fst el)+ case ct of+ Just ty | ty == ''MVar -> return (x, el : y, z)+ | ty == ''Chan -> return (el : x, y, z)+ _ -> return (x,y, el : z)+ )+ (return ([],[],[]))+++-- ** tests++parseTreeTest2 = parseTreeTest =<< getDataFileName "parseTreeExample.R"++parseTreeTest3 contents = withSystemTempFile "RlangQQ.tmp" $ \fn h -> do+ System.IO.hPutStrLn h contents+ hFlush h+ parseTreeTest fn++parseTreeTest inputFile = do+ t <- getDataFileName "Tree.R"+ rt <- readProcess "R" ["--no-save","--quiet"] $ "source('"++ t ++ "'); rlangQQ_toTree(parse('"++ inputFile ++ "'))"+ print rt+ let r = parseString parseTree mempty rt :: Result (Tree String)++ print (fmap hsClassify r)+ -- print (fmap (hsAssignedFirstVars True) r)+ -- print (fmap (hsAssignedFirstVars False) r)+ -- print (zipper r & withins root)+++++-- * global variable quote index++getRlangQQ_n :: Q Int+getRlangQQ_n = runIO $ do+ n <- readIORef rlangQQ_n+ writeIORef rlangQQ_n (n+1)+ return n++{-# NOINLINE rlangQQ_n #-}+rlangQQ_n :: IORef Int+rlangQQ_n = unsafePerformIO (newIORef 1)
+ src/RlangQQ/MakeRecord.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ConstraintKinds, DataKinds,GADTs,FlexibleContexts, FlexibleInstances,KindSignatures,MultiParamTypeClasses #-}+-- | functions to help making lists for consumption on the R side+module RlangQQ.MakeRecord where++import GHC.TypeLits -- prevents a panic lookupVers2 <<details unavailable>> with ghc 7.6. Fixed later probably from #7502+import Control.Monad.State+import Control.Monad.Identity+import Data.HList.CommonMain+import HListExtras++-- | convert a haskell list into a record with labels all of type \"\". The length+-- of the list is decided by the (type of the) first argument which is a 'HNat'+listToRecN :: ListToRecN __ (n :: HNat) x r => Proxy n -> [x] -> Record r+listToRecN n xs = Record $ hMap2 NoLabel $ flip evalState xs $ hSequence $ hReplicate n comp+ where comp = do+ x : xs' <- get+ return () :: State [x] ()+ put (xs' `asTypeOf` xs)+ return (x `asTypeOf` head xs)++type ListToRecN __ (n :: HNat) x r = (HReplicate n (StateT [x] Identity x),+ HSequence (StateT [x] Identity) (HReplicateR n (StateT [x] Identity x)) __,+ HMap2 NoLabel __ r)++++data NoLabel = NoLabel+instance (LVPair "" a ~ la) => ApplyAB NoLabel a la where+ applyAB _ x = LVPair x+
+ src/RlangQQ/NatQQ.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# LANGUAGE TemplateHaskell #-}+module RlangQQ.NatQQ (n) where++import Language.Haskell.TH.Quote+import Language.Haskell.TH+import Data.HList.CommonMain++{- | HList uses it's own nat, distinct from 'GHC.TypeLits.Nat', for various reasons.++Specifying those 'HNat' can be done like:++> [n| 5 |]++which is shorter than the equivalent++> hSucc $ hSucc $ hSucc $ hSucc $ hSucc hZero++-}+n :: QuasiQuoter+n = QuasiQuoter { quoteExp = natExp . read, quoteType = natTy . read, quotePat = natPat . read }++natExp :: Int -> ExpQ+natExp n = foldr appE [| hZero |] (replicate n [| hSucc |])++natTy n = [t| Proxy $(foldr appT (promotedT 'HZero) (replicate n (promotedT 'HSucc))) |]+++natPat n = sigP (varP (mkName ("nat"++show n))) (natTy n)+