diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,6 @@ +# 0.3 +Support positional arguments + +Write input/output files to Rtmp// because +different hs files would create the same filename +for R input/output. diff --git a/Rlang-QQ.cabal b/Rlang-QQ.cabal --- a/Rlang-QQ.cabal +++ b/Rlang-QQ.cabal @@ -1,5 +1,5 @@ name: Rlang-QQ -version: 0.2.1.0 +version: 0.3.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -27,6 +27,7 @@ examples/*.ipynb examples/*.html examples/Makefile + Changelog.md source-repository head type: darcs @@ -57,14 +58,31 @@ if (impl(ghc > 7.7)) default-extensions: AllowAmbiguousTypes - build-depends: base ==4.*, containers, - template-haskell <= 3, directory, process, - trifecta >= 1.4, utf8-string ==0.3.*, bytestring, - Cabal, syb, mtl, transformers, - binary, vector, HList >= 0.3.4, temporary, - text, array, zlib, - filepath, split, - haskell-src-meta + build-depends: base ==4.*, + array, + binary, + bytestring, + Cabal, + containers, + data-binary-ieee754, + directory, + filepath, + haskell-src-meta, + HList >= 0.4, + lens, + mtl, + process, + SHA, + split, + syb, + template-haskell <= 3, + temporary, + text, + transformers, + trifecta >= 1.4, + utf8-string ==0.3.*, + vector, + zlib if flag(repa) build-depends: repa @@ -73,12 +91,10 @@ exposed-modules: RlangQQ.Internal RlangQQ.Binary RlangQQ.Antiquote - RlangQQ.FN RlangQQ.NatQQ RlangQQ.MakeRecord RlangQQ.ParseKnitted RlangQQ - HListExtras other-modules: Paths_Rlang_QQ @@ -90,7 +106,20 @@ default: True test-suite doctests + default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -threaded main-is: doctests.hs build-depends: base, doctest >= 0.8 + +test-suite hspec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: examples/tests.hs + build-depends: base, + hspec, + lens, + directory, + vector, + Rlang-QQ + -- build-tools: HListPP diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -1,7 +1,17 @@ import Test.DocTest main = doctest $ "-isrc": "-idist/build/autogen": - "examples/test2.hs": - "examples/test4.hs": - "examples/test5.hs": + "-XDataKinds": + "-XConstraintKinds": + "-XDataKinds": + "-XFlexibleContexts": + "-XFlexibleInstances": + "-XFunctionalDependencies": + "-XGADTs": + "-XKindSignatures": + "-XMultiParamTypeClasses": + "-XScopedTypeVariables": + "-XTypeFamilies": + "-XTypeOperators": + "-XViewPatterns": "src/RlangQQ.hs": [] diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,19 +1,16 @@ # build and test all examples # - -SHELL = bash - default: test6.html test7.html cd ../; runghc examples/runexamples.hs - runghc examples/tests.hs + cd ../; runghc examples/tests.hs ghc -O2 romberg.hs; ./romberg %.html: %.md pandoc -s $< -o "$@" %.md: %.Rmd - R --no-save <<< 'library(knitr); knit("$<")' + R --no-save -e 'library(knitr); knit("$<")' %.Rmd.html: %.Rmd vim -c ":TOhtml" -c ":wqall" $< @@ -28,6 +25,6 @@ romberg_Double.pdf romberg_Float.pdf installdeps: - R --no-save <<< 'install.packages(c("knitr", "lattice", "reshape", "ggplot2", "lattice"))' + R --no-save -e 'install.packages(c("knitr", "lattice", "reshape", "ggplot2", "lattice"))' cabal install lens numbers hspec diff --git a/examples/tests.hs b/examples/tests.hs --- a/examples/tests.hs +++ b/examples/tests.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF HListPP #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE DataKinds, PolyKinds, FlexibleContexts, TemplateHaskell, QuasiQuotes #-} @@ -12,10 +14,6 @@ import Control.Monad import qualified Data.Vector as V -makeLabelable "x y z" - -inRecL = hLens' (Label :: Label "inRec") - inRec = [pun| x y z |] where x = "xlabel" y,z :: [Double] @@ -26,8 +24,6 @@ main = hspec $ describe "rlangqq" $ do it "can read a tsv file" $ do [pun| x@(a b) s |] <- [r| - # find the file whether we runghc tests.hs - # runghc examples/tests.hs fname <- c(Sys.glob('*.tsv'), Sys.glob('examples/*.tsv'))[1] hs_x <- as.list(read.delim(fname, sep=' ')) hs_s <- as.numeric(with(hs_x, t(a) %*% b)) @@ -39,8 +35,7 @@ o <- [r| print(hs_inRec) # should be unnecessary hs_inRec <- within(hs_inRec, y <- y + z) |] - let inR = hLens' (Label :: Label "inRec") - (o ^.inR.y) `shouldBe` zipWith (+) (inRec^.y) (inRec^.z) + (o ^. `inRec . `y) `shouldBe` zipWith (+) (inRec^.`y) (inRec^.`z) it "accumulates when variables are ch_" $ do w <- newRChan @@ -49,20 +44,20 @@ hs_inRec <- within(hs_inRec, y <- y + z + ch_w) |] out <- forM [1,2,3,4 :: Double] $ \n -> do - sendRcv w n <&> view (inRecL . y) + sendRcv w n <&> view (`inRec . `y) out `shouldBe` tail (scanl - (\ accum n -> map (+n) $ zipWith (+) (inRec^.z) accum) - (inRec^.y) + (\ accum n -> map (+n) $ zipWith (+) (inRec^. `z) accum) + (inRec^. `y) [1 .. 4]) it "repeats when variables are not ch_" $ do out <- forM [1,2,3,4 :: Double] $ \n -> do [r| print(hs_inRec) # this shouldn't be necessary to force INOUT hs_inRec <- within(hs_inRec, y <- y + z + hs_n) |] - <&> view (inRecL . y) + <&> view (`inRec . `y) out `shouldBe` - map (\n -> map (+n) (zipWith (+) (inRec^.y) (inRec^.z))) [1 .. 4] + map (\n -> map (+n) (zipWith (+) (inRec^.`y) (inRec^.`z))) [1 .. 4] it "interpolates haskell expressions" $ do ys <- forM [1,2,3,4 :: Double] $ \n -> do @@ -70,7 +65,7 @@ print(hs_inRec) hs_inRec <- within(hs_inRec, y <- y + z + $(n+1) ) |] return y - ys `shouldBe` map (\n -> map (+(1+n)) (zipWith (+) (inRec^.y) (inRec^.z))) [1 .. 4] + ys `shouldBe` map (\n -> map (+(1+n)) (zipWith (+) (inRec^.`y) (inRec^.`z))) [1 .. 4] it "can make a plot where you ask it to" $ do let x = [0 .. 10 :: Double] @@ -85,3 +80,16 @@ dev.off() |] doesFileExist "testplot.png" `shouldReturn` True + + + it "does positional arguments" $ do + let n, m :: Integer + n = 5 + m = 6 + nm <- [r| hs_x <- hs_1 * $(2) |] n m + nm `shouldBe` (`x .==. (n*m) .*. emptyRecord) + + mm <- [r| hs_x <- hs_2 * hs_2 |] n m + mm `shouldBe` (`x .==. (m*m) .*. emptyRecord) + + diff --git a/src/HListExtras.hs b/src/HListExtras.hs deleted file mode 100644 --- a/src/HListExtras.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} - -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 - - diff --git a/src/RlangQQ/Binary.hs b/src/RlangQQ/Binary.hs --- a/src/RlangQQ/Binary.hs +++ b/src/RlangQQ/Binary.hs @@ -30,6 +30,7 @@ module Data.HList.CommonMain, ) where +import Control.Lens import System.Process import Unsafe.Coerce import Control.Applicative @@ -51,6 +52,7 @@ import Data.Binary.Builder import Data.Binary.Put import qualified Data.Binary +import Data.Binary.IEEE754 (doubleToWord, wordToDouble) import qualified Data.Text as T import Data.Text.Encoding as E @@ -68,16 +70,11 @@ import qualified Codec.Compression.GZip as GZip -import HListExtras -data FLVPair = FLVPair -instance (Tagged l a ~ b) => ApplyAB FLVPair a b where - applyAB FLVPair x = Tagged x - --- this should not be necessary -type family UnHMapFLVPair (a :: [*]) :: [*] -type instance UnHMapFLVPair (Tagged l a ': as) = a ': UnHMapFLVPair as -type instance UnHMapFLVPair '[] = '[] +-- | 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) +makeWrapped ''RDA -- | this seems to be a magic number. Corresponds to R 3.0.1 putVersion = put (262153 :: Int32) @@ -94,8 +91,8 @@ -- | 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 +putDouble = put . doubleToWord +getDouble = fmap wordToDouble get getVectorDouble = do 14 <- get :: Get Int32 @@ -194,20 +191,18 @@ 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)) +type RDSHLIST2 b l = (HSequence Get b l, + HReplicateF (HLength l) FFromRDS () b, + HNat2Integral (HLength l), + HLengthEq l (HLength l)) -instance (RDSHLIST2 ___ __ l) => FromRDS (LST l) where +instance (RDSHLIST2 __ l) => FromRDS (LST l) where fromRDS = withSelf $ \(self) -> do 531 <- get :: Get Int32 let len = hNat2Integral (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) ()) + r <- hSequence $ hReplicateF (hLength self) FFromRDS () 254 <- get :: Get Int32 return (LST r) where @@ -225,33 +220,24 @@ 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) + (ListStart `HCons` (Label :: Label "names") .=. (recordLabelsString (Proxy :: Proxy (LabelsOf xs))) `HCons` HNil) type ToRDSRecord __ ___ xs = (RDSHLIST __ ___, ToRDS (LST ___), RecordValues xs, HList ___ ~ (HList (RecordValuesR xs) `HAppendR` HList '[ListStart, Tagged "names" [String]]), - RecordLabelsString (RecordLabels xs), + RecordLabelsString (LabelsOf xs), HAppend (HList (RecordValuesR xs)) (HList '[ ListStart, Tagged "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, - 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'), - HReplicate (HLength bs') FFromRDS, - HReplicateR (HLength bs')FFromRDS ~ as'2) +type FromRDSRec a c = ( + HReplicateF (HLength c) FFromRDS () a, + HSequence Get a (RecordValuesR c), + Unlabeled' c, + RecordLabelsString (LabelsOf c), + HNat2Integral (HLength c)) {- | R lists become HList records. @list(x=1,y='b')@ parses to something like @@ -265,53 +251,40 @@ You have to get the result type right (ie. @Record [Tagged \"x\" Double, Tagged \"y\" String]@) for things to parse -} -instance FromRDSRec a b as' as'2 bs' => FromRDS (Record bs') where +instance FromRDSRec b d => FromRDS (Record d) where fromRDS = do 531 <- get :: Get Int32 - let len = hNat2Integral (Proxy :: Proxy (HLength bs')) + let lenN = Proxy :: Proxy (HLength d) + len = hNat2Integral lenN 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 (Proxy :: Proxy (HLength bs')) FFromRDS) ) - ()) + c <- hSequence (hReplicateF lenN FFromRDS ()) + getListHdr "names" <- getString names :: [String] <- fromRDS - let names' = recordLabelsString (error "recLabs" :: Proxy (RecordLabels bs')) + let names' = recordLabelsString (Proxy :: Proxy (LabelsOf d)) 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') :: HList bs')) - -- this hMap1 can't be replaced by hMap? + return (c ^. from unlabeled) -class RecordLabelsString (a :: [Symbol]) where +class RecordLabelsString (a :: [*]) where recordLabelsString :: Proxy a -> [String] instance RecordLabelsString '[] where recordLabelsString _ = [] instance (ShowLabel x, RecordLabelsString xs) - => RecordLabelsString (x ': xs) where + => RecordLabelsString (Label 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(Tagged l a ~ x, y ~ Label l) => ApplyAB FLabelLVPair x y where - applyAB FLabelLVPair _ = (Label :: Label l) -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 @@ -387,7 +360,8 @@ putVersion getListHdr = do - [1026, 1, 262153] <- replicateM 3 (get :: Get Int32) + [1026, 1] <- replicateM 2 (get :: Get Int32) + _ <- getVersion return () @@ -407,10 +381,6 @@ x <- fromRDS return (Tagged 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 (Tagged l2 t ': rs)) where toRDS (RDA (x `HCons` xs)) = do @@ -633,23 +603,22 @@ > Record '[Tagged l1 (Tagged m1 x), Tagged l2 (Tagged m2 x)] -The outer labels (@l1@, @l2@) are the haskell-side. The inner labels +The outer labels (@l1@, @l2@) are those used on 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 :: FromRDA r => B.ByteString -> Record r fromRDA x = ( $ GZip.decompress x) $ runGet $ do let hdr = "RDX2\nX\n" hdr' <- fmap (BS.toString) $ getByteString (BS.length (BS.fromString hdr)) unless (hdr == hdr') $ fail "wrong header" [{- 2 , 196609, 131840 -} _, _, _ :: Int32 ] <- replicateM 3 get - fmap (\(RDA a) -> Record (hMap FLVPair (a::HList __) )) fromRDS + fromRDS <&> view ( _Wrapping RDA . from unlabeled) -type FromRDA a r = (HMapCxt FLVPair (HList a) (HList r) a r, FromRDS (RDA a)) +type FromRDA r = (Unlabeled' r, FromRDS (RDA (RecordValuesR r))) -- * tests diff --git a/src/RlangQQ/FN.hs b/src/RlangQQ/FN.hs deleted file mode 100644 --- a/src/RlangQQ/FN.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- | 'hMap' 'FN' drops the inner Tagged, 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 ~ (Tagged (t :: k) (Tagged (t2::k) x)), b ~Tagged t x) => ApplyAB FN a b where - applyAB _ (Tagged (Tagged x)) = Tagged x - -data NoLabel = NoLabel -instance (la ~ Tagged "" a) => ApplyAB NoLabel a la where - applyAB _ x = Tagged x - diff --git a/src/RlangQQ/Internal.hs b/src/RlangQQ/Internal.hs --- a/src/RlangQQ/Internal.hs +++ b/src/RlangQQ/Internal.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NoCPP #-} module RlangQQ.Internal where import System.IO.Temp import System.IO import Control.Applicative +import Data.Char import Data.List import Data.Maybe import Data.Monoid @@ -16,18 +17,22 @@ import System.Process import Text.Printf import Text.Trifecta +import Text.Read (readMaybe) import qualified Data.ByteString.Lazy.UTF8 as B import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy import qualified Data.ByteString.Lazy.Char8 as B8 +import qualified Data.Digest.Pure.SHA as SHA + import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Generics import qualified Data.Traversable as T import qualified Data.Map as M import Data.Foldable (foldMap) +import qualified Data.Set as S import System.FilePath @@ -35,13 +40,14 @@ import RlangQQ.Binary import RlangQQ.Antiquote -import RlangQQ.FN -- import RlangQQ.ParseKnitted import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Concurrent +import Control.Lens hiding (noneOf) + import System.IO.Unsafe import Data.IORef @@ -49,25 +55,33 @@ -- | going via binary serialization (classes from "RlangQQ.Binary"). This is used in 'RlangQQ.r' quoteRExpression2 i returnChan str0 = do - let rawFile, mdFile, rmdFile, inputFile, inputFile2, outputFile, figPath :: String - rawFile = printf "Rtmp/raw%d.R" (i :: Int) - rmdFile = printf "Rtmp/raw%d.Rmd" i - rmdFile2 = printf "Rtmp/raw%d_.Rmd" i - mdFile = printf "Rtmp/raw%d.md" i - figPath = printf "Rtmp/fig%d/" i - inputFile = printf "Rtmp/%d_hs.rdx" i - inputFile2 = printf "Rtmp/%d_hs2.rdx" i - outputFile = printf "Rtmp/%d_r.rdx" i + let str0Hash = take 8 $ SHA.showDigest (SHA.sha1 (B8.pack str0)) + rawFile, mdFile, rmdFile, inputFile, inputFile2, outputFile, + figPath :: String + rawFile = printf "Rtmp/%s/raw%d.R" str0Hash (i :: Int) + rmdFile = printf "Rtmp/%s/raw%d.Rmd" str0Hash i + rmdFile2 = printf "Rtmp/%s/raw%d_.Rmd" str0Hash i + mdFile = printf "Rtmp/%s/raw%d.md" str0Hash i + figPath = printf "Rtmp/%s/fig%d/" str0Hash i + inputFile = printf "Rtmp/%s/%d_hs.rdx" str0Hash i + inputFile2 = printf "Rtmp/%s/%d_hs2.rdx" str0Hash i + outputFile = printf "Rtmp/%s/%d_r.rdx" str0Hash i - -- the print('') is to fix a bug that somehow drops the first - -- expression sent to R - (knitrHdr, withRawFile -> (("setwd('../');"++) -> str, addAntiquotes)) + (knitrHdr, withRawFile -> (("setwd('../../'); getwd();"++) -> str, addAntiquotes)) = splitKnitrHdr str0 let inRmdChunk s = unlines ["```{r " ++ knitrHdr ++ "}", s, "```"] variables <- runIO $ do - t <- getDataFileName "Tree.R" - createDirectoryIfMissing False "Rtmp" + t <- do + t1 <- getDataFileName "Tree.R" + b <- doesFileExist t1 + -- for the benefit of "cabal test" + -- which does not set the environment variable + -- Rlang_QQ_datadir=rsrc, and you don't necessarily + -- have Tree.R installed in the ~/.cabal/... yet + return $ if b then t1 else "rsrc/Tree.R" + + createDirectoryIfMissing True ("Rtmp/" ++ str0Hash) writeFile rawFile str writeFile rmdFile (inRmdChunk str) rt <- readProcess "R" ["--no-save","--quiet"] @@ -78,9 +92,6 @@ print a error "parse failure" - -- 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 @@ -120,8 +131,8 @@ sampOutput' :: (String -> ExpQ) -> ExpQ sampOutput' addLabels = mkHList [ [| $(addLabels x) $(case intent of - Out -> [| undefined |] -- no input value whose - -- type should unify with + Out -> [| error ("RlangQQ.Internal.sampOutput" ++ + " should not be evaluated") |] _ -> var x ) |] | (x, intent) <- M.toList variables, notIn intent ] @@ -133,16 +144,18 @@ readOutputFile :: ExpQ readOutputFile = [| - let mapSnd (Record x) = Record (hMap FN x) + let -- Record '[Tagged "x" (Tagged "x1" a)] -> Record '[Tagged "x" a] + dropInnerTagged x = over unlabeled (^. to Record . unlabeled) x fixTy x = x `asTypeOf` Record $sampOutput - fixTy2 x = x `asTypeOf` Record $sampOutput2 in do cts <- B.readFile outputFile -- lazy IO makes for confusings: possibly better to switch -- over to strict BS instead of this Data.ByteString.Lazy.length cts `seq` return () - return . fixTy2 . mapSnd . fixTy $ fromRDA cts |] + -- to stop ghc-7.6 from having a type error: + return . $(varE 'dropInnerTagged) . fixTy $ fromRDA cts |] + outVars :: [String] outVars = [ s | (s, intent) <- M.toList variables ++ M.toList chanVars {- necessary? -}, notIn intent ] @@ -206,9 +219,9 @@ ov output $(whenQ returnChan - ([| (`writeChan` output) |] `appE` [| chOut |]) - -- should be writeChan chOut output - -- but that doesn't typecheck here... + [| $(varE 'writeChan) chOut output |] + -- rewrite to: [| writeChan chOut output |] + -- when ghc-7.6 support is dropped ) |]) return chOut @@ -216,16 +229,23 @@ runIO $ writeFile rmdFile2 rmd2Content - addAntiquotes [| do + let positionalVariablesIx :: M.Map Int (S.Set String) + positionalVariablesIx = M.fromListWith (<>) + $ mapMaybe (\ k -> do + n <- readMaybe =<< msum (map (`stripPrefix` k) prefixes) + return (n, S.singleton k)) + $ [ v | (v, intent) <- M.toList variables, + intent `elem` [In,InOut] ] + + addLambda positionalVariablesIx $ addAntiquotes [| do {- already done, but Rtmp could have moved - since compile time -} - createDirectoryIfMissing False "Rtmp" - do - f <- doesFileExist rmdFile2 - unless f $ writeFile rmdFile2 rmd2Content + since compile time, or another RlangQQ could + have overwritten the file -} + createDirectoryIfMissing True ("Rtmp" str0Hash) + writeFile rmdFile2 rmd2Content $writeInputFile - $(if M.size chanVars == 0 then [| do + $(if M.null chanVars then [| do $runRNoChan $( whenOutVars readOutputFile) |] else runRChan) @@ -254,6 +274,8 @@ (\(a,b,c) -> (a,b)) $ foldr (\ chunk ~( str, ef, i) -> case chunk of + Left (LitE (IntegerL p)) -> ("hs_" ++ show p ++ " " ++ str, + ef, i) Left x -> let v = "hs_interp" ++ show i in ( concat [v, " ", str], @@ -268,6 +290,31 @@ parsed +addLambda :: M.Map Int (S.Set String) -> ExpQ -> ExpQ +addLambda ps xp + | Just ((pMax,_), _ ) <- M.maxViewWithKey ps = do + let allPS = M.fromList [ (n,()) | n <- [1 .. pMax] ] + case M.keys $ ps M.\\ allPS of + [] -> return () + extra -> reportWarning ("Unexpected positional arguments " ++ show extra) + + case M.keys $ allPS M.\\ ps of + [] -> return () + unused -> reportWarning ("Positional argument not used " ++ show unused) + + case [ p0 | p0 <- M.elems ps, + S.size p0 > 1 ] of + [] -> return () + duplicates -> reportError ("Positional argument types must be the same " ++ show duplicates ) + + lamE [ case M.lookup n ps of + Just (S.toList -> [e]) -> varP (mkName e) + Nothing -> wildP + | n <- [1 .. pMax] ] xp + | otherwise = xp + + + -- ** 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) @@ -279,7 +326,9 @@ label x = [| Label :: Label $(litT (strTyLit (dropHS x))) |] label' x = [| Label :: Label $(litT (strTyLit x)) |] -var x = varE (mkName (dropHS x)) +var x = varE $ mkName $ case dropHS x of + x' | all isDigit x' -> x + | otherwise -> x' mkHList :: [ExpQ] -> ExpQ mkHList = foldl (\ b a -> [| $a .*. $b |]) [| HNil |] @@ -359,25 +408,6 @@ 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 diff --git a/src/RlangQQ/MakeRecord.hs b/src/RlangQQ/MakeRecord.hs --- a/src/RlangQQ/MakeRecord.hs +++ b/src/RlangQQ/MakeRecord.hs @@ -2,28 +2,17 @@ module RlangQQ.MakeRecord where import GHC.TypeLits -- prevents a panic lookupVers2 <
> with ghc 7.6. Fixed later probably from #7502 -import Control.Monad.State -import Control.Monad.Identity import Data.HList.CommonMain -import HListExtras +import Control.Lens + -- | 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 $ hMap 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)) __, - HMapCxt NoLabel (HList __) (HList r) __ r) - - - -data NoLabel = NoLabel -instance (Tagged "" a ~ la) => ApplyAB NoLabel a la where - applyAB _ x = Tagged x +-- +-- > listToRecN :: _ => Proxy (n :: HNat) -> [x] -> Record (HReplicateR n (Tagged "" x)) +listToRecN n xs = maybe (error msg) (`asTypeOf` es) + $ xs ^? listAsHList . from unlabeled + where es = (undefined :: Proxy n -> [x] -> Record (HReplicateR n (Tagged "" x))) + n xs + msg = "RlangQQ.listToRecN too few elements"