Rlang-QQ 0.2.1.0 → 0.3.0.0

raw patch · 10 files changed

+214/−214 lines, 10 filesdep +Rlang-QQdep +SHAdep +data-binary-ieee754dep ~HListdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: Rlang-QQ, SHA, data-binary-ieee754, hspec, lens

Dependency ranges changed: HList, base

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• Rlang-QQ.cabal +40/−11
• doctests.hs +13/−3
• examples/Makefile +3/−6
• examples/tests.hs +22/−14
• src/HListExtras.hs +0/−14
• src/RlangQQ/Binary.hs +37/−68
• src/RlangQQ/FN.hs +0/−24
• src/RlangQQ/Internal.hs +84/−54
• src/RlangQQ/MakeRecord.hs +9/−20

@@ -0,0 +1,6 @@+# 0.3+Support positional arguments++Write input/output files to Rtmp/<hash>/ because+different hs files would create the same filename+for R input/output.

@@ -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

@@ -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":     []

@@ -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 

@@ -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)++

@@ -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--

@@ -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 

@@ -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-

@@ -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

@@ -2,28 +2,17 @@ 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+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"