packages feed

NGLess (empty) → 1.4.0

raw patch · 97 files changed

+15976/−0 lines, 97 filesdep +HUnitdep +MissingHdep +NGLesssetup-changed

Dependencies added: HUnit, MissingH, NGLess, QuickCheck, aeson, ansi-terminal, async, atomic-write, base, bytestring, bytestring-lexing, bzlib-conduit, conduit, conduit-algorithms, conduit-extra, configurator, containers, convertible, criterion, data-default, deepseq, diagrams-core, diagrams-lib, diagrams-svg, directory, double-conversion, edit-distance, either, errors, exceptions, extra, file-embed, filemanip, filepath, hashable, hashtables, hostname, http-client, http-conduit, inline-c, inline-c-cpp, int-interval-map, mtl, network, optparse-applicative, parsec, primitive, process, regex, resourcet, safe, safeio, stm, stm-chans, stm-conduit, strict, tar, tar-conduit, tasty, tasty-hunit, tasty-quickcheck, tasty-th, template-haskell, text, time, transformers, unix, unix-compat, unliftio, unliftio-core, vector, vector-algorithms, yaml, zlib

Files

+ COPYING view
@@ -0,0 +1,25 @@+Copyright (c) 2012-2022+Luis Pedro Coelho <luis@luispedro.org>+Paulo Monteiro+Renato Alves <renato.alves@embl.de>++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ ChangeLog view
@@ -0,0 +1,192 @@+Version 1.4.0 2022-05-30 by luispedro+	* Add --trace argument to all modes+	* Update --create-reference-pack mode to newer format (previous version worked, but+	users still had to recreate indices after downloading, negating some of+	the benefits+	* Update --install-reference-data mode to download latest version (#107)+	* Update --create-reference-pack mode to download latest version (#108)+	* Do not fail when merging empty files (#113)+	* write() returns the filename used+	* Switch to tasty test framework+	* Update to LTS-19+	* write() uses multiple threads to write multiple FQ files+	* Use binaries from path (not self installed)+	* Better error message when parsing misformed FastQ files+	* Overhall building infrastructure to use haskell.nix and build+	dependencies with nix+	* Update megahit version+	* Added GMGC to builtin Modules+	* Make `--print-path minimap2` work correctly++Version 1.3.0 2021-01-28 by luispedro+	* Validate count() headers on --validate-only+	* Better error message if the user attempts to use the non-existent <\>+	operator (suggest </>)+	* Add min-ngless-version field for modules+	* Add early check that block assignments are always to block variables+	* Use ZStd compression for temporary files from preprocess()+	* Correctly handle subpaths in samples for collect (fixes #141)+	* Add to_string() to int and double types (partially fixes #78 & fixes #81)+	* Add read_int() and read_double() functions (fixes #78)++Version 1.2.0 2020-07-12 by luispedro+	* Add load_fastq_directory to builtin functions+	* Better messages when using `lock1`+	* Enable specifying *all* module resources by URL with download on first+	use+	* Fix CIGAR reinjection bug+	* Remove old motus/specI modules+	* No longer ship JS libraries (also do not expand them in-place)++Version 1.1.0 2020-01-25 by luispedro+	* Reintroduce zstd compression (after fixes upstream)+	* Fix CIGAR interpretation (#109) occurring when I is present+	* Call bwa mem so that it behaves in a deterministic way (independently of+	the number of threads used)+	* Add `include_fragments` option to orf_find+	* Add early check for column headers in `count()`+	* Update to LTS-14.1 (fixes #116)+	* Add ``sense`` argument to `count()`+	* Add line numbers to FastQ parsing errors+	* Fix __extra_args argument in map()+	* Add `discard_singles` function+	* Add `interleaved` option to fastq()+	* `load_mocat_sample` now fails if `pair.2` exists but `pair.1` doesn't++Version 1.0.1 2019-07-05 by luispedro+	* Fix bug with external modules and multiple fastQ inputs+	* Fix bug with resaving input files where the original file was sometimes+	moved (thus removing it).++Version 1.0.0 2019-04-24 by luispedro+	* Fix multiple features usage (#63)+	* Update minimap2/megahit to latest versions++Version 0.11.1 2019-03-21 by luispedro+	* Fix reinjectSequence in select() call with blocks+	* Remove zstd compression+	* Fix SAM order switching in select() call with blocks (#105)+	* Compress SAM files after select() calls++Version 0.11.0 2019-03-15 by luispedro+	* Switch to diagrams package for plotting+	* Update minimap2 version to 2.14+	* Module samtools (version 0.1) now includes samtools_view+	* Update to LTS-13 (GHC 8.6)+	* Fix bug with orf_find & prots_out argument+	* Call bwa/minimap2 with interleaved fastq files+	* Add --verbose flag to check-install mode+	* Avoid leaving open file descriptors after FastQ encoding detection+	* Fix bug in garbage collection+	* Compress intermediate SAM files (#22)+	* Tar extraction uses much less memory (#77)+	* Add early checks for input files in more situations (#33)+	* Support compression in collect() output (#42)+	* Fix CIGAR (#92) for select() blocks+	* Add smoothtrim function+	* Fix lock1()/collect() use with --subsample+	* Fix compression/decompression when calling external modules++Version 0.10.0 2018-11-12 by luispedro+	* Fix to lock1's return value when used with paths (#68 - reopen)+	* Support _F/_R suffixes for forward/reverse in load_mocat_sample+	* samtools_sort() now accepts by={name} to sort by read name+	* Fixed bug where header was printed even when STDOUT was used+	* Fixed bug where writing interleaved FastQ to STDOUT did not work as+	expected+	* Indices created by bwa and minimap2 are now versioned+	* arg1 in external modules is no longer always treated as a path+	* Added expand_searchpath to external modules API (closes #56)+	* Fixed bug where detection of Fastq encoding was not performed on the second pair+	* Fix saving fastq sets with --subsample (issue #85)+	* Add __extra_megahit_args to assemble() (issue #86)+	* Better error message when user mis-specifies the ngless version string+	(issue #84)+	* Support NO_COLOR environment variable (issue #83)+	* Garbage collection for temporary files (issue #79)+	* Rename --search-dir to --search-path for consistency with other API+	* Fix corner case with select() producing incorrect CIGAR strings (#92)+	* Always check output file writability (#91)+	* Make paired() accept encoding argument++Version 0.9.1 2018-07-17 by luispedro+	* Add biorxiv citation++Version 0.9.0 2018-07-12 by luispedro+	* Add allbest() method to mappedreads+	* Output FastQ quality graphs as PNGs+	* Added MouseGutCatalog module+	* Added DogGutGeneCatalog module+	* Added PigGeneCatalog module+	* Added reference genome for Sus scrofa (pig)+	* Update IGC module to 0.9+	* Continuously update mtime on all lock files+	* Warn when overwriting files+	* Version automatically downloaded reference URLs++Version 0.8.1 2018-06-05 by luispedro+	* Update to LTS-11.12 (for faster conduit-algorithms used in collect())+	* Add fallback for character encoding on systems with bad locale support+	* Fixed lock1 when used with paths (#68)+	* Fixed expansion of searchdir with external modules (#56)++Version 0.8.0 2018-05-06 by luispedro+	* Add minimap2 support as alternative mapper+	* Faster collect()+	* Fix writing of multiple compressed files to uncompressed format+	* Add `n_to_zero_quality` method for short reads+	* Add </> operator for path manipulation+	* Fix bug in select (corner case where sequences would be missing from+	output)+	* Add non-ATCG fraction field to FastQ statistics+	* Add reference argument to count()+	* GFF based counting now expands multi-value sub-features+	* Update to bwa 0.7.17++Version 0.7.1 2018-03-17 by luispedro+	* Fix memory leak in count()+	* Fix when-true flag usage with external modules++Version 0.7.0 2018-03-07 by luispedro+	* Add 'failed' files to parallel lock1()+	* Add `max_trim` argument to MappedReadSet.filter()+	* Support saving compressed SAM files+	* Much faster select() implementation with a block+	* Fix count's mode {intersection_strict} to no longer behave as {union}+	* Support for saving interleaved FastQ files+	* Lower memory usage+	* More conservative SAM merging in split mode+	* Compute #Basepairs in FastQ stats+	* Fix as_reads() for single-end reads+	* Add headers argument to samfile()+	* For more situations, avoid intermediate copies in count()+	* Much improved memory and speed performance of count()+	* Fix select() corner case++Version 0.6.1 2017-12-10 by luispedro+	* Add --check-install mode+	* Fix streaming short read QC (performance regression)+	* Better error message in readlines() when file opening fails+	* Compute statistics after select()++Version 0.6.0 2017-11-29 by luispedro+	* Add `orf_find` function (implemented through Prodigal)+	* Add qcstats() function+	* Output preprocessed FQ statistics (had been erroneously removed)+	* Fix --strict-threads command-line option spelling+	* Use multiple threads in SAM->BAM conversion+	* Change include_m1 default in count() function to True+	* Add --index-path functionality to define where to write indices (issue #47)+	* Allow `citations` as key in external modules+	* Better citations information+	* Better error checking/script validation+	* Added reference alias for a more human readable name+	* Version embedded megahit binary+	* Updated builtin referenced to include latest releases of assemblies+	* Fixed inconsistency between reference identifiers and underlying files++Version 0.5.1 2017-11-02 by luispedro+	* Fix building step (static compilation)++Version 0.5.0 2017-11-01 by luispedro+	* First release supporting all basic functionality.
+ Execs/Bench.hs view
@@ -0,0 +1,138 @@+{- Copyright 2016-2019+ - Licence: MIT -}+import Criterion.Main+++import qualified Data.Vector as V+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit as C+import qualified Data.ByteString as B+import qualified Data.Text as T+import           Data.Conduit ((.|))+import           Control.DeepSeq (NFData)++import Control.Monad.Trans.Resource (runResourceT)++import BuiltinFunctions (builtinModule)+import NGLess (NGLessIO, testNGLessIO)+++import Interpretation.Count (performCount+                            , MMMethod(..)+                            , loadFunctionalMap+                            , CountOpts(..)+                            , AnnotationMode(..)+                            , StrandMode(..)+                            , annotationRule+                            , AnnotationIntersectionMode(..)+                            , Annotator(..)+                            , NMode(..))+import Interpretation.Substrim (substrim)+import StandardModules.Parallel (pasteCounts)+import Interpret (interpret)+import FileOrStream (FileOrStream(..))+import Parse (parsengless)+import Language (Script(..))+import Data.Sam (readSamLine, readSamGroupsC', samStatsC)+import Data.FastQ (FastQEncoding(..), ShortRead(..), fqDecodeVector)+import Utils.Conduit (linesC, ByteLine(..), linesVC)+import Transform (transform)+import NGLess.NGLEnvironment (NGLVersion(..), setupTestEnvironment, setModulesForTestingPurposesOnlyDoNotUseOtherwise)++nfNGLessIO :: (NFData a) => NGLessIO a -> Benchmarkable+nfNGLessIO = nfIO . testNGLessIO++nfNGLessScript :: T.Text -> Benchmarkable+nfNGLessScript sc = case parsengless "bench" False sc of+    Left err -> error (show err)+    Right expr -> nfNGLessIO $ interpret [] . nglBody $ expr++nfNGLessScriptWithTransform :: T.Text -> Benchmarkable+nfNGLessScriptWithTransform code = case parsengless "bench" False code of+    Left err -> error (show err)+    Right sc -> nfNGLessIO $ do+        let mods = [builtinModule (NGLVersion 1 4)]+        setModulesForTestingPurposesOnlyDoNotUseOtherwise mods+        sc' <- transform mods sc+        interpret mods (nglBody sc')+++nfRIO = nfIO . runResourceT+countRights = loop (0 :: Int)+    where+        loop !i = C.await >>= \case+            Nothing -> return i+            Just (Right !_) -> loop (i+1)+            Just (Left !_) -> loop i++rightOrDie (Right r) = r+rightOrDie err = error $ "Expected Right, got: " ++ show err+exampleSR :: ShortRead+exampleSR = V.head . rightOrDie . fqDecodeVector 0 SangerEncoding $ V.fromList+                [ByteLine "@SRR867735.1 HW-ST997:253:C16APACXX:7:1101:2971:1948/1"+                ,ByteLine "NCCGCTGCTCGGGATCAAGACATACCGCGGGGGGAGGGGAGCGGGACCAC"+                ,ByteLine "+"+                ,ByteLine "#11ABDD6DFBDFHEGHDDGFFFHE?@GEEGA##################"]+++count= loop (0 :: Int)+    where+        loop !i = C.await >>= \case+            Nothing -> return i+            Just _ -> loop (i+1)++basicCountOpts = CountOpts+        { optFeatures = []+        , optSubFeatures = Nothing+        , optIntersectMode = annotationRule IntersectStrict+        , optAnnotationMode = AnnotateSeqName+        , optStrandMode = SMBoth+        , optMinCount = 0.0+        , optMMMethod = MMDist1+        , optDelim = "\t"+        , optNormMode = NMRaw+        , optIncludeMinus1 = True+        }++main = setupTestEnvironment >> defaultMain [+    bgroup "sam-stats"+        [ bench "sample" $ nfNGLessIO (C.runConduit (CB.sourceFile "test_samples/sample.sam" .| linesVC 4096 .| samStatsC))+        ]+    ,bgroup "fastq"+        [ bench "fastqStats" $ nfNGLessIO (C.runConduit (conduitPossiblyCompressedFile "test_samples/sample.fq.gz" .| linesC .| count))+        , bench "preprocess" $ nfNGLessScript                          "p = fastq('test_samples/sample.fq.gz')\npreprocess(p) using |r|:\n  r = substrim(r, min_quality=26)\n  if len(r) < 45:\n    discard"+        , bench "preprocess-transformed" $ nfNGLessScriptWithTransform "p = fastq('test_samples/sample.fq.gz')\npreprocess(p) using |r|:\n  r = substrim(r, min_quality=26)\n  if len(r) < 45:\n    discard"+        , bench "preprocess-pair" $ nfNGLessScript+                "p = paired('test_samples/sample.fq.gz', 'test_samples/sample.fq.gz')\npreprocess(p) using |r|:\n  r = substrim(r, min_quality=26)\n"+        , bench "preprocess-pair-transformed" $ nfNGLessScriptWithTransform+                "p = paired('test_samples/sample.fq.gz', 'test_samples/sample.fq.gz')\npreprocess(p) using |r|:\n  r = substrim(r, min_quality=26)\n"+        , bench "preprocess-pair-nop" $ nfNGLessScriptWithTransform+                "p = paired('test_samples/sample.fq.gz', 'test_samples/sample.fq.gz')\npreprocess(p) using |r|:\n  r = r\n"+        , bench "substrim" $ nf (substrim 30) exampleSR+        ]+    ,bgroup "conduit"+        [ bench "raw"      $ nfNGLessIO (C.runConduit (conduitPossiblyCompressedFile "test_samples/sample.sam.gz" .| CB.lines .| (CC.conduitVector 1024 :: C.ConduitT B.ByteString (V.Vector B.ByteString) NGLessIO ()) .| count))+        , bench "linesC"   $ nfNGLessIO (C.runConduit (conduitPossiblyCompressedFile "test_samples/sample.sam.gz" .| linesC .| (CC.conduitVector 1024 :: C.ConduitT ByteLine (V.Vector ByteLine) NGLessIO ()) .| count))+        , bench "linesVC"  $ nfNGLessIO (C.runConduit (conduitPossiblyCompressedFile "test_samples/sample.sam.gz" .| (linesVC 1024 :: C.ConduitT B.ByteString (V.Vector ByteLine) NGLessIO ()) .| count))+        ]+    ,bgroup "parse-sam"+        [ bench "readSamLine" $ nfRIO (C.runConduit (CB.sourceFile "test_samples/sample.sam" .| CB.lines .| CL.map readSamLine .| countRights))+        , bench "samGroups" $ nfNGLessIO (C.runConduit (CB.sourceFile "test_samples/sample.sam" .| linesVC 2048 .| readSamGroupsC' 1 True .| count))+        ]+    ,bgroup "count"+        [ bench "load-map"      $ nfNGLessIO (loadFunctionalMap "test_samples/functional.map" ["KEGG_ko", "eggNOG_OG"])+        , bench "annotate-seqname" . nfNGLessIO $ performCount (File "test_samples/sample.sam") "testing" [SeqNameAnnotator Nothing] basicCountOpts+        , bench "annotate-functionalmap" . nfNGLessIO $ do+                    amap <- loadFunctionalMap "test_samples/functional.map" ["KEGG_ko", "eggNOG_OG"]+                    performCount (File "test_samples/sample.sam") "testing" amap basicCountOpts+        ]+    ,bgroup "parallel"+        [ bench "paste-sparse"   $ nfNGLessIO (pasteCounts [] False ["sample" | _ <- [(0 :: Int)..127]]+                                                                ["test_samples/merge/sp_sample_"++show i | i <- [(0 :: Int)..127]])+        , bench "paste-dense"    $ nfNGLessIO (pasteCounts [] True ["sample" | _ <- [(0 :: Int)..127]]+                                                                ["test_samples/merge/sample_"++show i | i <- [(0 :: Int)..127]])+        ]+    ]
+ Execs/Main.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE PackageImports #-}+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}+module Main+    ( main+    ) where++{-| #Structure of ngless+ -+ - # Basic ngless interpretation workflow:+ -+ - 1. The whole text is loaded into memory (after UTF-8 decoding). Scripts are small.+ - 2. A complete abstract syntax tree is built.+ - 	These steps are implemented in Tokens.hs & Parse.hs+ - 	The AST is represented with types defined in Language.hs+ - 3. Modules are loaded.+ - 	This step is implemented in Main.hs.+ - 	NGless has several implicit modules (i.e., functionality which is+ - 	implemented as a module, but which the user does not have to import).+ - 	See Modules.hs for more information about modules.+ - 4. The syntax tree is validated. This includes several checks for sanity.+ - 	These steps are implemented in Types.hs (basic type validation)+ - 	followed by Validation.hs and ValidationIO.hs+ - 5. The syntax tree is transformed.+ - 	This step is implemented in Transform.hs. This performs simplification+ - 	and optimization of the tree.+ - 6. The syntax tree is interpreted.+ - 	This step is implemented in Interpret.hs+ - 	Most of the work is then performed by functionality inside+ - 	Interpretation/ or in the implicitly (or explicitly) imported modules+ - 	in BuiltinModules or StandardModules+ -+-}++import Data.Maybe+import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO(..))+import Options.Applicative+import System.FilePath+import System.Directory+import Control.Monad.Extra (whenJust, whenM)+import System.IO (stdout, stderr, stdin, hPutStrLn, mkTextEncoding, hGetEncoding, Handle, hSetEncoding)+import Control.Exception (catch, try, throwIO, fromException, displayException)+import Control.Concurrent (setNumCapabilities)+import System.Console.ANSI (setSGRCode, SGR(..), ConsoleLayer(..), Color(..), ColorIntensity(..))+import System.Exit (exitSuccess, exitFailure, ExitCode(..))++import Control.Monad.Trans.Resource++import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as B++import Interpret+import JSONScript (writeScriptJSON)+import Validation+import ValidationIO+import Transform+import Language+import Types+import Parse+import Configuration+import qualified Version+import ReferenceDatabases+import Output+import NGLess+import NGLess.NGError+import NGLess.NGLEnvironment+import Modules+import qualified CmdArgs+import FileManagement+import StandardModules.NGLStdlib+import Citations (collectCitations)+import Utils.Network+import Utils.Batch (getNcpus)+import Utils.Suggestion+import CWL (writeCWL)++import           BuiltinFunctions (builtinModule)+import qualified BuiltinModules.Argv as ModArgv+import qualified BuiltinModules.Assemble as ModAssemble+import qualified BuiltinModules.Checks as Checks+import qualified BuiltinModules.AsReads as ModAsReads+import qualified BuiltinModules.LoadDirectory as ModLoadDirectory+import qualified BuiltinModules.Readlines as Readlines+import qualified BuiltinModules.Remove as Remove+import qualified BuiltinModules.QCStats as ModQCStats+import qualified BuiltinModules.ORFFind as ModORFFind+++-- | wrapPrint transforms the script by transforming the last expression <expr>+-- into write(<expr>, ofile=STDOUT)+wrapPrint :: Script -> NGLess Script+wrapPrint (Script v sc) = Script v <$> wrap sc+    where+        wrap :: [(Int,Expression)] -> NGLess [(Int,Expression)]+        wrap [] = return []+        wrap [(lno,e)]+            | wrapable e = return [(lno,addPrint e)]+            | otherwise = throwScriptError "Cannot add write() statement at the end of script (the script cannot terminate with a print/write call)"+        wrap (e:es) = wrap es >>= return . (e:)+        addPrint e = FunctionCall (FuncName "write") e [(Variable "ofile", BuiltinConstant (Variable "STDOUT"))] Nothing++        wrapable (FunctionCall (FuncName f) _ _ _)+            | f `elem` ["print", "write"] = False+        wrapable _ = True++redColor :: String+redColor = setSGRCode [SetColor Foreground Dull Red]++fatalError :: String -> IO a+fatalError err = do+    hPutStrLn stderr "Exiting after fatal error:"+    hPutStrLn stderr (redColor ++ err)+    hPutStrLn stderr $ setSGRCode [Reset]+    exitFailure+++runNGLessIO :: String -> NGLessIO a -> IO a+runNGLessIO context (NGLessIO act) = try (runResourceT act) >>= \case+        Left (NGError NoErrorExit _) -> exitSuccess+        Left (NGError etype emsg) -> do+            triggerFailHook+            hPutStrLn stderr ("Exiting after fatal error while " ++ context)+            case etype of+                ShouldNotOccur ->+                    hPutStrLn stderr $+                        "Should Not Occur Error! This probably indicates a bug in ngless.\n" +++                        "\tPlease get in touch with the authors with a description of how this happened.\n" +++                        "\tIf possible run your script with the --trace flag and post the script and the resulting trace at\n"+++                        "\t\thttps://github.com/ngless-toolkit/ngless/issues.\n"+                ScriptError ->+                    hPutStrLn stderr "Script Error (there is likely an error in your script)"+                DataError ->+                    hPutStrLn stderr "Data Error (the input data did not conform to NGLess' expectations)"+                SystemError ->+                    hPutStrLn stderr "System Error (NGLess was not able to access some necessary resource)"+                _ -> return ()+            hPutStrLn stderr (redColor ++ emsg)+            hPutStrLn stderr $ setSGRCode [Reset]+            exitFailure+        Right v -> return v++-- | Load both automatically imported modules and user-requested ones+loadModules :: NGLVersion -> [ModInfo] -> NGLessIO [Module]+loadModules av mods  = do+    mA <- ModAsReads.loadModule ("" :: T.Text)+    mArgv <- ModArgv.loadModule ("" :: T.Text)+    mAssemble <- ModAssemble.loadModule ("" :: T.Text)+    mLoadDirectory <- ModLoadDirectory.loadModule ("" :: T.Text)+    mReadlines <- Readlines.loadModule ("" :: T.Text)+    mChecks <- Checks.loadModule ("" :: T.Text)+    mRemove <- Remove.loadModule ("" :: T.Text)+    mStats <- ModQCStats.loadModule ("" :: T.Text)+    mOrfFind <- ModORFFind.loadModule ("0.6" :: T.Text)+    imported <- loadStdlibModules mods+    let loaded = [builtinModule av]+                    ++ [mOrfFind | av >= NGLVersion 0 6]+                    ++ [mLoadDirectory | av >= NGLVersion 1 2]+                    ++ [mReadlines, mArgv, mAssemble, mA, mChecks, mRemove, mStats] ++ imported+    forM_ loaded registerModule+    return loaded+++headerStr :: String+headerStr = "NGLess v"++Version.versionStr++" (C) NGLess authors\n"+++            "https://ngless.embl.de/\n"+++            "\n"++formatCitation :: T.Text -> String+formatCitation citation = T.unpack . T.unlines . map T.unwords $ citationLines+    where+        lineMax = 90+        wordsWithPrefix = "-":T.words citation+        citationLines :: [[T.Text]]+        citationLines = groupLines wordsWithPrefix+        groupLines :: [T.Text] -> [[T.Text]]+        groupLines [] = []+        groupLines (w:ws) = groupLines' [w,"\t"] (2 + T.length w) ws+        groupLines' acc _ [] = [reverse acc]+        groupLines' acc n rest@(w:ws)+            | T.length w + n > lineMax = reverse acc:groupLines rest+            | otherwise = groupLines' (w:acc) (n + T.length w) ws+++printHeader :: [T.Text] -> NGLessIO ()+printHeader citations = liftIO $ do+    putStr headerStr+    unless (null citations) $ do+        putStr "When publishing results from this script, please cite the following references:\n\n"+        forM_ citations $ \c ->+            putStrLn (formatCitation c)+        putStr "\n"++loadScript :: CmdArgs.NGLessInput -> IO (Either String T.Text)+loadScript (CmdArgs.InlineScript s) = return . Right . T.pack $ s+loadScript (CmdArgs.ScriptFilePath "") = return . Left $ "Either a filename (including - for stdin) or a --script argument must be given to ngless"+loadScript (CmdArgs.ScriptFilePath fname) =+        --Note that the input for ngless is always UTF-8.+        --Always. This means that we cannot use T.readFile+        --which is locale aware.+        --We also assume that the text file is quite small and, therefore, loading+        --it in to memory is not resource intensive.+        if fname == "-"+            then decodeUtf8'' <$> B.getContents+            else checkFileReadable fname >>= \case+                Nothing -> decodeUtf8'' <$> B.readFile fname+                Just m -> return $! Left (T.unpack m)+    where+        decodeUtf8'' s = case T.decodeUtf8' s of+            Right r -> Right r+            Left err -> Left (show err)++++modeExec :: CmdArgs.NGLessMode -> IO ()+modeExec opts@CmdArgs.DefaultMode{} = do+    when (not (CmdArgs.experimentalFeatures opts) && isJust (CmdArgs.exportJSON opts)) $+        fatalError ("The use of --export-json requires the --experimental-features flag\n"+++                    "This feature may change at any time.\n")+    when (not (CmdArgs.experimentalFeatures opts) && isJust (CmdArgs.exportCWL opts)) $+        fatalError ("The use of --export-cwl requires the --experimental-features flag\n"+++                    "This feature may change at any time.\n")+    let (fname,reqversion) = case CmdArgs.input opts of+                CmdArgs.ScriptFilePath fp -> (fp,True)+                CmdArgs.InlineScript _ -> ("inline",False)+    case CmdArgs.nThreads opts of+        CmdArgs.NThreads n -> setNumCapabilities n+        CmdArgs.NThreadsAuto -> getNcpus >>= \case+            Just n -> setNumCapabilities n+            Nothing -> fatalError "Could not determine number of CPUs"+    ngltext <- loadScript (CmdArgs.input opts) >>= \case+        Right t -> return t+        Left err ->  fatalError err+    let maybe_add_print = (if CmdArgs.print_last opts then wrapPrint else return)+    runNGLessIO "loading and running script" $ do+        updateNglEnvironment (\e -> e { ngleScriptText = ngltext })+        outputConfiguration+        sc' <- runNGLess $ parsengless fname reqversion ngltext >>= maybe_add_print+        activeVersion <- runNGLess . parseVersion $ (nglVersion <$> nglHeader sc')+        when (activeVersion < NGLVersion 1 0) $+            outputListLno' WarningOutput ["Using old version (in compatibility mode). If possible, upgrade your version statement to ngless \"1.0\"."]+        updateNglEnvironment (\e -> e {ngleVersion = activeVersion })+        when (CmdArgs.debug_mode opts == "ast") $ liftIO $ do+            forM_ (nglBody sc') $ \(lno,e) ->+                putStrLn ((if lno < 10 then " " else "")++show lno++": "++show e)+            exitSuccess+        outputListLno' DebugOutput ["Loading modules..."]+        modules <- loadModules activeVersion (fromMaybe [] (nglModules <$> nglHeader sc'))+        sc <- runNGLess $ checktypes modules sc' >>= validate modules+        when (uses_STDOUT `any` [e | (_,e) <- nglBody sc]) $ do+            outputListLno' DebugOutput ["Setting quiet mode as STDOUT is used"]+            setQuiet+        outputListLno' DebugOutput ["Validating script..."]+        errs <- validateIO modules sc+        when (isJust errs) $ do+            let errormessage = T.intercalate "\n\n" (fromJust errs)+            liftIO $ fatalError (T.unpack errormessage)+        when (CmdArgs.validateOnly opts) $ do+            outputListLno' InfoOutput ["Script OK."]+            liftIO exitSuccess+        outputListLno' TraceOutput ["Transforming script..."]+        when (CmdArgs.debug_mode opts == "transform") $+            liftIO (print sc)+        transformed <- transform modules sc+        when (CmdArgs.debug_mode opts == "transform") $+            liftIO (print transformed)+        whenM (nConfPrintHeader <$> nglConfiguration) $ do+            printHeader (collectCitations modules transformed)+        whenJust (CmdArgs.exportJSON opts) $ \jsoname -> liftIO $ do+            writeScriptJSON jsoname sc transformed+            exitSuccess+        whenJust (CmdArgs.exportCWL opts) $ \cwlname -> liftIO $ do+            writeCWL sc fname cwlname+            exitSuccess+        outputListLno' InfoOutput ["Script OK. Starting interpretation..."]+        interpret modules (nglBody transformed)+        triggerHook FinishOkHook+        whenM (nConfCreateReportDirectory <$> nglConfiguration) $ do+            odir <- nConfReportDirectory <$> nglConfiguration+            liftIO $ createDirectoryIfMissing False odir+            liftIO $ setupHtmlViewer odir+            liftIO $ T.writeFile (odir </> "script.ngl") ngltext+            writeOutputJSImages odir fname ngltext+            writeOutputTSV False (Just $ odir </> "fq.tsv") (Just $ odir </> "mappings.tsv")+    exitSuccess+++modeExec (CmdArgs.InstallReferenceMode ref)+    | isBuiltinReference ref = void . runNGLessIO "installing data" $ do+        activeVersion <- runNGLess $ parseVersion Nothing+        updateNglEnvironment (\e -> e {ngleVersion = activeVersion })+        installData Nothing ref+    | otherwise =+        error (concat ["Reference ", T.unpack ref, " is not a known reference."])++modeExec (CmdArgs.CreateReferencePackMode ofile gen mgtf mfunc) = runNGLessIO "creating reference package" $ do+        outputListLno' InfoOutput ["Starting packaging (will download and index genomes)..."]+        createReferencePack ofile gen mgtf mfunc++modeExec (CmdArgs.DownloadFileMode url local) = runNGLessIO "download a file" $+    downloadFile url local++modeExec (CmdArgs.DownloadDemoMode demo) = do+    let known = ["gut-short", "ocean-short"]+    if demo `elem` known+        then do+            let url = "https://ngless.embl.de/resources/Demos/" ++ demo ++ ".tar.gz"+            runNGLessIO "downloading a demo" $ downloadExpandTar url "."+            putStrLn ("\nDemo downloaded to " ++ demo)+        else do+            hPutStrLn stderr (redColor ++ "Unknown demo '"++ demo ++ "'.\n"+++                                    T.unpack (suggestionMessage (T.pack demo) (T.pack <$> known))+++                                    "Available demos are:\n")+            forM_ known $ hPutStrLn stderr . ("\t- " ++)+            hPutStrLn stderr $ setSGRCode [Reset]+            exitFailure++modeExec (CmdArgs.PrintPathMode exec) = runNGLessIO "finding internal path" $ do+    updateNglEnvironment (\env -> let oldConf = ngleConfiguration env+                                    in env { ngleConfiguration = oldConf { nConfOutputTo = NGLOutStderr } })+    path <- case exec of+      "samtools" -> samtoolsBin+      "prodigal" -> prodigalBin+      "megahit" -> megahitBin+      "bwa" -> bwaBin+      "minimap2" -> minimap2Bin+      _ -> throwSystemError ("Unknown binary " ++ exec ++ ".")+    liftIO $ putStrLn path++modeExec (CmdArgs.CheckInstallMode verbose) = runNGLessIO "Checking install" $ do+    let checkPath tool pathA+            | verbose = do+                path <- pathA+                liftIO $ putStrLn (tool ++ ": `" ++ path ++ "`")+            | otherwise = void pathA+    checkPath "samtools" samtoolsBin+    checkPath "prodigal" prodigalBin+    checkPath "megahit" megahitBin+    checkPath "bwa" bwaBin+    liftIO $ putStrLn "Install OK"++main' = do+    let metainfo = fullDesc <> footer foottext <> progDesc "ngless implement the NGLess language"+        foottext = concat [+                            "ngless v", Version.versionStrLong, "(C) NGLess Authors 2013-2022\n",+                            "For more information:\n",+                            "\thttps://ngless.embl.de/\n",+                            "For comments/discussion:\n",+                            "\thttps://groups.google.com/forum/#!forum/ngless\n",+                            "Citation: LP Coelho et al., 2019. ",+                            "https://doi.org/10.1186/s40168-019-0684-8.\n"+                            ]+        versioner =+            (infoOption ("ngless v" ++ Version.versionStrLong ++ " (release date: " ++ Version.dateStr ++ ")")+                (long "version" <> short 'V' <> help "print version and exit"))+            <*>+            (infoOption Version.versionStr (long "version-short" <> help "print just version string (useful for scripting)"))+            <*>+            (infoOption ("ngless v" ++ Version.versionStr ++ " (full version: " ++ Version.versionStrLong ++ "; release date: " ++ Version.dateStr ++ "; embedded binaries: " ++ Version.embeddedStr ++ ")")+                (long "version-debug" <> help "print detailed version information"))+            <*>+            (infoOption Version.dateStr (long "date-short" <> help "print just release date string (useful for scripting)"))+    args <- execParser (info (versioner <*> helper <*> CmdArgs.nglessArgs) metainfo)+    config <- initConfiguration args+    updateNglEnvironment' (\env -> env { ngleConfiguration = config })+    modeExec (CmdArgs.mode args)++makeEncodingSafe :: Handle -> IO ()+makeEncodingSafe h = do+  ce' <- hGetEncoding h+  case ce' of+    Nothing -> return ()+    Just ce -> mkTextEncoding (takeWhile (/= '/') (show ce) ++ "//TRANSLIT") >>=+      hSetEncoding h++main = do+    mapM_ makeEncodingSafe [stdout, stdin, stderr]+    catch main' $ \e -> case fromException e of+        Just ec -> throwIO (ec :: ExitCode) -- rethrow+        Nothing ->+            fatalError ("An unhandled error occurred (this should not happen)!\n\n" +++                        "\tIf you can reproduce this issue, please run your script\n" +++                        "\twith the --trace flag and report a bug (including the script and the trace) at\n" +++                        "\t\thttps://github.com/ngless-toolkit/ngless/issues\n\n" +++                        "The error message was: `" ++ displayException e ++ "`")
+ NGLess.cabal view
@@ -0,0 +1,586 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           NGLess+version:        1.4.0+synopsis:       NGLess implements ngless, a DSL for processing sequencing data+description:    NGLess implements a domain-specific language for processing next generation data, particularly metagenomics.+category:       Domain Specific Language+homepage:       https://github.com/ngless-toolkit/ngless#readme+bug-reports:    https://github.com/ngless-toolkit/ngless/issues+author:         Luis Pedro Coelho and others (see AUTHORS)+maintainer:     luis@luispedro.org+license:        MIT+license-file:   COPYING+build-type:     Simple+extra-source-files:+    ChangeLog++source-repository head+  type: git+  location: https://github.com/ngless-toolkit/ngless++flag embed+  description: Embed dependencies+  manual: False+  default: False++flag static+  description: Static build+  manual: False+  default: False++library+  exposed-modules:+      BuiltinFunctions+      BuiltinModules.Argv+      BuiltinModules.AsReads+      BuiltinModules.Assemble+      BuiltinModules.Checks+      BuiltinModules.LoadDirectory+      BuiltinModules.ORFFind+      BuiltinModules.QCStats+      BuiltinModules.Readlines+      BuiltinModules.Remove+      Citations+      CmdArgs+      Configuration+      CWL+      Data.Fasta+      Data.FastQ+      Data.FastQ.Utils+      Data.GFF+      Data.Sam+      Dependencies.Embedded+      Dependencies.Versions+      ExternalModules+      FileManagement+      FileOrStream+      FileOrStream.Types+      Interpret+      Interpretation.Count+      Interpretation.Count.RefSeqInfoVector+      Interpretation.CountFile+      Interpretation.FastQ+      Interpretation.Map+      Interpretation.Select+      Interpretation.Substrim+      Interpretation.Unique+      Interpretation.Write+      JSONScript+      Language+      Modules+      NGLess+      NGLess.NGError+      NGLess.NGLEnvironment+      Output+      Parse+      ReferenceDatabases+      StandardModules.Batch+      StandardModules.Example+      StandardModules.Mappers.Bwa+      StandardModules.Mappers.Minimap2+      StandardModules.Mappers.Soap+      StandardModules.Minimap2+      StandardModules.Mocat+      StandardModules.Motus+      StandardModules.NGLStdlib+      StandardModules.Parallel+      StandardModules.Samtools+      StandardModules.Soap+      Tokens+      Transform+      Types+      Utils.Batch+      Utils.Conduit+      Utils.Debug+      Utils.Here+      Utils.IntGroups+      Utils.LockFile+      Utils.Network+      Utils.Process+      Utils.ProgressBar+      Utils.Samtools+      Utils.Suggestion+      Utils.Utils+      Utils.Vector+      Validation+      ValidationIO+      Version+  other-modules:+      Paths_NGLess+  hs-source-dirs:+      NGLess/+  default-extensions:+      BangPatterns+      OverloadedStrings+      LambdaCase+      TupleSections+  other-extensions:+      DeriveDataTypeable+      TemplateHaskell+  ghc-options: -Wall -Wcompat -fwarn-tabs -fno-warn-missing-signatures -O2 -fno-full-laziness+  c-sources:+      NGLess/Dependencies/embedded.c+      NGLess/Data/FastQ.c+  build-depends:+      MissingH >=1.3+    , aeson >=0.9+    , ansi-terminal+    , async+    , atomic-write >=0.2+    , base >=4.12 && <4.16+    , bytestring+    , bytestring-lexing+    , conduit >=1.3+    , conduit-algorithms >=0.0.9.0+    , conduit-extra >=1.1.12+    , configurator+    , containers+    , convertible+    , data-default+    , deepseq >=1.3+    , diagrams-core+    , diagrams-lib+    , diagrams-svg+    , directory+    , edit-distance >=0.2+    , either+    , errors >=2.1+    , exceptions+    , extra >=1.4+    , file-embed >=0.0.8+    , filemanip >=0.3.6+    , filepath >=1.3+    , hashable+    , hashtables+    , hostname+    , http-client+    , http-conduit+    , inline-c+    , inline-c-cpp+    , int-interval-map+    , mtl >=2.2+    , network+    , optparse-applicative+    , parsec >=3.1+    , primitive >=0.6+    , process >=1.2.3+    , regex+    , resourcet >=1.1+    , safe+    , stm+    , stm-chans+    , stm-conduit >=2.7+    , strict+    , tar >=0.5+    , tar-conduit >=0.3.2+    , template-haskell+    , text >=1.2+    , time >=1.5+    , transformers+    , unix-compat+    , unliftio+    , unliftio-core+    , vector >=0.11+    , vector-algorithms+    , yaml+    , zlib+  if os(windows)+    cpp-options: -DWINDOWS+    build-depends:+        atomic-write+  else+    build-depends:+        bzlib-conduit+      , double-conversion+      , safeio >=0.0.2+      , unix+  if flag(static)+    ld-options: -static -pthread+  default-language: Haskell2010++executable ngless+  main-is: Main.hs+  hs-source-dirs:+      Execs+  default-extensions:+      BangPatterns+      OverloadedStrings+      LambdaCase+      TupleSections+  other-extensions:+      DeriveDataTypeable+      TemplateHaskell+  ghc-options: -Wall -Wcompat -fwarn-tabs -fno-warn-missing-signatures -O2 -fno-full-laziness -threaded -rtsopts "-with-rtsopts=-A64m -n4m -H"+  c-sources:+      NGLess/Dependencies/embedded.c+      NGLess/Data/FastQ.c+  build-depends:+      MissingH >=1.3+    , NGLess+    , aeson >=0.9+    , ansi-terminal+    , async+    , atomic-write >=0.2+    , base >=4.12 && <4.16+    , bytestring+    , bytestring-lexing+    , conduit >=1.3+    , conduit-algorithms >=0.0.9.0+    , conduit-extra >=1.1.12+    , configurator+    , containers+    , convertible+    , data-default+    , deepseq >=1.3+    , diagrams-core+    , diagrams-lib+    , diagrams-svg+    , directory+    , edit-distance >=0.2+    , either+    , errors >=2.1+    , exceptions+    , extra >=1.4+    , file-embed >=0.0.8+    , filemanip >=0.3.6+    , filepath >=1.3+    , hashable+    , hashtables+    , hostname+    , http-client+    , http-conduit+    , inline-c+    , inline-c-cpp+    , int-interval-map+    , mtl >=2.2+    , network+    , optparse-applicative+    , parsec >=3.1+    , primitive >=0.6+    , process >=1.2.3+    , regex+    , resourcet >=1.1+    , safe+    , stm+    , stm-chans+    , stm-conduit >=2.7+    , strict+    , tar >=0.5+    , tar-conduit >=0.3.2+    , template-haskell+    , text >=1.2+    , time >=1.5+    , transformers+    , unix-compat+    , unliftio+    , unliftio-core+    , vector >=0.11+    , vector-algorithms+    , yaml+    , zlib+  if os(windows)+    cpp-options: -DWINDOWS+    build-depends:+        atomic-write+  else+    build-depends:+        bzlib-conduit+      , double-conversion+      , safeio >=0.0.2+      , unix+  if flag(static)+    ld-options: -static -pthread+  if flag(embed)+    cpp-options: -DBUILD_W_EMBED+    cc-options: -DBUILD_W_EMBED+  default-language: Haskell2010++test-suite nglesstest+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  other-modules:+      BuiltinFunctions+      BuiltinModules.Argv+      BuiltinModules.AsReads+      BuiltinModules.Assemble+      BuiltinModules.Checks+      BuiltinModules.LoadDirectory+      BuiltinModules.ORFFind+      BuiltinModules.QCStats+      BuiltinModules.Readlines+      BuiltinModules.Remove+      Citations+      CmdArgs+      Configuration+      CWL+      Data.Fasta+      Data.FastQ+      Data.FastQ.Utils+      Data.GFF+      Data.Sam+      Dependencies.Embedded+      Dependencies.Versions+      ExternalModules+      FileManagement+      FileOrStream+      FileOrStream.Types+      Interpret+      Interpretation.Count+      Interpretation.Count.RefSeqInfoVector+      Interpretation.CountFile+      Interpretation.FastQ+      Interpretation.Map+      Interpretation.Select+      Interpretation.Substrim+      Interpretation.Unique+      Interpretation.Write+      JSONScript+      Language+      Modules+      NGLess+      NGLess.NGError+      NGLess.NGLEnvironment+      Output+      Parse+      ReferenceDatabases+      StandardModules.Batch+      StandardModules.Example+      StandardModules.Mappers.Bwa+      StandardModules.Mappers.Minimap2+      StandardModules.Mappers.Soap+      StandardModules.Minimap2+      StandardModules.Mocat+      StandardModules.Motus+      StandardModules.NGLStdlib+      StandardModules.Parallel+      StandardModules.Samtools+      StandardModules.Soap+      Tokens+      Transform+      Types+      Utils.Batch+      Utils.Conduit+      Utils.Debug+      Utils.Here+      Utils.IntGroups+      Utils.LockFile+      Utils.Network+      Utils.Process+      Utils.ProgressBar+      Utils.Samtools+      Utils.Suggestion+      Utils.Utils+      Utils.Vector+      Validation+      ValidationIO+      Version+      Tests.Count+      Tests.FastQ+      Tests.IntGroups+      Tests.Language+      Tests.LoadFQDirectory+      Tests.NGLessAPI+      Tests.Parse+      Tests.Select+      Tests.Types+      Tests.Utils+      Tests.Validation+      Tests.Vector+      Tests.Write+      Paths_NGLess+  hs-source-dirs:+      NGLess+      Tests-Src/+  default-extensions:+      BangPatterns+      OverloadedStrings+      LambdaCase+      TupleSections+  other-extensions:+      DeriveDataTypeable+      TemplateHaskell+  ghc-options: -Wall -Wcompat -fwarn-tabs -fno-warn-missing-signatures -O2 -fno-full-laziness+  cpp-options: -DIS_BUILDING_TEST+  c-sources:+      NGLess/Dependencies/embedded.c+      NGLess/Data/FastQ.c+  build-depends:+      HUnit >=1.3+    , MissingH >=1.3+    , QuickCheck >=2.8+    , aeson >=0.9+    , ansi-terminal+    , async+    , atomic-write >=0.2+    , base >=4.12 && <4.16+    , bytestring+    , bytestring-lexing+    , conduit >=1.3+    , conduit-algorithms >=0.0.9.0+    , conduit-extra >=1.1.12+    , configurator+    , containers+    , convertible+    , data-default+    , deepseq >=1.3+    , diagrams-core+    , diagrams-lib+    , diagrams-svg+    , directory+    , edit-distance >=0.2+    , either+    , errors >=2.1+    , exceptions+    , extra >=1.4+    , file-embed >=0.0.8+    , filemanip >=0.3.6+    , filepath >=1.3+    , hashable+    , hashtables+    , hostname+    , http-client+    , http-conduit+    , inline-c+    , inline-c-cpp+    , int-interval-map+    , mtl >=2.2+    , network+    , optparse-applicative+    , parsec >=3.1+    , primitive >=0.6+    , process >=1.2.3+    , regex+    , resourcet >=1.1+    , safe+    , stm+    , stm-chans+    , stm-conduit >=2.7+    , strict+    , tar >=0.5+    , tar-conduit >=0.3.2+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , tasty-th+    , template-haskell+    , text >=1.2+    , time >=1.5+    , transformers+    , unix-compat+    , unliftio+    , unliftio-core+    , vector >=0.11+    , vector-algorithms+    , yaml+    , zlib+  if os(windows)+    cpp-options: -DWINDOWS+    build-depends:+        atomic-write+  else+    build-depends:+        bzlib-conduit+      , double-conversion+      , safeio >=0.0.2+      , unix+  default-language: Haskell2010++benchmark nglessbench+  type: exitcode-stdio-1.0+  main-is: Bench.hs+  hs-source-dirs:+      Execs/+  default-extensions:+      BangPatterns+      OverloadedStrings+      LambdaCase+      TupleSections+  other-extensions:+      DeriveDataTypeable+      TemplateHaskell+  ghc-options: -Wall -Wcompat -fwarn-tabs -fno-warn-missing-signatures -O2 -fno-full-laziness+  c-sources:+      NGLess/Dependencies/embedded.c+      NGLess/Data/FastQ.c+  build-depends:+      HUnit >=1.3+    , MissingH >=1.3+    , NGLess+    , aeson >=0.9+    , ansi-terminal+    , async+    , atomic-write >=0.2+    , base >=4.12 && <4.16+    , bytestring+    , bytestring-lexing+    , conduit >=1.3+    , conduit-algorithms >=0.0.9.0+    , conduit-extra >=1.1.12+    , configurator+    , containers+    , convertible+    , criterion+    , data-default+    , deepseq >=1.3+    , diagrams-core+    , diagrams-lib+    , diagrams-svg+    , directory+    , edit-distance >=0.2+    , either+    , errors >=2.1+    , exceptions+    , extra >=1.4+    , file-embed >=0.0.8+    , filemanip >=0.3.6+    , filepath >=1.3+    , hashable+    , hashtables+    , hostname+    , http-client+    , http-conduit+    , inline-c+    , inline-c-cpp+    , int-interval-map+    , mtl >=2.2+    , network+    , optparse-applicative+    , parsec >=3.1+    , primitive >=0.6+    , process >=1.2.3+    , regex+    , resourcet >=1.1+    , safe+    , stm+    , stm-chans+    , stm-conduit >=2.7+    , strict+    , tar >=0.5+    , tar-conduit >=0.3.2+    , template-haskell+    , text >=1.2+    , time >=1.5+    , transformers+    , unix-compat+    , unliftio+    , unliftio-core+    , vector >=0.11+    , vector-algorithms+    , yaml+    , zlib+  if os(windows)+    cpp-options: -DWINDOWS+    build-depends:+        atomic-write+  else+    build-depends:+        bzlib-conduit+      , double-conversion+      , safeio >=0.0.2+      , unix+  default-language: Haskell2010
+ NGLess/BuiltinFunctions.hs view
@@ -0,0 +1,199 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+module BuiltinFunctions+    ( MethodName(..)+    , MethodInfo(..)+    , builtinModule+    , builtinMethods+    , findFunction+    ) where++import Data.List (find)+import Data.Default (def)+import qualified Data.Text as T++import NGLess.NGLEnvironment (NGLVersion(..))+import Modules+import Language++data MethodInfo = MethodInfo+    { methodName :: MethodName+    , methodSelfType :: NGLType+    , methodArgType :: Maybe NGLType+    , methodReturnType :: NGLType+    , methodKwargsInfo :: [ArgInformation] -- Unnamed argument is called "__0"+    , methodIsPure :: Bool+    , methodChecks :: [FunctionCheck]+    } deriving (Eq, Show)++findFunction :: [Module] -> FuncName -> Maybe Function+-- findFunction mods fn = trace (show mods) $ trace (show fn) $ find ((==fn) . funcName) $ concat (modFunctions <$> mods)+findFunction mods fn = find ((==fn) . funcName) $ concat (modFunctions <$> mods)++builtinModule :: NGLVersion -> Module+builtinModule ver@(NGLVersion majV minV) = def+    { modInfo = ModInfo "__builtin__" (T.pack $ show majV ++ "." ++ show minV)+    , modPath = ""+    , modFunctions = builtinFunctions ver+    }++builtinFunctions ver =+    [Function (FuncName "fastq") (Just NGLString) [ArgCheckFileReadable] NGLReadSet fastqArgs False []+    ,Function (FuncName "paired") (Just NGLString) [ArgCheckFileReadable] NGLReadSet pairedArgs False []+    ,Function (FuncName "group") (Just (NGList NGLReadSet)) [] NGLReadSet groupArgs False []+    ,Function (FuncName "samfile") (Just NGLString) [ArgCheckFileReadable] NGLMappedReadSet samfileArgs False []+    ,Function (FuncName "unique") (Just NGLReadSet) [] NGLReadSet uniqueArgs False [FunctionCheckReturnAssigned]+    ,Function (FuncName "preprocess") (Just NGLReadSet) [] NGLReadSet preprocessArgs False [FunctionCheckReturnAssigned]+    ,Function (FuncName "substrim") (Just NGLRead) [] NGLRead substrimArgs False [FunctionCheckReturnAssigned]+    ,Function (FuncName "endstrim") (Just NGLRead) [] NGLRead endstrimArgs False [FunctionCheckReturnAssigned]+    ,Function (FuncName "smoothtrim") (Just NGLRead) [] NGLRead smoothtrimArgs False [FunctionCheckReturnAssigned, FunctionCheckMinNGLessVersion (0, 11)]+    ,Function (FuncName "map") (Just NGLReadSet) [] NGLMappedReadSet mapArgs False [FunctionCheckReturnAssigned]+    ,Function (FuncName "mapstats") (Just NGLMappedReadSet) [] NGLCounts mapStatsArgs False []+    ,Function (FuncName "select") (Just NGLMappedReadSet) [] NGLMappedReadSet selectArgs False []+    ,Function (FuncName "count") (Just NGLMappedReadSet) [] NGLCounts countArgs False [FunctionCheckReturnAssigned]+    ,Function (FuncName "__check_count") (Just NGLMappedReadSet) [] NGLCounts countCheckArgs False []+    ,Function (FuncName "countfile") (Just NGLString) [ArgCheckFileReadable] NGLCounts [] False [FunctionCheckReturnAssigned]+    ,Function (FuncName "write") (Just NGLAny) [] (if ver >= NGLVersion 1 4 then NGLString else NGLVoid) writeArgs False []++    ,Function (FuncName "print") (Just NGLAny) [] NGLVoid [] False []++    ,Function (FuncName "read_int") (Just NGLString) [] NGLInteger [ArgInformation "on_empty_return" False NGLInteger []] False []+    ,Function (FuncName "read_double") (Just NGLString) [] NGLDouble [ArgInformation "on_empty_return" False NGLDouble []] False []++    ,Function (FuncName "__assert") (Just NGLBool) [] NGLVoid [] False []++    ,Function (FuncName "__merge_samfiles") (Just (NGList NGLString)) [] NGLMappedReadSet [] False []+    ]++groupArgs =+    [ArgInformation "name" True NGLString []+    ]++writeArgs =+    [ArgInformation "ofile" True NGLString [ArgCheckFileWritable]+    ,ArgInformation "format" False NGLSymbol [ArgCheckSymbol ["tsv", "csv", "bam", "sam"]]+    ,ArgInformation "format_flags" False NGLSymbol [ArgCheckMinVersion (0,7)+                                                   ,ArgCheckSymbol ["interleaved"]]+    ,ArgInformation "verbose" False NGLBool []+    ,ArgInformation "comment" False NGLString []+    ,ArgInformation "auto_comments" False (NGList NGLSymbol) [ArgCheckSymbol ["date", "script", "hash"]]+    ]++countArgs =+    [ArgInformation "features" False (NGList NGLString) []+    ,ArgInformation "subfeatures" False (NGList NGLString) []+    ,ArgInformation "min" False NGLInteger []+    ,ArgInformation "multiple" False NGLSymbol [ArgCheckSymbol ["all1", "dist1", "1overN", "unique_only"]]+    ,ArgInformation "mode" False NGLSymbol [ArgCheckSymbol ["union", "intersection_strict", "intersection_non_empty"]]+    ,ArgInformation "gff_file" False NGLString [ArgCheckFileReadable]+    ,ArgInformation "functional_map" False NGLString [ArgCheckFileReadable]+    ,ArgInformation "sense" False NGLSymbol [ArgCheckSymbol ["both", "sense", "antisense"], ArgCheckMinVersion (1,1)]+    ,ArgInformation "strand" False NGLBool [ArgDeprecated (1,1) "Use `sense` argument instead"]+    ,ArgInformation "norm" False NGLBool []+    ,ArgInformation "discard_zeros" False NGLBool []+    ,ArgInformation "include_minus1" False NGLBool []+    ,ArgInformation "normalization" False NGLSymbol [ArgCheckSymbol ["raw", "normed", "scaled", "fpkm"]]+    ,ArgInformation "reference" False NGLString [ArgCheckMinVersion (0,8)]+    ]++countCheckArgs = countArgs +++    [ArgInformation "original_lno" False NGLInteger []+    ]+++selectArgs =+    [ArgInformation "keep_if" False (NGList NGLSymbol) [ArgCheckSymbol ["mapped", "unmapped", "unique"]]+    ,ArgInformation "drop_if" False (NGList NGLSymbol) [ArgCheckSymbol ["mapped", "unmapped", "unique"]]+    ,ArgInformation "paired" False NGLBool []+    ,ArgInformation "__oname" False NGLString []+    ]++fastqArgs =+    [ArgInformation "encoding" False NGLSymbol [ArgCheckSymbol ["auto", "33", "64", "sanger", "solexa"]]+    ,ArgInformation "interleaved" False NGLBool [ArgCheckMinVersion (1,1)]+    ,ArgInformation "__perform_qc" False NGLBool []+    ]++samfileArgs =+    [ArgInformation "name" False NGLString []+    ,ArgInformation "headers" False NGLString+                    [ArgCheckMinVersion (0,7)+                    ,ArgCheckFileReadable+                    ]+    ]+pairedArgs =+    [ArgInformation "second" True NGLString []+    ,ArgInformation "singles" False NGLString []+    ,ArgInformation "encoding" False NGLSymbol [ArgCheckSymbol ["auto", "33", "64", "sanger", "solexa"]]+    ,ArgInformation "__perform_qc" False NGLBool []+    ]++uniqueArgs =+    [ArgInformation "max_copies" False NGLInteger []]++preprocessArgs =+    [ArgInformation "keep_singles" False NGLBool []+    ,ArgInformation "__qc_input" False NGLBool []+    ]++mapArgs =+    [ArgInformation "reference" False NGLString []+    ,ArgInformation "fafile" False NGLString [ArgCheckFileReadable]+    ,ArgInformation "mode_all" False NGLBool []+    ,ArgInformation "mapper" False NGLString []+    ,ArgInformation "block_size_megabases" False NGLInteger []+    ,ArgInformation "__extra_args" False (NGList NGLString) [ArgCheckMinVersion (1,1)]+    ,ArgInformation "__oname" False NGLString []+    ]++mapStatsArgs = []++substrimArgs =+    [ArgInformation "min_quality" True NGLInteger []+    ]++endstrimArgs =+    [ArgInformation "min_quality" True NGLInteger []+    ,ArgInformation "from_ends" False NGLSymbol [ArgCheckSymbol ["both", "3", "5"]]+    ]++smoothtrimArgs =+    [ArgInformation "min_quality" True NGLInteger []+    ,ArgInformation "window" True NGLInteger []+    ]++builtinMethods :: [MethodInfo]+builtinMethods =+    [+     -- NGLMappedReadSet+     MethodInfo (MethodName "flag")   NGLMappedRead (Just NGLSymbol) NGLBool flagArgs True []+    ,MethodInfo (MethodName "filter") NGLMappedRead Nothing NGLMappedRead filterArgs True []+    ,MethodInfo (MethodName "pe_filter") NGLMappedRead Nothing NGLMappedRead [] True []+    ,MethodInfo (MethodName "some_match") NGLMappedRead (Just NGLString) NGLBool [] True []+    ,MethodInfo (MethodName "unique") NGLMappedRead Nothing NGLMappedRead [] True []+    ,MethodInfo (MethodName "allbest") NGLMappedRead Nothing NGLMappedRead [] True [FunctionCheckMinNGLessVersion (0,9)]++    -- NGLRead+    ,MethodInfo (MethodName "avg_quality") NGLRead Nothing NGLDouble [] True []+    ,MethodInfo (MethodName "fraction_at_least") NGLRead (Just NGLInteger) NGLDouble [] True []+    ,MethodInfo (MethodName "n_to_zero_quality") NGLRead Nothing NGLRead [] True [FunctionCheckMinNGLessVersion (0,8)]++    -- NGLDouble+    ,MethodInfo (MethodName "to_string") NGLDouble Nothing NGLString [] True []++    -- NGLInteger+    ,MethodInfo (MethodName "to_string") NGLInteger Nothing NGLString [] True []+    ]++filterArgs =+    [ArgInformation "min_identity_pc" False NGLInteger []+    ,ArgInformation "min_match_size" False NGLInteger []+    ,ArgInformation "max_trim" False NGLInteger [ArgCheckMinVersion (0,7)]+    ,ArgInformation "action" False NGLSymbol [ArgCheckSymbol ["drop", "unmatch"]]+    ,ArgInformation "reverse" False NGLBool []+    ]++flagArgs =+    [ArgInformation "__0" False NGLSymbol [ArgCheckSymbol ["mapped", "unmapped"]]+    ]
+ NGLess/BuiltinModules/Argv.hs view
@@ -0,0 +1,27 @@+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++module BuiltinModules.Argv+    ( loadModule+    ) where++import qualified Data.Text as T+import           Data.Default (def)++import Language++import Modules+import NGLess+import Configuration+import NGLess.NGLEnvironment++loadModule :: T.Text -> NGLessIO Module+loadModule _ = do+    argv <- nConfArgv <$> nglConfiguration+    let nglARGV = NGOList (NGOString <$> argv)+    return def+        { modInfo = ModInfo "builtin.argv" "0.0"+        , modConstants = [("ARGV", nglARGV)]+        }+
+ NGLess/BuiltinModules/AsReads.hs view
@@ -0,0 +1,155 @@+{- Copyright 2015-2018 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++module BuiltinModules.AsReads+    ( loadModule+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.Algorithms.Async as CAlg+import Control.Monad.Trans.Resource (release)+import Data.Conduit ((.|))+import Control.Monad.Except+import System.IO+import Data.Default (def)+import Data.IORef (newIORef, writeIORef, readIORef)+import Control.Concurrent (getNumCapabilities)++import Language+import FileManagement++import Interpretation.FastQ (encodingFor)++import Data.Sam+import Data.FastQ+import Modules+import Output+import NGLess+import FileOrStream+import Utils.Conduit (ByteLine(..))++executeReads :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeReads (NGOMappedReadSet name istream _) _ = NGOReadSet name <$> uncurry samToFastQ (asSamStream istream)+executeReads arg _ = throwShouldNotOccur ("executeReads called with argument: " ++ show arg)++executeDiscardSingles :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeDiscardSingles (NGOReadSet meta (ReadSet paired _)) [] = return (NGOReadSet meta (ReadSet paired []))+executeDiscardSingles arg _ = throwShouldNotOccur ("executeDiscardSingles called with argument: " ++ show arg)++data FQResult = NoResult+                | Single !B.ByteString+                | Paired !B.ByteString !B.ByteString+            deriving (Eq)++samToFastQ :: FilePath -> C.ConduitT () (V.Vector ByteLine) NGLessIO () -> NGLessIO ReadSet+samToFastQ fpsam stream = do+    (rk1, (oname1,ohand1)) <- openNGLTempFile' fpsam "reads_" "1.fq.gz"+    (rk2, (oname2,ohand2)) <- openNGLTempFile' fpsam "reads_" "2.fq.gz"+    (rk3, (oname3,ohand3)) <- openNGLTempFile' fpsam "reads_" "singles.fq.gz"+    hasPaired <- liftIO (newIORef False)+    hasSingle <- liftIO (newIORef False)+    let writer sel var out =+            CL.map sel+                .| do+                    empty <- CC.nullE+                    unless empty $+                        liftIO (writeIORef var True)+                    CC.concat .| CAlg.asyncGzipTo out+    numCapabilities <- liftIO getNumCapabilities+    [(),(),()] <- C.runConduit $+        stream+            .| readSamGroupsC' numCapabilities True+            .| CL.mapM (fmap (V.filter (/= NoResult)) . V.mapM asFQ)+            .| C.sequenceSinks+                [writer (V.mapMaybe (\r -> case r of Paired a _ -> Just a ; _ -> Nothing)) hasPaired ohand1+                ,writer (V.mapMaybe (\r -> case r of Paired _ b -> Just b ; _ -> Nothing)) hasPaired ohand2+                ,writer (V.mapMaybe (\r -> case r of Single a -> Just a; _ -> Nothing)) hasSingle ohand3+                ]+    outputListLno' TraceOutput ["Finished as_reads"]+    liftIO $ forM_ [ohand1, ohand2, ohand3] hClose+    hasPaired' <- liftIO $ readIORef hasPaired+    hasSingle' <- liftIO $ readIORef hasSingle+    case (hasPaired', hasSingle') of+        (True, True) -> do+            enc <- encodingFor oname1+            return $! ReadSet [(FastQFilePath enc oname1,FastQFilePath enc oname2)] [FastQFilePath enc oname3]+        (False, True) -> do+            release rk1+            release rk2+            enc <- encodingFor oname3+            return $! ReadSet [] [FastQFilePath enc oname3]+        (True, False) -> do+            release rk3+            enc <- encodingFor oname1+            return $! ReadSet [(FastQFilePath enc oname1,FastQFilePath enc oname2)] []+        (False, False) -> do+            -- the input is empty+            release rk3+            outputListLno' WarningOutput ["as_reads returning an empty read set"]+            return $! ReadSet [(FastQFilePath SangerEncoding oname1,FastQFilePath SangerEncoding oname2)] []+++asFQ :: [SamLine] -> NGLessIO FQResult+asFQ sg = postproc (asFQ' False False . filter hasSequence $ sg)+    where+        postproc :: [(Int, B.ByteString)] -> NGLessIO FQResult+        postproc [(_,b)] = return $ Single b+        postproc [(1,a),(2,b)] = return $ Paired a b+        postproc [(2,b),(1,a)] = return $ Paired a b+        postproc [] = do+            outputListLno' WarningOutput ["No sequence information for read ", readID]+            return NoResult+        postproc other = throwShouldNotOccur ("Impossible argument to postproc: " ++ show other)+        readID = case sg of+            (f@SamLine{}:_) -> B8.unpack (samQName f)+            _ -> " [no read ID: this is likely a bug in ngless]"+        asFQ'  False False [s] = [(3 :: Int, asFQ1 s)]+        asFQ'  _ _ []= []+        asFQ' seen1 seen2 (s:ss)+            | isFirstInPair  s && not seen1 = (1 :: Int, asFQ1 s):asFQ' True seen2 ss+            | isSecondInPair s && not seen2 = (2 :: Int, asFQ1 s):asFQ' seen1 True ss+            | otherwise = asFQ' seen1 seen2 ss+        asFQ1 SamLine{samQName=qname, samSeq=short, samQual=qs} = B.concat ["@", qname, "\n", short, "\n+\n", qs, "\n"]+        asFQ1 SamHeader{} = error "Should not have seen a header in this place"+++as_reads_Function = Function+    { funcName = FuncName "as_reads"+    , funcArgType = Just NGLMappedReadSet+    , funcArgChecks = []+    , funcRetType = NGLReadSet+    , funcKwArgs = []+    , funcAllowsAutoComprehension = True+    , funcChecks = [FunctionCheckReturnAssigned]+    }++discard_singles_Function = Function+    { funcName = FuncName "discard_singles"+    , funcArgType = Just NGLReadSet+    , funcArgChecks = []+    , funcRetType = NGLReadSet+    , funcKwArgs = []+    , funcAllowsAutoComprehension= True+    , funcChecks = [FunctionCheckMinNGLessVersion (1,1)+                   ,FunctionCheckReturnAssigned]+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.as_reads" "0.0"+    , modFunctions = [as_reads_Function, discard_singles_Function]+    , runFunction = \case+                        "as_reads" -> executeReads+                        "discard_singles" -> executeDiscardSingles+                        _ -> error "NOT POSSIBLE"+    }+
+ NGLess/BuiltinModules/Assemble.hs view
@@ -0,0 +1,84 @@+{- Copyright 2017-2022 NGLess Authors+ - License: MIT+ -}++module BuiltinModules.Assemble+    ( loadModule+    ) where++import qualified Data.Text as T+import           System.FilePath ((</>))+import           Control.Monad.Except (liftIO)+import           Data.Default (def)+import           GHC.Conc (getNumCapabilities)+import           Control.Monad.Trans.Resource (release)+++import Language+import Configuration+import FileManagement (ensureCompressionIsOneOf, Compression(..), createTempDir, megahitBin)+import Modules+import Output+import NGLess+import Data.FastQ+import Data.FastQ.Utils+import NGLess.NGLEnvironment+import Utils.Process (runProcess)+++maybeRecompress :: FastQFilePath -> NGLessIO FilePath+maybeRecompress (FastQFilePath _ fp) = ensureCompressionIsOneOf [NoCompression, GzipCompression] fp++executeAssemble :: T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeAssemble "assemble" expr kwargs = do+    files <- case expr of+            NGOReadSet _ (ReadSet [] singles) -> do+                f <- maybeRecompress =<< concatenateFQs singles+                return ["-r", f]+            NGOReadSet _ (ReadSet pairs []) -> do+                f1 <- maybeRecompress =<< concatenateFQs (fst <$> pairs)+                f2 <- maybeRecompress =<< concatenateFQs (snd <$> pairs)+                return ["-1", f1, "-2", f2]+            NGOReadSet _ (ReadSet pairs singles) -> do+                f1 <- maybeRecompress =<< concatenateFQs (fst <$> pairs)+                f2 <- maybeRecompress =<< concatenateFQs (snd <$> pairs)+                f3 <- maybeRecompress =<< concatenateFQs singles+                return ["-1", f1, "-2", f2, "-r", f3]+            _ -> throwScriptError ("megahit:assemble first argument should have been readset, got '"++show expr++"'")+    megahitPath <- megahitBin+    keepTempFiles <- nConfKeepTemporaryFiles <$> nglConfiguration+    nthreads <- liftIO getNumCapabilities+    extraArgs <- map T.unpack <$> lookupStringListOrScriptErrorDef (return []) "extra megahit arguments" "__extra_megahit_args" kwargs+    (_, tdir) <- createTempDir "ngless-megahit-assembly"+    (mt, mhtmpdir) <- createTempDir "ngless-megahit-tmpdir"+    let odir = tdir </> "megahit-output"+        args = files +++                        ["-o", odir+                        ,"--num-cpu-threads", show nthreads+                        ,"--tmp-dir", mhtmpdir+                        ] ++ ["--keep-tmp-files" | keepTempFiles] ++ extraArgs+    outputListLno' DebugOutput ["Calling megahit: ", megahitPath, " ", unwords args]+    runProcess megahitPath args (return ()) (Left ())+    release mt+    return $! NGOFilename (odir </> "final.contigs.fa")+executeAssemble _ _ _ = throwScriptError "unexpected code path taken [megahit:assemble]"++assembleFunction = Function+    { funcName = FuncName "assemble"+    , funcArgType = Just NGLReadSet+    , funcArgChecks = []+    , funcRetType = NGLString+    , funcKwArgs = [ArgInformation "__extra_megahit_args" False (NGList NGLString) []]+    , funcAllowsAutoComprehension = False+    , funcChecks =+        [FunctionCheckNGLVersionIncompatibleChange (1, 4) "Megahit version was updated which significantly changes results"+        ,FunctionCheckReturnAssigned]+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.assemble" "0.0"+    , modFunctions = [assembleFunction]+    , runFunction = executeAssemble+    }+
+ NGLess/BuiltinModules/Checks.hs view
@@ -0,0 +1,102 @@+{- Copyright 2016-2019 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE TupleSections, OverloadedStrings #-}++module BuiltinModules.Checks+    ( checkOFile+    , loadModule+    ) where++import qualified Data.Text as T+import           Data.Default (def)+import Control.Monad.Except+import System.Directory+import System.FilePath (takeDirectory)+++import Language++import Modules+import NGLess+import           Utils.Suggestion (checkFileReadable)++checkOFile :: T.Text -> IO (Maybe T.Text)+checkOFile ofile = do+    let dirname = takeDirectory (T.unpack ofile)+    exists <- doesDirectoryExist dirname+    if not exists+        then return . Just $! T.concat ["File name '", ofile, "' used as output, but directory ", T.pack dirname, " does not exist."]+        else do+            canWrite <- writable <$> getPermissions dirname+            return $! if canWrite+                    then Nothing+                    else Just (T.concat ["write call to file ", ofile, ", but directory ", T.pack dirname, " is not writable."])+++executeChecks :: T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeChecks "__check_ofile" expr args = do+    oname <- stringOrTypeError "o file check" expr+    lno <- lookupIntegerOrScriptError "o file lno" "original_lno" args+    liftIO (checkOFile oname) >>= \case+        Nothing -> return NGOVoid+        Just err -> throwSystemError $! concat [T.unpack err, " (used in line ", show lno, ")."]+executeChecks "__check_ifile" expr args = do+    oname <- stringOrTypeError "input file check" expr+    lno <- lookupIntegerOrScriptError "inputo file lno" "original_lno" args+    liftIO (checkFileReadable $ T.unpack oname) >>= \case+        Nothing -> return NGOVoid+        Just err -> throwSystemError $! concat [T.unpack err, " (used in line ", show lno, ")."]+executeChecks "__check_index_access" (NGOList vs) args = do+    lno <- lookupIntegerOrScriptError "index access check" "original_lno" args+    index1 <- lookupIntegerOrScriptError "index access check" "index1" args+    when (fromInteger index1 >= length vs) $+        throwScriptError (concat ["Index access on line ", show lno, " is invalid.\n Accessing element with index ", show index1,+                    " but list only has ", show (length vs), " elements.",+                    (if fromInteger index1 == length vs+                        then "\nPlease note that NGLess uses 0-based indexing."+                        else "")+                    ])+    return NGOVoid+executeChecks _ _ _ = throwShouldNotOccur "checks called in an unexpected fashion."++indexCheck = Function+    { funcName = FuncName "__check_index_access"+    , funcArgType = Nothing+    , funcArgChecks = []+    , funcRetType = NGLVoid+    , funcKwArgs =+                [ArgInformation "original_lno" True NGLInteger []+                ,ArgInformation "index1" True NGLInteger []]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++oFileCheck = Function+    { funcName = FuncName "__check_ofile"+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLVoid+    , funcKwArgs = [ArgInformation "original_lno" True NGLInteger []]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++iFileCheck = Function+    { funcName = FuncName "__check_ifile"+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLVoid+    , funcKwArgs = [ArgInformation "original_lno" True NGLInteger []]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.checks" "0.0"+    , modFunctions = [oFileCheck, iFileCheck, indexCheck]+    , runFunction = executeChecks+    }+
+ NGLess/BuiltinModules/LoadDirectory.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}+{- Copyright 2016-2020 NGLess Authors+ - License: MIT+ -}++module BuiltinModules.LoadDirectory+    ( loadModule+    , executeLoad+#ifdef IS_BUILDING_TEST+    , matchUp+#endif+    ) where++import qualified Data.Text as T+import           Control.Monad.Extra (unlessM)+import           System.Directory (doesDirectoryExist)+import System.FilePath+import System.FilePath.Glob+import Control.Monad.IO.Class (liftIO)+import Control.Monad+import Data.Maybe+import Data.Default (def)+import Data.List (sort, nub, isInfixOf, isSuffixOf)++import Output+import NGLess+import Modules+import Language+import Utils.Utils (dropEnd)+import Interpretation.FastQ (executeGroup, executePaired, executeFastq)++exts :: [FilePath]+exts = do+    fq <- ["fq", "fastq"]+    comp <- ["", ".gz", ".bz2"]+    return $! fq ++ comp++pairedEnds :: [(String, String)]+pairedEnds = do+    end <- exts+    (s1,s2) <- [(".1", ".2") ,("_1", "_2"), ("_F", "_R")]+    return (s1 ++ "." ++ end, s2 ++ "." ++ end)++buildSingle m1+    | "pair.1" `isInfixOf` m1 = T.unpack $ T.replace "pair.1" "single" (T.pack m1)+    | "pair.2" `isInfixOf` m1 = T.unpack $ T.replace "pair.2" "single" (T.pack m1)+    | otherwise = "MARKER_FOR_FILE_WHICH_DOES_NOT_EXIST"++matchUp :: [FilePath] -> NGLess ([FilePath], [Either (FilePath, FilePath) (FilePath,FilePath, FilePath)])+matchUp fqfiles = do+    let match1 :: FilePath -> Maybe (FilePath, FilePath)+        match1 fp = listToMaybe . flip mapMaybe pairedEnds $ \(p1,p2) -> if+                    | (isSuffixOf p1 fp) -> Just (fp, dropEnd (length p1) fp ++ p2)+                    | (isSuffixOf p2 fp) -> Just (dropEnd (length p2) fp ++ p1, fp)+                    | otherwise -> Nothing+        -- match1 returns repeated entries if both pair.1 and pair.2 exist, `nub` removes duplicate records+        matched1 = nub $ mapMaybe match1 fqfiles+    paired <- forM matched1 $ \(m1,m2) -> do+        let singles = buildSingle m1+        unless (m1 `elem` fqfiles) $ throwDataError ("Cannot find match for file: " ++ m2)+        unless (m2 `elem` fqfiles) $ throwDataError ("Cannot find match for file: " ++ m1)+        return $+            if singles `elem` fqfiles+                then Right (m1, m2, singles)+                else Left (m1, m2)+    let used = concat $ flip map paired $ \case+                Left (a,b) -> [a,b]+                Right (a,b,c) -> [a,b,c]+        singletons = filter (`notElem` used) fqfiles+    return (singletons, paired)++loadDirectoryFiles :: [FilePath] -> T.Text -> Bool -> NGLessIO [NGLessObject]+loadDirectoryFiles fqfiles encoding doQC = do+    let passthru = [("__perform_qc", NGOBool doQC), ("encoding", NGOSymbol encoding)]+        encodeStr = NGOString . T.pack+    (singletons, paired) <- runNGLess $ matchUp fqfiles++    singletons' <- forM singletons $ \f -> do+        outputListLno' InfoOutput ["load_fastq_directory found single-end sample '", f, "'"]+        executeFastq (encodeStr f) passthru+    paired' <- forM paired $ \match -> do+        let (m1, m2, singlesMsg, singlesArgs) = case match of+                Left (a, b) -> (a, b, "", [])+                Right (a, b, singles) -> (a, b,+                            "' with singles file '" ++ singles ++ "'",+                            [("singles", encodeStr singles)])+        outputListLno' InfoOutput [+                        "load_fastq_directory found paired-end sample '",+                        m1, "' - '", m2,+                        singlesMsg]+        executePaired (encodeStr m1) (("second", encodeStr m2):(singlesArgs++passthru))+    return $ singletons' ++ paired'+++executeLoad :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeLoad (NGOString samplename) kwargs = do+    qcNeeded <- lookupBoolOrScriptErrorDef (return True) "hidden QC argument" "__perform_qc" kwargs+    encoding <- lookupSymbolOrScriptErrorDef (return "auto") "encoding passthru argument" "encoding" kwargs+    outputListLno' TraceOutput ["Executing load_fastq_directory transform"]+    let basedir = T.unpack samplename+    unlessM (liftIO $ doesDirectoryExist basedir) $+        throwDataError ("Attempting to load directory '"++basedir++"', but directory does not exist.")+    fqfiles <- fmap (sort . concat) $ forM exts $ \pat ->+        liftIO $ namesMatching (basedir </> ("*." ++ pat))+    args <- loadDirectoryFiles fqfiles encoding qcNeeded+    executeGroup (NGOList args) [("name", NGOString samplename)]+executeLoad _ _ = throwShouldNotOccur "load_fastq_directory got the wrong arguments."+++loadFastqDirectory = Function+    { funcName = FuncName "load_fastq_directory"+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLReadSet+    , funcKwArgs =+            [ArgInformation "__perform_qc" False NGLBool []+            ,ArgInformation "encoding" False NGLSymbol [ArgCheckSymbol ["auto", "33", "64", "sanger", "solexa"]]+            ]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }+++loadModule :: T.Text -> NGLessIO Module+loadModule _ =+        return def+        { modInfo = ModInfo "builtin.load_directory" "1.0"+        , modCitations = []+        , modFunctions = [loadFastqDirectory]+        , runFunction = \case+                        "load_fastq_directory" -> executeLoad+                        other -> \_ _ -> throwShouldNotOccur ("mocat execute function called with wrong arguments: " ++ show other)+        }
+ NGLess/BuiltinModules/ORFFind.hs view
@@ -0,0 +1,79 @@+{- Copyright 2017-2019 NGLess Authors+ - License: MIT+ -}++module BuiltinModules.ORFFind+    ( loadModule+    ) where++import qualified Data.Text as T+import           System.IO (hClose)+import           Control.Monad.Except (liftIO)+import           Data.Default (def)++import Language+import Modules+import Output+import NGLess+import FileOrStream+import FileManagement (prodigalBin, openNGLTempFile)+import Utils.Process (runProcess)+import Utils.Utils (fmapMaybeM)++executeORFFind :: T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeORFFind "orf_find" expr kwargs = do+    input <- case expr of+            NGOSequenceSet f -> return f+            NGOFilename f -> return $ File f+            NGOString f -> return $ File (T.unpack f)+            _ -> throwScriptError ("orf_find first argument should have been sequenceset, got '"++show expr++"'")+    isMetagenome <- lookupBoolOrScriptError "orf_find" "is_metagenome" kwargs+    coordsOut <- fmapMaybeM (stringOrTypeError "coords_out argument for orf_find") $ lookup "coords_out" kwargs+    aaOut <- fmapMaybeM (stringOrTypeError "prots_out argument for orf_find") $ lookup "prots_out" kwargs+    includeFragments <- lookupBoolOrScriptErrorDef (return True) "include_fragments arg for orf_find" "include_fragments" kwargs+    prodigalPath <- prodigalBin+    fp <- asFile input+    (dnaout, h) <- openNGLTempFile fp "gene_predict" "fna"+    liftIO $ hClose h+    let args = ["-i", fp,+                "-d", dnaout]+                ++ (if isMetagenome+                            then ["-p", "meta"]+                            else [])+                ++ (case coordsOut of+                        Nothing -> ["-o", "/dev/null"]+                        Just c -> ["-o", T.unpack c, "-f", "gff"])+                ++ (case aaOut of+                        Nothing -> []+                        Just ao -> ["-a", T.unpack ao])+                ++ ["-c" | not includeFragments]++    outputListLno' DebugOutput ["Calling prodigal: ", prodigalPath, " ", unwords args]+    runProcess prodigalPath args (return ()) (Left ())+    -- return $! NGOSequenceSet (File dnaout)+    return $! NGOFilename dnaout+executeORFFind _ _ _ = throwScriptError "unexpected code path taken [prodigal:orf_find]"++orfFindFunction = Function+    { funcName = FuncName "orf_find"+    -- , funcArgType = Just NGLSequenceSet+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLFilename+    , funcKwArgs =+            [ArgInformation "is_metagenome" True NGLBool []+            ,ArgInformation "include_fragments" False NGLBool [ArgCheckMinVersion (1,1)]+            ,ArgInformation "coords_out" False NGLString [ArgCheckFileWritable]+            ,ArgInformation "prots_out" False NGLString [ArgCheckFileWritable]+            ]+    , funcAllowsAutoComprehension = False+    , funcChecks = [FunctionCheckReturnAssigned]+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.orffind" "0.6"+    , modFunctions = [orfFindFunction]+    , runFunction = executeORFFind+    }+
+ NGLess/BuiltinModules/QCStats.hs view
@@ -0,0 +1,52 @@+{- Copyright 2017-2019 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE FlexibleContexts #-}++module BuiltinModules.QCStats+    ( loadModule+    ) where++import qualified Data.Text as T+import           Data.Default (def)+import Control.Monad.Except+import System.IO++import Language+import FileManagement++import Modules+import Output+import NGLess+import FileOrStream++executeStats :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeStats (NGOSymbol statsType) [] = do+        (fp, h) <- openNGLTempFile "" "qcstats" "tsv"+        liftIO $ hClose h+        case statsType of+            "mapping" -> writeOutputTSV True Nothing (Just fp)+            "fastq" -> writeOutputTSV True (Just fp) Nothing+            _ -> throwScriptError ("Unknown stats type: " ++ T.unpack statsType)+        return $ NGOCounts (File fp)+executeStats arg _ = throwShouldNotOccur ("executeStats called with argument: " ++ show arg)++qcStatsFunction = Function+    { funcName = FuncName "qcstats"+    , funcArgType = Just NGLSymbol+    , funcArgChecks = [ArgCheckSymbol ["fastq", "mapping"]]+    , funcRetType = NGLCounts+    , funcKwArgs = []+    , funcAllowsAutoComprehension = False+    , funcChecks = [FunctionCheckReturnAssigned+                   ,FunctionCheckNGLVersionIncompatibleChange (0, 8) ""]+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.stats" "0.6"+    , modFunctions = [qcStatsFunction]+    , runFunction = const executeStats+    }+
+ NGLess/BuiltinModules/Readlines.hs view
@@ -0,0 +1,51 @@+{- Copyright 2016-2019 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE ScopedTypeVariables #-}++module BuiltinModules.Readlines+    ( loadModule+    ) where++import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import           Data.Conduit ((.|))+import           Data.Default (def)++import Language++import Modules+import NGLess+import Utils.Conduit (ByteLine(..), linesC)++executeReadlines :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeReadlines (NGOString fname) _ = do+    content <-+        C.runConduit $ (CC.sourceFile (T.unpack fname) `C.catchC` (\(e :: IOError) ->+                                            throwDataError ("Could not read file '"++T.unpack fname++"': " ++ show e)))+            .| linesC+            .| CL.consume+    return $! NGOList [NGOString (T.pack . B8.unpack $ ell) | ByteLine ell <- content]+executeReadlines arg _ = throwShouldNotOccur ("executeReadlines called with argument: " ++ show arg)++readlines_Function = Function+    { funcName = FuncName "readlines"+    , funcArgType = Just NGLString+    , funcArgChecks = [ArgCheckFileReadable]+    , funcRetType = NGList NGLString+    , funcKwArgs = []+    , funcAllowsAutoComprehension = False+    , funcChecks = [FunctionCheckReturnAssigned]+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.readlines" "0.0"+    , modFunctions = [readlines_Function]+    , runFunction = const executeReadlines+    }+
+ NGLess/BuiltinModules/Remove.hs view
@@ -0,0 +1,52 @@+{- Copyright 2016 NGLess Authors+ - License: MIT+ -}+++module BuiltinModules.Remove+    ( loadModule+    ) where++import qualified Data.Text as T+import Control.Monad (forM_)+import Data.Default (def)++import Data.FastQ+import Language+import FileManagement (removeIfTemporary)+import FileOrStream+import Modules+import NGLess+++executeRemove :: T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeRemove "__remove" expr [] = do+    let files = case expr of+            NGOReadSet _ (ReadSet pairs singles) ->+                                (fqpathFilePath . fst <$> pairs)+                                ++ (fqpathFilePath . snd <$> pairs)+                                ++ (fqpathFilePath <$> singles)+            NGOMappedReadSet _ (File f) _ -> [f]+            NGOCounts (File f) -> [f]+            _ -> []+    forM_ files removeIfTemporary+    return NGOVoid+executeRemove _ _ _ = return NGOVoid++removeFunction = Function+    { funcName = FuncName "__remove"+    , funcArgType = Nothing+    , funcArgChecks = []+    , funcRetType = NGLVoid+    , funcKwArgs = []+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "builtin.remove" "0.0"+    , modFunctions = [removeFunction]+    , runFunction = executeRemove+    }+
+ NGLess/CWL.hs view
@@ -0,0 +1,75 @@+{- Copyright 2017 NGLess Authors+ - License: MIT+ -}+module CWL+    ( writeCWL+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import           Data.Maybe+import           Control.Monad.Trans.Cont (evalCont, callCC)++import Utils.Utils+import Language++{- Build a CWL wrapper for the NGLess script+ -+ - Currently, this is very simplistic with little error checking.+ -}+++build :: FilePath -> [Integer] -> Integer -> String+build sfname inputs output = concat+    ["cwlVersion: cwl:draft-3\n"+    ,"class: CommandLineTool\n"+    ,"baseCommand: [ngless, ", sfname, "]\n"+    ,"inputs:\n"+    ,buildInputs inputs+    ,builtOutput output+    ]++buildInputs :: [Integer] -> String+buildInputs = concatMap buildInput+buildInput :: Integer -> String+buildInput p = concat+    ["- id: input", show p, "\n"+    ,"  type: Str\n"+    ,"  inputBinding:\n"+    ,"    position: ", show p, "\n"+    ]+builtOutput p = concat+    ["outputs:\n"+    ,"  -id: nglessout\n"+    ,"  type: File\n"+    ,"  outputBinding:\n"+    ,"    glob: $(inputs.input"++show p++")\n"+    ]+++extractARGVUsage :: Expression -> Maybe Integer+extractARGVUsage e = evalCont $ callCC $ \exit -> do+                        recursiveAnalyse (extractARGVUsage' exit) e+                        return Nothing+    where+        extractARGVUsage' exit (IndexExpression (Lookup _ (Variable "ARGV")) (IndexOne (ConstInt ix1))) = exit (Just ix1)+        extractARGVUsage' _ _ = return ()++extractAllARGVUsage :: Script -> [Integer]+extractAllARGVUsage (Script _ body) = mapMaybe extractARGVUsage (snd <$> body)++extractOutput (Script _ body) = head $ mapMaybe  extractOutput' (snd <$> body)+    where+        extractOutput' :: Expression -> Maybe Integer+        extractOutput' (FunctionCall (FuncName "write") _ kwargs _) = do+            ofile <- lookup (Variable "ofile") kwargs+            extractARGVUsage ofile+        extractOutput' _ = Nothing++writeCWL :: Script -> FilePath -> FilePath -> IO ()+writeCWL sc scFname fp =+    withOutputFile fp $ \h ->+        B.hPut h (B8.pack $ buildCWL scFname sc)++buildCWL :: FilePath -> Script -> String+buildCWL scFname sc = build scFname (extractAllARGVUsage sc) (extractOutput sc)
+ NGLess/Citations.hs view
@@ -0,0 +1,33 @@+{- Copyright 2017-2018 NGLess Authors+ - License: MIT+ -}+module Citations+    ( collectCitations+    ) where++import qualified Data.Text as T+import qualified Data.Set as S+import Data.Maybe (mapMaybe)++import Modules+import Language++citations :: [(T.Text, T.Text)]+citations =+    [("assemble", "Li, D., Liu, C.M., Luo, R., Sadakane, K. and Lam, T.W., 2015. MEGAHIT: an ultra-fast single-node solution for large and complex metagenomics assembly via succinct de Bruijn graph. Bioinformatics, 31(10), pp.1674-1676.")+    ,("orf_find", "Hyatt, D., Chen, G.L., LoCascio, P.F., Land, M.L., Larimer, F.W. and Hauser, L.J., 2010. Prodigal: prokaryotic gene recognition and translation initiation site identification. BMC bioinformatics, 11(1), p.119.")+    ,("map", "Li, H., 2013. Aligning sequence reads, clone sequences and assembly contigs with BWA-MEM. arXiv preprint arXiv:1303.3997.")+    ]++nglessCitation :: T.Text+nglessCitation =+    "Coelho, L.P., Alves, R., Monteiro, P., Huerta-Cepas, J., Freitas, A.T., and Bork, P., NG-meta-profiler: fast processing of metagenomes using NGLess, a domain-specific language. in Microbiome 7:84 (2019). DOI: http://doi.org/10.1186/s40168-019-0684-8"+++collectCitations :: [Module] -> Script -> [T.Text]+collectCitations mods (Script _ sc) =+    let modCits = concatMap modCitations mods+        useCits = flip mapMaybe (snd <$> sc) $ \case+            Assignment _ (FunctionCall (FuncName f) _ _ _) -> lookup f citations+            _ -> Nothing+    in nglessCitation : (S.toList . S.fromList) (modCits ++ useCits)
+ NGLess/CmdArgs.hs view
@@ -0,0 +1,209 @@+{- Copyright 2015-2022 NGLess Authors+ - License: MIT+ -}+module CmdArgs+    ( ColorSetting(..)+    , Verbosity(..)+    , NThreadsOpts(..)+    , NGLessInput(..)+    , NGLessArgs(..)+    , NGLessMode(..)+    , nglessArgs+    ) where++{-| This is a separate module so that Main & Configuration+ - can share these objects. Putting them in Configuration would, however,+ - pollute it as it is imported from everywhere.+ -}++import Options.Applicative+import Text.Read (readMaybe)+import qualified Data.Configurator.Types as CF+import qualified Data.Text as T++data Verbosity = Quiet | Normal | Loud+        deriving (Show, Eq, Ord, Enum)+data ColorSetting = AutoColor | NoColor | ForceColor+    deriving (Eq, Show)++instance CF.Configured ColorSetting where+    convert (CF.String "auto") = Just AutoColor+    convert (CF.String "force") = Just ForceColor+    convert (CF.String "none") = Just NoColor+    convert _ = Nothing+++data NThreadsOpts = NThreads Int | NThreadsAuto+    deriving (Eq, Show)++instance CF.Configured NThreadsOpts where+    convert (CF.String "auto") = Just NThreadsAuto+    convert (CF.String val) = NThreads <$> (readMaybe $ T.unpack val)+    convert _ = Nothing++data NGLessInput =+        InlineScript String+        | ScriptFilePath FilePath+    deriving (Eq, Show)++data NGLessArgs = NGLessArgs+        { mode :: NGLessMode+        , verbosity :: Verbosity+        , quiet :: Bool+        , color :: Maybe ColorSetting+        , trace_flag :: Maybe Bool+        } deriving (Eq, Show)+data NGLessMode =+        DefaultMode+              { input :: NGLessInput+              , debug_mode :: String+              , validateOnly :: Bool+              , print_last :: Bool+              , nThreads :: NThreadsOpts+              , strictThreads :: Maybe Bool+              , createReportDirectory :: Maybe Bool+              , html_report_directory :: Maybe FilePath+              , temporary_directory :: Maybe FilePath+              , keep_temporary_files :: Maybe Bool+              , config_files :: [FilePath]+              , no_header :: Bool+              , subsampleMode :: Bool+              , experimentalFeatures :: Bool+              , exportJSON :: Maybe FilePath+              , exportCWL :: Maybe FilePath+              , deprecationCheck :: Bool+              , searchPath :: [FilePath]+              , indexPath :: Maybe FilePath+              , extraArgs :: [String]+              }+        | InstallReferenceMode+              { refname :: T.Text+              }+        | CreateReferencePackMode+              { oname :: FilePath+              , genome_url :: String+              , gtf_url :: Maybe String+              , functional_map_url :: Maybe String+              }+        | DownloadFileMode+              { origUrl :: String+              , localFile :: FilePath+              }+        | DownloadDemoMode+              { demoName :: String+              }+        | PrintPathMode+              { pathDesired :: String+              }+        | CheckInstallMode+              { checkInstallVerbose :: Bool+              }+           deriving (Eq, Show)++parseVerbosity = option (eitherReader readVerbosity) (long "verbosity" <> short 'v' <> value Normal)+    where+        readVerbosity :: String -> Either String Verbosity+        readVerbosity "quiet" = Right Quiet+        readVerbosity "normal" = Right Normal+        readVerbosity "full" = Right Loud+        readVerbosity other = Left ("Cannot parse '" ++ other ++ "' as a verbosity")++parseColor = optional $ option (eitherReader readColor) (long "color" <> help colorHelp)+    where+        readColor "auto" = Right AutoColor+        readColor "no" = Right NoColor+        readColor "yes" = Right ForceColor+        readColor "force" = Right ForceColor+        readColor _ = Left "Could not parse color option (valid options are 'auto', 'force', and 'no')"+        colorHelp = "Color settings, one of 'auto' (color if writing to a terminal, this is the default), 'force' (always color), 'no' (no color)."++-- The input can be either inline (using -e ... or --script "...") or given as+-- a filepath+parseInput :: Parser NGLessInput+parseInput = InlineScript <$> strOption+                        (long "script"+                        <> short 'e'+                        <> help "inline script to execute")+            <|> ScriptFilePath <$> strArgument (metavar "INPUT" <> help "Filename of script to interpret")++-- A integer literal or the string "auto"+parseNThreads = option (eitherReader readNThreads) (long "jobs" <> short 'j' <> long "threads" <> value (NThreads 1) <> help "Nr of threads to use")+    where+        readNThreads "auto" = Right NThreadsAuto+        readNThreads val = case readMaybe val of+                            Just n -> Right (NThreads n)+                            Nothing -> Left ("Failed to parse "++val++" as a threads option")++-- An option with 3 states+--    ""            -> Nothing+--    "--option"    -> Just True+--    "--no-option" -> Just False+--+-- This builds on the `switch` function because it distinguishes between not+-- passing in the option.+triSwitch :: String -> String -> Parser (Maybe Bool)+triSwitch name helpmsg = optional (flag' True  (long         name <> help helpmsg)+                               <|> flag' False (long ("no-"++name) <> help ("opposite of --"++name)))++mainArgs = DefaultMode+              <$> parseInput -- input :: NGLessInput+              <*> strOption (long "debug" <> value "") -- debug_mode :: String+              <*> switch (long "validate-only" <> short 'n' <> help "Only validate input, do not run script") -- validateOnly :: Bool+              <*> switch (long "print-last" <> short 'p' <> help "print value of last line in script") -- print_last :: Bool+              <*> parseNThreads+              <*> triSwitch "strict-threads" "strictly respect the --threads option (by default, NGLess will, occasionally, use more threads than specified)" -- scrict-threads :: Bool+              <*> triSwitch "create-report" "create the report directory" -- createReportDirectory :: Bool+              <*> optional (strOption $ long "html-report-directory" <> short 'o' <> help "name of output directory") -- html_report_directory :: Maybe FilePath+              <*> optional (strOption $ long "temporary-directory" <> short 't' <> help "Directory where to store temporary files") -- temporary_directory :: Maybe FilePath+              <*> triSwitch "keep-temporary-files" "Whether to keep temporary files (default is delete them)" -- keep_temporary_files :: Maybe Bool+              <*> many (strOption $ long "config-file" <> help "Configuration files to parse") -- config_files :: Maybe [FilePath]+              <*> switch (long "no-header" <> help "Do not print copyright information") -- no_header :: Bool+              <*> switch (long "subsample" <> help "Subsample mode: quickly test a pipeline by discarding 99% of the input")-- subsampleMode :: Bool+              <*> switch (long "experimental-features" <> help "Whether to allow the use of experimental features") -- experimentalFeatures :: Bool+              <*> optional (strOption $ long "export-json" <> help "File to write JSON representation of script to") -- exportJSON :: Maybe FilePath+              <*> optional (strOption $ long "export-cwl" <> help "File to write CWL wrapper of given script") -- exportCWL :: Maybe FilePath+              <*> switch (long "check-deprecation" <> help "Check if ngless version or any used modules have been deprecated")-- deprecationCheck :: Bool+              <*> many (+                  (strOption $ long "search-dir" <> help "Deprecated. Use --search-path instead") -- searchDir :: [FilePath]+              <|> (strOption $ long "search-path" <> help "Reference search directories (replace <references> in script)") -- searchPath :: [FilePath]+              )+              <*> optional (strOption $ long "index-path" <> help "Index path (directory where indices are stored)") -- indexPath :: Maybe FilePath+              <*> many (strArgument (metavar "ARGV")) -- extraArgs :: [String]++installArgs = (flag' InstallReferenceMode (long "install-reference-data"))+                <*> (T.pack <$> strArgument (help "Name of reference to install" <> metavar "REF"))+        -- += details  [ "Example:" , "(sudo) ngless --install-reference-data sacCer3" ]++createRefArgs = flag' CreateReferencePackMode (long "create-reference-pack" <> internal)+                        <*> strOption (long "output-name" <> internal)+                        <*> strOption (long "genome-url" <> internal)+                        <*> optional (strOption $ long "gtf-url" <> internal)+                        <*> optional (strOption $ long "functional-map-url" <> internal)+        -- += details ["Example:", "ngless --create-reference-pack ref.tar.gz -g http://...genome.fa.gz -a http://...gtf.fa.gz"]++downloadFileArgs = flag' DownloadFileMode (long "download-file")+                        <*> strOption (long "download-url")+                        <*> strOption (long "local-file")++downloadDemoArgs = flag' DownloadDemoMode (long "download-demo")+                        <*> strArgument (metavar "DEMO-NAME")++printPathArgs = flag' PrintPathMode (long "print-path")+                        <*> strArgument (metavar "EXEC")++checkInstallArgs = flag' CheckInstallMode (long "check-install" <> help "Check if ngless is correctly installed")+                          <*> switch (long "verbose" <> short 'v' <> help "Print paths")++nglessArgs :: Parser NGLessArgs+nglessArgs = NGLessArgs+                <$> (mainArgs+                        <|> downloadFileArgs+                        <|> downloadDemoArgs+                        <|> installArgs+                        <|> createRefArgs+                        <|> printPathArgs+                        <|> checkInstallArgs)+                <*> parseVerbosity+                <*> switch (long "quiet" <> short 'q')+                <*> parseColor+                <*> triSwitch "trace" "Set highest verbosity mode" -- trace_flag :: Maybe Bool
+ NGLess/Configuration.hs view
@@ -0,0 +1,192 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE RecordWildCards #-}+module Configuration+    ( NGLessConfiguration(..)+    , NGLessOutputDestination(..)+    , ColorSetting(..)+    , guessConfiguration+    , initConfiguration+    ) where++import Control.Monad+import System.Environment (getExecutablePath, lookupEnv)+import System.Directory+import System.FilePath+import Data.Maybe+import Control.Applicative+import qualified Data.Text as T+import qualified Data.Configurator as CF++import CmdArgs++defaultBaseURL :: FilePath+defaultBaseURL = "https://ngless.embl.de/resources/"++data NGLessOutputDestination = NGLOutStdout | NGLOutStderr deriving (Eq, Show)++-- | ngless configuration options+data NGLessConfiguration = NGLessConfiguration+    { nConfDownloadBaseURL :: FilePath+    , nConfGlobalDataDirectory :: FilePath+    , nConfUserDirectory :: FilePath+    , nConfUserDataDirectory :: FilePath+    , nConfTemporaryDirectory :: FilePath+    , nConfKeepTemporaryFiles :: Bool+    , nConfTrace :: Bool+    , nConfStrictThreads :: Bool+    , nConfCreateReportDirectory :: Bool+    , nConfReportDirectory :: FilePath+    , nConfColor :: ColorSetting+    , nConfPrintHeader :: Bool+    , nConfSubsample :: Bool+    , nConfArgv :: [T.Text]+    , nConfVerbosity :: Verbosity+    , nConfOutputTo :: NGLessOutputDestination+    , nConfSearchPath :: [FilePath]+    , nConfIndexStorePath :: Maybe FilePath+    } deriving (Eq, Show)+++-- | Where to save data (user mode)+getDefaultUserNglessDirectory :: IO FilePath+getDefaultUserNglessDirectory = liftM2 fromMaybe+    ((</> ".local/share/ngless") <$> getHomeDirectory)+    (fmap (</> "ngless") <$> lookupEnv "XDG_DATA_HOME")+++-- | This sets the default configuration based on the environment+guessConfiguration :: IO NGLessConfiguration+guessConfiguration = do+    tmp <- getTemporaryDirectory+    nglessBinDirectory <- takeDirectory <$> getExecutablePath+    defaultUserNglessDirectory <- getDefaultUserNglessDirectory+    return NGLessConfiguration+        { nConfDownloadBaseURL = defaultBaseURL+        , nConfGlobalDataDirectory = nglessBinDirectory </> "../share/ngless/data"+        , nConfUserDirectory = defaultUserNglessDirectory+        , nConfUserDataDirectory = defaultUserNglessDirectory </> "data"+        , nConfCreateReportDirectory = True+        , nConfTemporaryDirectory = tmp+        , nConfKeepTemporaryFiles = False+        , nConfTrace = False+        , nConfStrictThreads = False+        , nConfReportDirectory = ""+        , nConfColor = AutoColor+        , nConfPrintHeader = True+        , nConfSubsample = False+        , nConfArgv = []+        , nConfVerbosity = Normal+        , nConfOutputTo = NGLOutStdout+        , nConfSearchPath = []+        , nConfIndexStorePath = Nothing+        }++-- | Update configuration options based on config files+readConfigFiles :: NGLessConfiguration -> [FilePath] -> IO NGLessConfiguration+readConfigFiles NGLessConfiguration{..} cfiles = do+    defaultUserConfig1 <- (</> ".config/ngless.conf") <$> getHomeDirectory+    defaultUserConfig2 <- (</> ".ngless.conf") <$> getHomeDirectory+    let configFiles =+                    [CF.Optional defaultUserConfig1+                    ,CF.Optional defaultUserConfig2+                    ,CF.Optional "/etc/ngless.conf"+                    ] ++ map CF.Required cfiles+    cp <- CF.load configFiles+    nConfDownloadBaseURL' <- CF.lookupDefault nConfDownloadBaseURL cp "download-url"+    nConfGlobalDataDirectory' <- CF.lookupDefault nConfGlobalDataDirectory cp "global-data-directory"+    nConfUserDirectory' <- CF.lookupDefault nConfUserDirectory cp "user-directory"+    nConfUserDataDirectory' <- CF.lookupDefault nConfUserDataDirectory cp "user-data-directory"+    nConfTemporaryDirectory' <- CF.lookupDefault nConfTemporaryDirectory cp "temporary-directory"+    nConfKeepTemporaryFiles' <- CF.lookupDefault nConfKeepTemporaryFiles cp "keep-temporary-files"+    nConfStrictThreads' <- CF.lookupDefault nConfStrictThreads cp "strict-threads"+    nConfColor' <- CF.lookupDefault AutoColor cp "color"+    nConfPrintHeader' <- CF.lookupDefault nConfPrintHeader cp "print-header"+    nConfSearchPath' <- CF.lookupDefault nConfSearchPath cp "search-path"+    nConfCreateReportDirectory' <- CF.lookupDefault nConfCreateReportDirectory cp "create-report"+    nConfIndexStorePath' <- CF.lookup cp "index-path"+    return NGLessConfiguration+        { nConfDownloadBaseURL = nConfDownloadBaseURL'+        , nConfGlobalDataDirectory = nConfGlobalDataDirectory'+        , nConfUserDirectory = nConfUserDirectory'+        , nConfUserDataDirectory = nConfUserDataDirectory'+        , nConfTemporaryDirectory = nConfTemporaryDirectory'+        , nConfKeepTemporaryFiles = nConfKeepTemporaryFiles'+        , nConfTrace = nConfTrace+        , nConfStrictThreads = nConfStrictThreads'+        , nConfCreateReportDirectory = nConfCreateReportDirectory'+        , nConfReportDirectory = nConfReportDirectory+        , nConfColor = nConfColor'+        , nConfPrintHeader = nConfPrintHeader'+        , nConfSubsample = nConfSubsample+        , nConfArgv = nConfArgv+        , nConfVerbosity = nConfVerbosity+        , nConfOutputTo = NGLOutStdout+        , nConfSearchPath = nConfSearchPath'+        , nConfIndexStorePath = nConfIndexStorePath' <|> nConfIndexStorePath+        }++-- | Configuration is set in 3 steps:+-- 1. 'guessConfiguration' sets defaults based on environment+-- 2. 'readConfigFiles' reads configuration files+-- 3. 'updateConfigurationOpts' uses command line options to update+initConfiguration :: NGLessArgs -> IO NGLessConfiguration+initConfiguration opts = do+        config <- guessConfiguration+        config' <- readConfigFiles config (case mode opts of+            DefaultMode{config_files = cs} -> cs+            _ -> [])+        return $! updateConfigurationOpts opts config'+    where++        updateConfigurationOpts NGLessArgs{..} config =+            let nConfTrace' = fromMaybe+                            (nConfTrace config)+                            trace_flag+            in  updateConfigurationOptsMode mode $+                    config+                        { nConfColor = fromMaybe (nConfColor config) color+                        , nConfVerbosity = if quiet then Quiet else verbosity+                        , nConfTrace = nConfTrace'+                        }++        updateConfigurationOptsMode DefaultMode{..} config =+            let strictThreads' = fromMaybe+                            (nConfStrictThreads config)+                            strictThreads+                ktemp = fromMaybe+                            (nConfKeepTemporaryFiles config)+                            keep_temporary_files+                tmpdir = fromMaybe+                            (nConfTemporaryDirectory config)+                            temporary_directory+                html_odir = case (html_report_directory, input) of+                    (Nothing, ScriptFilePath "-") -> "STDIN.output_ngless"+                    (Nothing, ScriptFilePath fpscript) -> fpscript ++ ".output_ngless"+                    (Nothing, InlineScript _ ) -> "INLINE_SCRIPT.output_ngless"+                    (Just html_odir', _) -> html_odir'+                argv = case input of+                    ScriptFilePath f -> f:extraArgs+                    _ -> extraArgs+                searchPath' = if null searchPath+                                    then nConfSearchPath config+                                    else searchPath+                createReportDirectory' = fromMaybe+                                    (nConfCreateReportDirectory config)+                                    createReportDirectory+                indexPath' = indexPath <|> nConfIndexStorePath config+            in config+                    { nConfStrictThreads = strictThreads'+                    , nConfKeepTemporaryFiles = ktemp+                    , nConfCreateReportDirectory = createReportDirectory'+                    , nConfReportDirectory = html_odir+                    , nConfTemporaryDirectory = tmpdir+                    , nConfPrintHeader = nConfPrintHeader config && not no_header && not print_last+                    , nConfSubsample = subsampleMode+                    , nConfArgv = T.pack <$> argv+                    , nConfSearchPath = searchPath'+                    , nConfIndexStorePath = indexPath'+                    }+        updateConfigurationOptsMode _ config = config+
+ NGLess/Data/FastQ.c view
@@ -0,0 +1,8 @@+#include <stdio.h>+void updateCharCount(unsigned int n, char* pc, long int* v) {+    unsigned int i;+    unsigned char* p = (unsigned char*)pc;+    for (i = 0; i < n; ++i) {+        ++v[p[i]];+    }+}
+ NGLess/Data/FastQ.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiWayIf #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, CPP #-}+{- Copyright 2013-2019 NGLess Authors+ - License: MIT+ -}++module Data.FastQ+    ( ShortRead(..)+    , FastQEncoding(..)+    , FastQFilePath(..)+    , ReadSet(..)+    , FQStatistics(..)+    , nBasepairs+    , srSlice+    , srLength+    , encodingName+    , fqDecodeVector+    , fqDecodeC+    , fqEncode+    , fqEncodeC+    , gcFraction+    , nonATCGFrac+    , statsFromFastQ+    , fqStatsC+    , qualityPercentiles+    , interleaveFQs+#ifdef IS_BUILDING_TEST+    , vSub+#endif+    ) where++import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString as B+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import           Control.DeepSeq (NFData(..))+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import Control.Monad.Except+import Control.Monad.Trans.Resource+import Control.Exception++import           System.IO.Unsafe (unsafeDupablePerformIO)+import qualified Language.C.Inline.Unsafe as CU+import qualified Language.C.Inline as C+++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Storable.Mutable as VSM+import qualified Data.Vector.Unboxed.Mutable as VUM++import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (poke)+import Foreign.C.Types+import Foreign.C.String++import Data.IORef+import Data.Maybe+import Data.Int+import Data.Char+import Data.Word++import NGLess.NGError+import Utils.Conduit+import Utils.Vector (unsafeIncrement)+++C.context (C.baseCtx <> C.bsCtx <> C.vecCtx)+C.include "<stdint.h>"++foreign import ccall unsafe "updateCharCount" c_updateCharCount :: CUInt -> CString -> Ptr Int -> IO ()++    -- | Represents a short read+data ShortRead = ShortRead+        { srHeader :: !B.ByteString+        , srSequence :: !B.ByteString+        , srQualities :: !(VS.Vector Int8) -- ^ these have been decoded+        } deriving (Eq, Show, Ord)++instance NFData ShortRead where+    rnf ShortRead{} = ()++data FastQEncoding = SangerEncoding | SolexaEncoding deriving (Eq, Bounded, Enum, Show, Ord)++data FastQFilePath = FastQFilePath+                        { fqpathEncoding :: !FastQEncoding -- ^ encoding+                        , fqpathFilePath :: FilePath -- ^ file_on_disk+                        } deriving (Eq, Show, Ord)++data ReadSet = ReadSet+                { pairedSamples :: [(FastQFilePath, FastQFilePath)]+                , singleSamples :: [FastQFilePath]+                } deriving (Eq, Show, Ord)++data FQStatistics = FQStatistics+                { bpCounts :: (Int, Int, Int, Int, Int) -- ^ number of (A, C, T, G, OTHER)+                , lc :: !Int8 -- ^ lowest quality value+                , qualCounts ::  [VU.Vector Int] -- ^ quality counts by position+                , nSeq :: !Int -- ^ number of sequences+                , seqSize :: (Int,Int) -- ^ min and max+                } deriving(Eq,Show)++instance NFData FQStatistics where+    rnf (FQStatistics (!_,!_,!_,!_,!_) !_ qv !_ (!_,!_)) = rnf qv++-- | Total number of base pairs+-- Returns an Integer as it can be > 2³¹+nBasepairs :: FQStatistics -> Integer+nBasepairs fqstats = sum $ map (sum . map toInteger . VU.toList) $ qualCounts fqstats++minQualityValue :: Num a => a+minQualityValue = -5++-- short read length+srLength :: ShortRead -> Int+srLength = B.length . srSequence++-- slice a short read+srSlice ::+        Int -- ^ start pos+        -> Int -- ^ length of result+        -> ShortRead+        -> ShortRead+srSlice s n (ShortRead rId rS rQ) = assert (B.length rS >= s + n) $ ShortRead rId (B.take n $ B.drop s rS) (VS.slice s n rQ)++encodingOffset :: Num a => FastQEncoding -> a+encodingOffset SangerEncoding = 33+encodingOffset SolexaEncoding = 64++encodingName :: FastQEncoding -> String+encodingName SangerEncoding = "Sanger (33 offset)"+encodingName SolexaEncoding = "Solexa (64 offset)"+++-- | encode ShortRead as a ByteString (FastQ format)+fqEncodeC :: (Monad m) => FastQEncoding -> C.ConduitT ShortRead B.ByteString m ()+fqEncodeC enc = CL.map (fqEncode enc)++-- Using B.map instead of this function makes this loop be one of the functions+-- with the highest memory allocation in ngless.+bsAdd :: VS.Vector Int8 -> Int8 -> B.ByteString+bsAdd c delta = BI.unsafeCreate cn $ \p -> copyAddLoop p 0+    where+        cn = VS.length c+        copyAddLoop p i+            | i == cn = return ()+            | otherwise = do+                poke (p `plusPtr` i) ((fromIntegral $ c VS.! i + delta) :: Word8)+                copyAddLoop p (i + 1)++vSub :: B.ByteString -> Int8 -> VS.Vector Int8+vSub qs delta = unsafeDupablePerformIO $ do+    r <- VSM.new (B.length qs)+    [CU.block| void {+        int i;+        int len = $bs-len:qs;+        const char* in = $bs-ptr:qs;+        int8_t* out = $vec-ptr:(int8_t* r);+        for (i = 0; i < len; ++i) {+            out[i] = in[i] - $(int8_t delta);+        }+    }|]+    VS.unsafeFreeze r++fqEncode :: FastQEncoding -> ShortRead -> B.ByteString+fqEncode enc (ShortRead a b c) = B.concat [a, "\n", b, "\n+\n", bsAdd c offset, "\n"]+    where+        offset :: Int8+        offset = encodingOffset enc+++-- | Decode a FastQ file as a Conduit+--+-- Throws DataError if the stream is not in valid FastQ format+fqDecodeC :: (MonadError NGError m) => FilePath -> FastQEncoding -> C.ConduitT ByteLine ShortRead m ()+fqDecodeC fp enc = C.awaitForever $ \(ByteLine rid) ->+        lineOrError4 $ \rseq ->+            lineOrError4 $ \_ ->+                lineOrError4 $ \rqs->+                    if B.length rseq == B.length rqs+                        then C.yield $! ShortRead rid rseq (vSub rqs offset)+                        else throwDataError ("Parsing file '" ++ fp ++ "': Length of quality line is not the same as sequence")+    where+        offset :: Int8+        offset = encodingOffset enc+        lineOrError4 f = C.await >>=+                            maybe+                                (throwDataError ("Parsing file '" ++ fp ++ "': Number of lines in FastQ file is not multiple of 4! EOF found"))+                                (f . unwrapByteLine)+++-- | Decode a vector of ByteLines into a vector of ShortReads.+fqDecodeVector :: Int -- ^ line number of first line (for error messages)+                -> FastQEncoding+                -> V.Vector ByteLine+                -> NGLess (V.Vector ShortRead)+fqDecodeVector lno enc vs+        | V.length vs `mod` 4 /= 0 = throwDataError $+                                        "Number of input lines in FastQ file is not a multiple of 4 (" ++ (show $ 1 + lno + V.length vs) ++ " lines)"+        | otherwise = runNGLess $! V.generateM (V.length vs `div` 4) parse1+    where+        offset :: Int8+        offset = encodingOffset enc+        parse1 i+                | B.length rseq == B.length rqs = return $ ShortRead rid rseq (vSub rqs offset)+                | otherwise = throwDataError $ "Length of quality line is not the same as sequence (line " ++ show (1 + i*4 + lno) ++ ")"+            where+                rid  = unwrapByteLine $ vs V.! (i*4)+                rseq = unwrapByteLine $ vs V.! (i*4 + 1)+                rqs  = unwrapByteLine $ vs V.! (i*4 + 3)++statsFromFastQ :: (MonadIO m, MonadError NGError m, MonadThrow m, MonadUnliftIO m) => FilePath -> FastQEncoding -> m FQStatistics+statsFromFastQ fp enc = C.runConduitRes $+        conduitPossiblyCompressedFile fp+            .| linesC+            .| fqDecodeC fp enc+            .| fqStatsC++fqStatsC :: forall m. (MonadIO m) => C.ConduitT ShortRead C.Void m FQStatistics+fqStatsC = do+        -- This is pretty ugly code, but threading the state through a foldM+        -- was >2x slower. In any case, all the ugliness is well hidden.+        (charCounts,stats,qualVals) <- liftIO $ do+            charCounts <- VSM.replicate 256 (0 :: Int)+            -- stats is [ Nr-sequences minSequenceSize maxSequenceSize ]+            stats <- VUM.replicate 3 0+            VUM.write stats 1 maxBound+            qualVals <- newIORef =<< VSM.new 0+            return (charCounts, stats, qualVals)+        CL.mapM_ (update charCounts stats qualVals)+        liftIO $ do+            qcs <- readIORef qualVals+            n <- VUM.read stats 0+            minSeq <- VUM.read stats 1+            maxSeq <- VUM.read stats 2+            qcs' <- forM [0 .. maxSeq - 1] $ \i -> do+                v <- VUM.new 256+                let base = i * 256+                forM_ [0 .. 255] $ \j ->+                    VSM.read qcs (base + j) >>= VUM.write v j . fromEnum+                VU.unsafeFreeze v+            let lcT = if n > 0+                            then findMinQValue qcs'+                            else 0+            ccounts <- VS.unsafeFreeze charCounts+            let aCount = getNoCaseV ccounts 'a'+                cCount = getNoCaseV ccounts 'c'+                gCount = getNoCaseV ccounts 'g'+                tCount = getNoCaseV ccounts 't'+                oCount = VS.sum ccounts - aCount - cCount - gCount - tCount+            return $! FQStatistics (aCount, cCount, gCount, tCount, oCount) (fromIntegral lcT) qcs' n (minSeq, maxSeq)+    where++        update :: VSM.IOVector Int -> VUM.IOVector Int -> IORef (VSM.IOVector Int32) -> ShortRead -> m ()+        update !charCounts !stats qcs (ShortRead _ bps qs) = liftIO $ do+            let len = B.length bps+                qlen = 256*len+            prevLen <- VSM.length <$> readIORef qcs+            when (qlen > prevLen) $ do+                pqcs <- readIORef qcs+                nqcs <- VSM.grow pqcs (qlen - prevLen)+                forM_ [prevLen .. qlen - 1] $ \i ->+                    VSM.write nqcs i 0+                writeIORef qcs nqcs+            qcs' <- readIORef qcs+            B.unsafeUseAsCString bps $ \bps' ->+                VSM.unsafeWith charCounts $ \charCounts' ->+                    c_updateCharCount (toEnum len) bps' charCounts'+            liftIO $ [CU.block| void {+                int len = $bs-len:bps;+                int minQ = $(int minQualityValue);+                int8_t* qs = $vec-ptr:(int8_t* qs);+                int32_t* qcs_ = $vec-ptr:(int32_t* qcs');+                int i;+                for (i = 0; i < len; ++i) {+                    int ix = 256*i - minQ + qs[i];+                    ++qcs_[ix];+                }+            }|]+            unsafeIncrement stats 0+            VUM.unsafeModify stats (min len) 1+            VUM.unsafeModify stats (max len) 2+            return ()++        getNoCaseV c p = c VS.! ord p + c VS.! (ord . toUpper $ p)++        findMinQValue :: [VU.Vector Int] -> Int+        findMinQValue = (flip (-) minQualityValue) . minimum . map findMinQValue'+        findMinQValue' :: VU.Vector Int -> Int+        findMinQValue' qs = fromMaybe 256 (VU.findIndex (/= 0) qs)++interleaveFQs :: (MonadError NGError m, MonadResource m, MonadUnliftIO m, MonadThrow m) => ReadSet -> C.ConduitT () B.ByteString m ()+interleaveFQs (ReadSet pairs singletons) = do+            sequence_ [interleavePair f0 f1 | (FastQFilePath _ f0, FastQFilePath _ f1) <- pairs]+            sequence_ [conduitPossiblyCompressedFile f | FastQFilePath _ f <- singletons]+    where+        interleavePair :: (MonadError NGError m, MonadResource m, MonadUnliftIO m, MonadThrow m) => FilePath -> FilePath -> C.ConduitT () B.ByteString m ()+        interleavePair f0 f1 =+                ((conduitPossiblyCompressedFile f0 .| linesC .| CL.chunksOf 4) `zipSources` (conduitPossiblyCompressedFile f1 .| linesC .| CL.chunksOf 4))+                .| C.awaitForever (\(r0,r1) -> C.yield (ul r0) >> C.yield (ul r1))+        zipSources a b = C.getZipSource ((,) <$> C.ZipSource a <*> C.ZipSource b)+        ul = B8.unlines . map unwrapByteLine++gcFraction :: FQStatistics -> Double+gcFraction res = gcCount / allBpCount+    where+        (bpA,bpC,bpG,bpT,_) = bpCounts res+        gcCount = fromIntegral $ bpC + bpG+        allBpCount = fromIntegral $ bpA + bpC + bpG + bpT++nonATCGFrac :: FQStatistics -> Double+nonATCGFrac fq = fromIntegral nO / fromIntegral (nA + nC + nT + nG + nO)+    where+        (nA, nC, nT, nG, nO) = bpCounts fq+++qualityPercentiles :: FQStatistics -> [(Int, Int, Int, Int)]+qualityPercentiles FQStatistics{qualCounts=qCounts} = Prelude.map statistics qCounts+    where+        statistics :: VU.Vector Int -> (Int, Int, Int, Int)+        statistics qs = (bpSum `div` elemTotal + minQualityValue+                                , calcPercentile 0.50 + minQualityValue+                                , calcPercentile 0.25 + minQualityValue+                                , calcPercentile 0.75 + minQualityValue)+            where+                -- Calculates [('a',1), ('b',2)] = 0 + 'a' * 1 + 'b' * 2.+                -- 'a' and 'b' minus encoding.+                bpSum = VU.ifoldl' (\n i q -> n + i * q) 0 qs+                elemTotal = VU.sum qs++                calcPercentile :: Double -> Int+                calcPercentile perc = accUntilLim val'+                    where+                        val' = ceiling (fromIntegral elemTotal * perc)+                        accUntilLim :: Int -> Int+                        accUntilLim lim = case VU.findIndex (>= lim) $ VU.postscanl (+) 0 qs of+                              Just v -> v+                              Nothing -> error "ERROR: Logical impossibility in calcPercentile function"++++
+ NGLess/Data/FastQ/Utils.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+module Data.FastQ.Utils+    ( concatenateFQs+    ) where+++import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as CB+import           Data.Conduit ((.|))+import           Control.Monad (forM_)++import Data.List (isSuffixOf)++import NGLess.NGError (NGLessIO, throwShouldNotOccur)++import FileManagement (makeNGLTempFile)+import Utils.Conduit (linesC)+import Data.FastQ (FastQFilePath(..), fqDecodeC, fqEncodeC)+import Data.Conduit.Algorithms.Async (asyncGzipTo, conduitPossiblyCompressedFile)++concatenateFQs :: [FastQFilePath] -> NGLessIO FastQFilePath+concatenateFQs [] = throwShouldNotOccur "Empty argument to concatenateFQs"+concatenateFQs [f] = return f+concatenateFQs (FastQFilePath enc fp:rest) = do+    fres <- makeNGLTempFile fp "concatenate" "fq.gz" $ \hout -> do+        let catTo f enc'+                | enc /= enc' =+                    conduitPossiblyCompressedFile f+                        .| linesC+                        .| fqDecodeC f enc'+                        .| fqEncodeC enc+                        .| asyncGzipTo hout+                | ".gz" `isSuffixOf` f = CB.sourceFile f .| CB.sinkHandle hout+                | otherwise = conduitPossiblyCompressedFile f .| asyncGzipTo hout+        C.runConduitRes $ catTo fp enc+        forM_ rest $ \(FastQFilePath enc' f') ->+            C.runConduitRes (catTo f' enc')+    return $ FastQFilePath enc fres++
+ NGLess/Data/Fasta.hs view
@@ -0,0 +1,64 @@+{- Copyright 2017-2018 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts #-}+module Data.Fasta+    ( FastaSeq(..)+    , faseqLength+    , faConduit+    , faWriteC+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import           Data.Word+import           Control.Monad.Except+import           Control.DeepSeq++import NGLess.NGError+import Utils.Conduit++data FastaSeq = FastaSeq+                { seqheader :: !B.ByteString+                , seqdata :: !B.ByteString+                } deriving (Eq, Show)++instance NFData FastaSeq where+    rnf !_ = ()++faseqLength :: FastaSeq -> Int+faseqLength = B.length . seqdata+{-# INLINE faseqLength #-}++greaterThanSign :: Word8+greaterThanSign = 62++faConduit :: (MonadIO m, MonadError NGError m) => C.ConduitT B.ByteString FastaSeq m ()+faConduit = linesC .| faConduit'++faConduit' :: (MonadIO m, MonadError NGError m) => C.ConduitT ByteLine FastaSeq m ()+faConduit' = C.await >>= \case+                Nothing -> return ()+                Just (ByteLine header)+                  | B.null header -> throwDataError "Unexpected empty string at line 1"+                  | B.head header == greaterThanSign -> getdata (1 :: Int) (B.drop 1 header) []+                  | otherwise -> throwDataError ("Unexpected data (expected > sign, got: " ++ B8.unpack (B.take 80 header) ++ ")")+  where+    getdata !n header toks = C.await >>= \case+                                Nothing -> C.yield $ FastaSeq header (B.concat $ reverse toks)+                                Just (ByteLine next)+                                    | B.null next -> throwDataError ("Unexpected empty string at line " ++ show (n+1) ++ " (expected header line).")+                                    | B.head next == greaterThanSign -> do+                                            C.yield $ FastaSeq header (B.concat $ reverse toks)+                                            getdata (n+1) (B.drop 1 next) []+                                    | otherwise -> getdata (n+1) header (next:toks)++faWriteC :: (Monad m) => C.ConduitT FastaSeq B.ByteString m ()+faWriteC = C.awaitForever $ \(FastaSeq h s) -> do+    C.yield ">"+    C.yield h+    C.yield "\n"+    C.yield s+    C.yield "\n"
+ NGLess/Data/GFF.hs view
@@ -0,0 +1,119 @@+{- Copyright 2013-2019 NGLess Authors+ - License: MIT -}+{-# LANGUAGE CPP #-}++module Data.GFF+    ( GffLine(..)+    , GffStrand(..)+    , readGffLine+#if IS_BUILDING_TEST+    , _parseGffAttributes+    , _trimString+#endif+    ) where++import Control.Monad+import Control.DeepSeq+import           Control.Arrow (second)++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lex.Integral as I+import qualified Data.ByteString.Lex.Fractional as F++import NGLess.NGError++data GffStrand = GffPosStrand | GffNegStrand | GffUnknownStrand | GffUnStranded+            deriving (Eq, Show, Enum)++instance NFData GffStrand where+    rnf !_ = ()++data GffLine = GffLine+            { gffSeqId :: !B.ByteString+            , gffSource :: !B.ByteString+            , gffType :: !B.ByteString+            , gffStart :: !Int+            , gffEnd :: !Int+            , gffScore :: !(Maybe Float)+            , gffStrand :: !GffStrand+            , gffPhase :: {-# UNPACK #-} !Int -- ^phase: use -1 to denote .+            , gffAttrs :: ![(B.ByteString, B.ByteString)]+            } deriving (Eq,Show)++instance NFData GffLine where+    -- All but the score and attrs are bang annotated+    rnf GffLine{ gffScore = sc, gffAttrs = attrs } = rnf sc `seq` rnf attrs++_parseGffAttributes :: B.ByteString -> [(B.ByteString, B.ByteString)]+_parseGffAttributes = foldMap (\(a, b) -> zip (repeat a) (B8.split ',' b))+                        . map (second (B8.filter (/='\"') . B.tail))+                        . map (\x -> B8.break (== (checkAttrTag x)) x)+                        . map _trimString+                        . B8.split ';'+                        . removeLastDel+                        . _trimString++    where+        removeLastDel :: B8.ByteString -> B8.ByteString+        removeLastDel s+            | B.null s = s+            | otherwise = case B8.last s of+                ';' -> B8.init s+                _   -> s++--Check if the atribution tag is '=' or ' '+checkAttrTag :: B.ByteString -> Char+checkAttrTag s = case B8.elemIndex '=' s of+    Nothing -> ' '+    _       -> '='++-- remove ' ' from begining and end.+_trimString :: B.ByteString -> B.ByteString+_trimString = trimBeg . trimEnd+    where+        trimBeg = B8.dropWhile isSpace+        trimEnd = fst . B8.spanEnd isSpace+        isSpace = (== ' ')+++readGffLine :: B.ByteString -> Either NGError GffLine+readGffLine line = case B8.split '\t' line of+        [tk0,tk1,tk2,tk3,tk4,tk5,tk6,tk7,tk8] ->+            GffLine+                tk0+                tk1+                tk2+                <$> intOrError tk3+                <*> intOrError tk4+                <*> score tk5+                <*> strandOrError tk6+                <*> phase tk7+                <*> pure (_parseGffAttributes tk8)+        _ -> throwDataError ("unexpected line in GFF: " ++ show line)+    where+        parseOrError :: (a -> Maybe b) -> a -> NGLess b+        parseOrError p s = case p s of+                    Just v -> return v+                    Nothing -> throwDataError $ "Could not parse GFF line: "++ show line+        intOrError :: B.ByteString -> NGLess Int+        intOrError = parseOrError (liftM fst . I.readDecimal)+        floatOrError = parseOrError (liftM fst . F.readDecimal)+        score :: B.ByteString -> NGLess (Maybe Float)+        score "." = return Nothing+        score v = Just <$> floatOrError v++        phase :: B.ByteString -> NGLess Int+        phase "." = return (-1)+        phase r = intOrError r+        strandOrError :: B.ByteString -> NGLess GffStrand+        strandOrError s = case B8.uncons s of+            Just (s',_) -> parseStrand s'+            _ -> throwDataError "Could not parse GFF line (empty strand field)"++parseStrand :: Char -> NGLess GffStrand+parseStrand '.' = return GffUnStranded+parseStrand '+' = return GffPosStrand+parseStrand '-' = return GffNegStrand+parseStrand '?' = return GffUnknownStrand+parseStrand u = throwDataError $ "Parsing GFF line: unhandled value for strand ("++[u]++")"
+ NGLess/Data/Sam.hs view
@@ -0,0 +1,325 @@+{- Copyright 2014-2019 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+module Data.Sam+    ( SamLine(..)+    , SamGroup+    , samLength+    , readSamGroupsC'+    , readSamLine+    , encodeSamLine+    , isAligned+    , isPositive+    , isNegative+    , isFirstInPair+    , isSecondInPair+    , isSamHeaderString+    , hasSequence+    , matchSize+    , matchSize'+    , matchIdentity++    , samStatsC+    , samStatsC'+    , samIntTag+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as B8+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Lift as C+import qualified Data.Conduit as C+import           Data.Conduit.Algorithms.Async as CAlg+import           Data.Conduit.Algorithms.Utils (awaitJust)+import qualified Data.Conduit.Combinators as CC+import           Data.Conduit ((.|))+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import           Data.Strict.Tuple (Pair(..))+import Data.Bits (testBit)+import Data.List (intersperse)+import Control.Error (note)+import Control.DeepSeq++import Data.Maybe+import Control.Monad.Except+import NGLess.NGError+import Utils.Utils+import Utils.Conduit (ByteLine(..))+++type SamGroup = [SamLine]++data SamLine = SamLine+            { samQName :: !B.ByteString+            , samFlag :: {-# UNPACK #-} !Int+            , samRName :: {-# UNPACK #-} !B.ByteString+            , samPos :: {-# UNPACK #-} !Int+            , samMapq :: {-# UNPACK #-} !Int+            , samCigar :: {-# UNPACK #-} !B.ByteString+            , samRNext :: {-# UNPACK #-} !B.ByteString+            , samPNext :: {-# UNPACK #-} !Int+            , samTLen :: {-# UNPACK #-} !Int+            , samSeq :: {-# UNPACK #-} !B.ByteString+            , samQual :: {-# UNPACK #-} !B.ByteString+            , samExtra :: {-# UNPACK #-} !B.ByteString+            } | SamHeader !B.ByteString+             deriving (Eq, Show, Ord)+++instance NFData SamLine where+    rnf SamLine{} = ()+    rnf (SamHeader !_) = ()++isHeader SamHeader{} = True+isHeader SamLine{} = False+{-# INLINE isHeader #-}++samLength :: SamLine -> Int+samLength = B8.length . samSeq+{-# INLINE samLength #-}++-- log 2 of N+-- 4 -> 2+isAligned :: SamLine -> Bool+isAligned = not . (`testBit` 2) . samFlag+{-# INLINE isAligned #-}++-- 16 -> 4+isNegative :: SamLine -> Bool+isNegative = (`testBit` 4) . samFlag+{-# INLINE isNegative #-}++-- all others+isPositive :: SamLine -> Bool+isPositive = not . isNegative+{-# INLINE isPositive #-}++isFirstInPair :: SamLine -> Bool+isFirstInPair = (`testBit` 6) . samFlag+{-# INLINE isFirstInPair #-}++isSecondInPair :: SamLine -> Bool+isSecondInPair = (`testBit` 7) . samFlag+{-# INLINE isSecondInPair #-}++isSamHeaderString :: B.ByteString -> Bool+isSamHeaderString s = not (B.null s) && (B.head s == 64) -- 64 is '@'+{-# INLINE isSamHeaderString #-}++hasSequence :: SamLine -> Bool+hasSequence SamHeader{} = False+hasSequence SamLine{samSeq=s} = s /= "*"+{-# INLINE hasSequence #-}++newtype SimpleParser a = SimpleParser { runSimpleParser :: B.ByteString -> Maybe (Pair a B.ByteString) }+instance Functor SimpleParser where+    fmap f p = SimpleParser $ \b -> do+                                (v :!: rest) <- runSimpleParser p b+                                return $! (f v :!: rest)++instance Applicative SimpleParser where+    pure v = SimpleParser (\b -> Just (v :!: b))+    f <*> g = SimpleParser (\b -> do+                                (f' :!: rest) <- runSimpleParser f b+                                (g' :!: rest') <- runSimpleParser g rest+                                return $! (f' g' :!: rest'))++encodeSamLine :: SamLine -> BB.Builder+encodeSamLine (SamHeader b) = BB.byteString b+encodeSamLine samline = mconcat . intersperse (BB.char7 '\t') $ map ($ samline)+    [ BB.byteString . samQName+    , BB.intDec     . samFlag+    , BB.byteString . samRName+    , BB.intDec     . samPos+    , BB.intDec     . samMapq+    , BB.byteString . samCigar+    , BB.byteString . samRNext+    , BB.intDec .     samPNext+    , BB.intDec     . samTLen+    , BB.byteString . samSeq+    , BB.byteString . samQual+    , BB.byteString . samExtra+    ]++readSamLine :: B.ByteString -> Either NGError SamLine+readSamLine line+    | B.null line = throwDataError "Unexpected empty line"+    | B8.head line == '@' = return (SamHeader line)+    | otherwise = case runSimpleParser samP line of+        Just (v :!: _) -> return v+        Nothing -> throwDataError ("Could not parse sam line "++show line)++tabDelim :: SimpleParser B.ByteString+tabDelim = SimpleParser $ \input -> do+    ix <- B8.elemIndex '\t' input+    return $! (B.take ix input :!: B.drop (ix+1) input)++tabDelimOpts :: SimpleParser B.ByteString+tabDelimOpts = SimpleParser $ \input ->+    case B8.elemIndex '\t' input of+         Just ix -> return $! (B.take ix input :!: B.drop (ix+1) input)+         Nothing -> return $! (B.empty :!: input)++readIntTab = SimpleParser $ \b -> do+        (v,rest) <- B8.readInt b+        return $! (v :!: B.tail rest)+restParser = SimpleParser $ \b -> Just (b :!: B.empty)+samP = SamLine+    <$> tabDelim+    <*> readIntTab+    <*> tabDelim+    <*> readIntTab+    <*> readIntTab+    <*> tabDelim+    <*> tabDelim+    <*> readIntTab+    <*> readIntTab+    <*> tabDelim+    <*> tabDelimOpts+    <*> restParser++{--+Op     Description+M alignment match (can be a sequence match or mismatch).+I insertion to the reference+D deletion from the reference.+N skipped region from the reference.+S soft clipping (clipped sequences present inSEQ)+H hard clipping (clipped sequences NOT present inSEQ)+P padding (silent deletion from padded reference).+= sequence match.+X sequence mismatch.+--}++matchSize :: Bool -> SamLine -> Either NGError Int+matchSize includeI = matchSize' includeI False . samCigar++matchSize' includeI includeSoft cigar+    | B8.null cigar = return 0+    | otherwise = case B8.readInt cigar of+        Nothing -> throwDataError ("could not parse cigar '"++B8.unpack cigar ++"'")+        Just (n,code_rest) -> do+            let code = B8.head code_rest+                rest = B8.tail code_rest+                n' = case code of+                            'M' -> n+                            '=' -> n+                            'X' -> n+                            'S'+                                | includeSoft -> n+                            'I'+                                | includeI -> n+                            _ -> 0+            r <- matchSize' includeI includeSoft rest+            return (n' + r)++matchIdentity :: Bool -> SamLine -> Either NGError Double+matchIdentity useNewer samline = do+    let errmsg = "Could not get NM tag for samline " ++ B8.unpack (samQName samline) ++ ", extra tags were: "++ B8.unpack (samExtra samline)+    errors <- note (NGError DataError errmsg) $ samIntTag samline "NM"+    len <- matchSize useNewer samline+    let toDouble = fromInteger . toInteger+        mid = toDouble (len - errors) / toDouble len+    return mid++samIntTag :: SamLine -> B.ByteString -> Maybe Int+samIntTag samline tname+    | isHeader samline = Nothing+    | otherwise = listToMaybe . mapMaybe gettag . B8.split '\t' . samExtra $ samline+    where+        gettag match+            | B.take 2 match == tname+                    && (fst <$> B8.uncons (B.drop 3 match)) == Just 'i' = fst <$> B8.readInt (B.drop 5 match)+            | otherwise = Nothing++-- | take in *ByteLines* and transform them into groups of SamLines all+-- refering to the same read+--+-- This works in chunks (vectors) for efficiency+--+-- Header lines are silently ignored+--+-- When respectPairs is False, then the two mates of the same fragment will be+-- considered grouped in different blocks+readSamGroupsC' :: forall m . (MonadError NGError m, MonadIO m) =>+            Int -- ^ number of threads+            -> Bool -- respectPairs+            -> C.ConduitT (V.Vector ByteLine) (V.Vector [SamLine]) m ()+readSamGroupsC' mapthreads respectPairs = do+        CC.dropWhileE (isSamHeaderString . unwrapByteLine)+        CC.filter (not . V.null)+            .| asyncMapEitherC mapthreads (fmap groupByName . V.mapM (readSamLineCheck . unwrapByteLine))+            -- the groups may not be aligned on the group boundary, thus we need to fix them+            .| fixSamGroups+    where+        samQNameMate :: SamLine -> (B.ByteString, Bool)+        samQNameMate s+            | respectPairs = (samQName s, True)+            | otherwise = (samQName s, isFirstInPair s)+        readSamLineCheck sm+            | isSamHeaderString sm = throwDataError "SAM header appears after SAM data (malformed file?)"+            | otherwise = readSamLine sm+        groupByName :: V.Vector SamLine -> V.Vector [SamLine]+        groupByName vs = V.unfoldr groupByName' (0, error "null value", [])+            where+                groupByName' :: (Int, (B.ByteString, Bool), [SamLine]) -> Maybe ([SamLine], (Int, (B.ByteString, Bool), [SamLine]))+                groupByName' (ix, name, acc)+                        | ix == V.length vs = if null acc+                                                then Nothing+                                                else Just (reverse acc, (ix, error "null value", []))+                        | null acc = groupByName' (ix + 1, cur_tag, [cur])+                        | cur_tag == name = groupByName' (ix + 1, name, cur:acc)+                        | otherwise = Just (reverse acc, (ix, error "null value", []))+                    where+                        cur = vs V.! ix+                        cur_tag = samQNameMate cur+        fixSamGroups :: C.ConduitT (V.Vector [SamLine]) (V.Vector [SamLine]) m ()+        fixSamGroups = awaitJust fixSamGroups'+        fixSamGroups' :: V.Vector [SamLine] -> C.ConduitT (V.Vector [SamLine]) (V.Vector [SamLine]) m ()+        fixSamGroups' prev = C.await >>= \case+            Nothing -> C.yield prev+            Just cur -> case (V.last prev, V.head cur) of+                    (lastprev:_, curfirst:_)+                        | samQNameMate lastprev /= samQNameMate curfirst -> do+                            -- lucky case, the groups align with the vector boundary+                            C.yield prev+                            fixSamGroups' cur+                        | otherwise -> do+                            C.yield (V.slice 0 (V.length prev - 1) prev)+                            cur' <- liftIO $ injectLast (V.last prev) cur+                            fixSamGroups' cur'+                    _ -> throwShouldNotOccur "This should have been an impossible situation in `fixSamGroups`"+        injectLast :: [SamLine] -> V.Vector [SamLine] -> IO (V.Vector [SamLine])+        injectLast prev gs = do+            gs' <- V.unsafeThaw gs+            VM.modify gs' (prev ++ ) 0+            V.unsafeFreeze gs'++samStatsC :: (MonadIO m) => C.ConduitT (V.Vector ByteLine) C.Void m (NGLess (Int, Int, Int))+samStatsC = C.runExceptC $ readSamGroupsC' 1 True .| samStatsC'++samStatsC' :: forall m. (MonadError NGError m) => C.ConduitT (V.Vector SamGroup) C.Void m (Int, Int, Int)+samStatsC' = CL.foldM summarizeV (0, 0, 0)+    where+        add1if !v True = v+1+        add1if !v False = v++        summarizeV :: (Int, Int, Int) -> V.Vector SamGroup -> m (Int, Int, Int)+        summarizeV c vs = V.foldM summarize c vs++        summarize :: (Int, Int, Int) -> SamGroup -> m (Int, Int, Int)+        summarize c [] = return c+        summarize c (samline:_)+            | isHeader samline = return c+        summarize (!t, !al, !u) g = let+                    aligned = any isAligned g+                    sameRName = allSame (samRName <$> g)+                    unique = aligned && sameRName+            in return+                (t + 1+                ,add1if al aligned+                ,add1if  u unique+                )
+ NGLess/Dependencies/Embedded.hs view
@@ -0,0 +1,53 @@+{- Copyright 2015-2022 NGLess Authors+ - License: MIT+ -}+module Dependencies.Embedded+    ( samtoolsData+    , bwaData+    , prodigalData+    , megahitData+    , minimap2Data+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B++import Foreign.C.Types+import Foreign.C.String+import Data.Convertible++foreign import ccall safe "get_samtools_len" c_get_samtools_len :: CUInt+foreign import ccall safe "get_samtools_data" c_get_samtools_data :: CString++foreign import ccall safe "get_bwa_len" c_get_bwa_len :: CUInt+foreign import ccall safe "get_bwa_data" c_get_bwa_data :: CString++foreign import ccall safe "get_prodigal_len" c_get_prodigal_len :: CUInt+foreign import ccall safe "get_prodigal_data" c_get_prodigal_data :: CString++foreign import ccall safe "get_megahit_len" c_get_megahit_len :: CUInt+foreign import ccall safe "get_megahit_data" c_get_megahit_data :: CString++foreign import ccall safe "get_minimap2_len" c_get_minimap2_len :: CUInt+foreign import ccall safe "get_minimap2_data" c_get_minimap2_data :: CString++samtoolsData :: IO B.ByteString+samtoolsData =+    B.unsafePackCStringLen (c_get_samtools_data, convert c_get_samtools_len)++prodigalData :: IO B.ByteString+prodigalData =+    B.unsafePackCStringLen (c_get_prodigal_data, convert c_get_prodigal_len)++bwaData :: IO B.ByteString+bwaData =+    B.unsafePackCStringLen (c_get_bwa_data, convert c_get_bwa_len)++megahitData :: IO B.ByteString+megahitData =+    B.unsafePackCStringLen (c_get_megahit_data, convert c_get_megahit_len)++minimap2Data :: IO B.ByteString+minimap2Data =+    B.unsafePackCStringLen (c_get_minimap2_data, convert c_get_minimap2_len)+
+ NGLess/Dependencies/Versions.hs view
@@ -0,0 +1,24 @@+module Dependencies.Versions+    ( bwaVersion+    , samtoolsVersion+    , prodigalVersion+    , megahitVersion+    , minimap2Version+    ) where++{- It would be better to auto-generate this file -}++bwaVersion :: String+bwaVersion = "0.7.17"++samtoolsVersion :: String+samtoolsVersion = "1.13"++prodigalVersion :: String+prodigalVersion = "2.6.3"++megahitVersion :: String+megahitVersion = "1.2.9"++minimap2Version :: String+minimap2Version = "2.24"
+ NGLess/Dependencies/embedded.c view
@@ -0,0 +1,41 @@+#ifdef BUILD_W_EMBED+#include "samtools_data.c"+#include "prodigal_data.c"+#include "bwa_data.c"+#include "megahit_data.c"+#include "minimap2_data.c"++const unsigned char* get_samtools_data () { return ngless_samtools_static; }+unsigned int get_samtools_len () { return ngless_samtools_static_len; }++const unsigned char* get_prodigal_data () { return ngless_prodigal_static; }+unsigned int get_prodigal_len () { return ngless_prodigal_static_len; }++const unsigned char* get_bwa_data () { return ngless_bwa_static; }+unsigned int get_bwa_len () { return ngless_bwa_static_len; }++const unsigned char* get_megahit_data() { return megahit_packaged_tar_gz; }+unsigned int get_megahit_len() { return megahit_packaged_tar_gz_len; }++const unsigned char* get_minimap2_data() { return ngless_minimap2_static; }+unsigned int get_minimap2_len() { return ngless_minimap2_static_len; }++#else++const unsigned char* get_samtools_data () { return ""; }+unsigned int get_samtools_len () { return 0; }++const unsigned char* get_prodigal_data () { return ""; }+unsigned int get_prodigal_len () { return 0; }++const unsigned char* get_bwa_data () { return ""; }+unsigned int get_bwa_len () { return 0; }++const unsigned char* get_megahit_data() { return ""; }+unsigned int get_megahit_len() { return 0; }++const unsigned char* get_minimap2_data() { return ""; }+unsigned int get_minimap2_len() { return 0; }++#endif+
+ NGLess/ExternalModules.hs view
@@ -0,0 +1,573 @@+{- Copyright 2015-2021 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE RecordWildCards, FlexibleContexts, MultiWayIf #-}++module ExternalModules+    ( loadModule+    ) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.List.Utils as LU+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Async (withPossiblyCompressedFile)+import           Control.Monad.Extra (whenJust)+import           GHC.Conc (getNumCapabilities)+import           Data.Yaml ((.!=), (.:?), (.:))+import qualified Data.Aeson as Aeson+import qualified Data.Yaml as Yaml++import Control.Applicative+import Control.Monad+import System.Process+import System.Environment (getEnvironment, getExecutablePath)+import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist)+import System.Exit (ExitCode(..))+import System.IO+import System.FilePath+import Data.Maybe+import Data.List (find, isSuffixOf)+import Data.Default (def)++import Data.FastQ.Utils (concatenateFQs)+import Data.FastQ+import NGLess.NGLEnvironment+import FileManagement (makeNGLTempFile, inferCompression, Compression(..), expandPath, openNGLTempFile)+import Utils.Samtools+import Configuration+import FileOrStream+import Utils.Suggestion+import Utils.Utils+import Utils.Network (downloadExpandTar, isUrl)+import Language+import Modules+import Output+import NGLess+++-- | Basic file types+data FileTypeBase =+    FastqFileSingle+    | FastqFilePair+    | FastqFileTriplet+    | SamFile+    | BamFile+    | SamOrBamFile+    | TSVFile+    deriving (Eq,Show)++instance Aeson.FromJSON FileTypeBase where+    parseJSON = Aeson.withText "filetypebase" $ \case+        "fq1" -> return FastqFileSingle+        "fq2" -> return FastqFilePair+        "fq3" -> return FastqFileTriplet+        "sam" -> return SamFile+        "bam" -> return BamFile+        "sam_or_bam" -> return SamOrBamFile+        "tsv" -> return TSVFile+        ft -> fail ("unknown file type '"++T.unpack ft++"'")++data FileType = FileType+    { _fileTypeBase :: !FileTypeBase+    , _canGzip :: !Bool+    , _canBzip2 :: !Bool+    , _canStream :: !Bool+    } deriving (Eq, Show)++instance Aeson.FromJSON FileType where+    parseJSON = Aeson.withObject "filetype" $ \o ->+        FileType+            <$> o .: "filetype"+            <*> o .:? "can_gzip" .!= False+            <*> o .:? "can_bzip2" .!= False+            <*> o .:? "can_stream" .!= False++data CommandExtra = FlagInfo [T.Text]+            | FileInfo FileType+            | ExpandSearchPath Bool+            deriving (Eq, Show)++data CommandArgument = CommandArgument+        { cargInfo :: ArgInformation+        , cargDef :: Maybe NGLessObject -- ^ default value+        , cargPayload :: Maybe CommandExtra+        }+    deriving (Eq, Show)++instance Aeson.FromJSON CommandArgument where+    parseJSON = Aeson.withObject "command argument" $ \o -> do+        argName <- o .:? "name" .!= ""+        argRequired <- o .:? "required" .!= False+        atype <- o .: "atype"+        (argType, cargDef) <- case atype of+            "flag" -> do+                defVal <- o .:? "def"+                return (NGLBool, NGOBool <$> defVal)+            "option" -> do+                defVal <- o .:? "def"+                return (NGLSymbol, NGOSymbol <$> defVal)+            "int" -> do+                defVal <- o .:? "def"+                return (NGLInteger, NGOInteger <$> defVal)+            "str" -> do+                defVal <- o .:? "def"+                return (NGLString, NGOString <$> defVal)+            "readset" -> return (NGLReadSet, Nothing)+            "counts" -> return (NGLCounts, Nothing)+            "mappedreadset" -> return (NGLMappedReadSet, Nothing)+            _ -> fail ("unknown argument type "++atype)+        argChecks <- if atype == "option"+                then do+                    allowed <- o .: "allowed"+                    return [ArgCheckSymbol allowed]+                else return []+        let cargInfo = ArgInformation{..}+        aexpand <- o .:? "expand_searchpath" .!= False+        cargPayload <-+            if+                | atype `elem` ["option", "flag"] -> fmap FlagInfo <$> ((Just . (:[]) <$> o .: "when-true") <|> o .:? "when-true")+                | atype `elem` ["readset", "counts", "mappedreadset"] -> (Just . FileInfo <$> Aeson.parseJSON (Aeson.Object o)) <|> return Nothing+                | atype == "str" -> return $ Just (ExpandSearchPath aexpand)+                | otherwise -> return Nothing+        return CommandArgument{..}++newtype ReadNGLType = ReadNGLType { unwrapReadNGLType :: NGLType }++instance Aeson.FromJSON ReadNGLType where+    parseJSON = Aeson.withText "ngltype" $ \rtype ->+        ReadNGLType <$> case rtype of+            "void" -> return NGLVoid+            "counts" -> return NGLCounts+            "readset" -> return NGLReadSet+            "mappedreadset" -> return NGLMappedReadSet+            other -> fail ("Cannot parse unknown type '"++T.unpack other++"'")++data CommandReturn = CommandReturn+                        { commandReturnType :: !NGLType+                        , _commandReturnName :: !T.Text+                        , _commandReturnExt :: FilePath+                        }+    deriving (Eq, Show)++instance Aeson.FromJSON CommandReturn where+    parseJSON = Aeson.withObject "hidden argument" $ \o -> do+        t <- unwrapReadNGLType <$> o .: "rtype"+        if t == NGLVoid+            then return $! CommandReturn NGLVoid "" ""+            else CommandReturn t <$> o .: "name" <*> o .: "extension"++data Command = Command+    { nglName :: T.Text         -- ^ what function is called inside ngless+    , arg0 :: FilePath          -- ^ what the script is+    , arg1 :: CommandArgument   -- ^ all ngless functions take an argument+    , additional :: [CommandArgument]+    , ret :: CommandReturn+    } deriving (Eq, Show)++instance Aeson.FromJSON Command where+    parseJSON = Aeson.withObject "function" $ \o ->+        Command+            <$> o .: "nglName"+            <*> o .: "arg0"+            <*> o .: "arg1"+            <*> o .:? "additional" .!= []+            <*> o .:? "return" .!=  CommandReturn NGLVoid "" ""++data ModuleNGLessMinVersion = ModuleNGLessMinVersion+                        { nglessMinVersion :: NGLVersion+                        , nglessMinVersionReason :: T.Text+                        }+    deriving (Eq, Show)++instance Aeson.FromJSON ModuleNGLessMinVersion where+    parseJSON = Aeson.withObject "min-ngless-version" $ \o -> do+            vtText <- o .: "min-version"+            reason <- o .: "reason"+            vt <- (Aeson.withText "minimal NGLess version" $ \vt ->+                        case parseVersion (Just vt) of+                            Left err -> fail (show err)+                            Right val -> return val) vtText+            return $ ModuleNGLessMinVersion vt reason+++data ExternalModule = ExternalModule+    { emInfo :: ModInfo -- ^ module information+    , modulePath :: FilePath -- ^ directory where module files are located+    , modNGLessMinVersion :: Maybe ModuleNGLessMinVersion -- ^ minimal NGLess version for this module+    , initCmd :: Maybe FilePath+    , initArgs :: [String]+    , emFunctions :: [Command]+    , references :: [ExternalReference]+    , emCitations :: [T.Text]+    } deriving (Eq, Show)++instance Aeson.FromJSON ExternalModule where+    parseJSON = Aeson.withObject "module" $ \o -> do+        initO <- o .:? "init"+        (initCmd, initArgs) <- case initO of+            Nothing -> return (Nothing, [])+            Just initO' -> do+                init_cmd <- initO' .: "init_cmd"+                init_args <- initO' .:? "init_args" .!= []+                return (init_cmd, init_args)+        modNGLessMinVersion <- o .:? "min-ngless-version"+        references <- o .:? "references" .!= []+        emFunctions <- o .:? "functions" .!= []+        singleCitation <- o .:? "citation"+        citations <- o .:? "citations" .!= []+        let emCitations = maybeToList singleCitation ++ citations+        emInfo <- ModInfo <$> o .: "name" <*> o .: "version"+        let modulePath = undefined+        return ExternalModule{..}++addPathToRep :: FilePath -> ExternalModule -> ExternalModule+addPathToRep mpath m = m { modulePath = mpath, references = map (addPathToRef mpath) (references m) }++addPathToRef :: FilePath -> ExternalReference -> ExternalReference+addPathToRef mpath er@ExternalReference{..} = er+        { faFile = ma faFile+        , gtfFile = ma <$> gtfFile+        , geneMapFile = ma <$> geneMapFile+        }+    where+        ma p+            | isAbsolute p = p+            | isUrl p = p+            | otherwise = mpath </> p+addPathToRef _ er = er+++asFunction Command{..} = Function (FuncName nglName) (Just . argType . cargInfo $ arg1) [] (commandReturnType ret) (map cargInfo additional) False []++{- | Environment to expose to module processes -}+nglessEnv :: FilePath -> NGLessIO [(String,String)]+nglessEnv basedir = do+    tmpdir <- nConfTemporaryDirectory <$> nglConfiguration+    liftIO $ do+        env <- getEnvironment+        let env' = filter ((`notElem` ["TMP", "TMPDIR", "TEMP", "TEMPDIR"]) . fst) env+        ncpu <- getNumCapabilities+        nglessPath <- getExecutablePath+        return $ ("NGLESS_NGLESS_BIN", nglessPath)+                :("NGLESS_MODULE_DIR", basedir)+                :("NGLESS_NR_CORES", show ncpu)+                :("TMPDIR", tmpdir) -- TMPDIR is the POSIX standard+                :("TMP", tmpdir) -- TMP is also used on Windows+                :("TEMPDIR", tmpdir) -- Some software uses TEMP/TEMPDIR+                :("TEMP", tmpdir)+                :env'++executeCommand :: FilePath -> [Command] -> T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeCommand basedir cmds funcname input args = do+    cmd <- maybe+                (throwShouldNotOccur ("Call to undefined function "++T.unpack funcname++"."))+                return+                (find ((== funcname) . nglName) cmds)+    paths <- encodeArgument (arg1 cmd) (Just input)+    args' <- argsArguments cmd args+    moarg <- case ret cmd of+        CommandReturn NGLVoid _ _ -> return Nothing+        CommandReturn _ name ext -> do+            (newfp, hout) <- openNGLTempFile "external" "eout_" ext+            liftIO $ hClose hout+            let oarg = "--"++T.unpack name++"="++newfp+            return $ Just (newfp, [oarg])+    env <- nglessEnv basedir+    let cmdline = paths ++ args' ++ maybe [] snd moarg+        process = (proc (basedir </> arg0 cmd) cmdline) { env = Just env }+    outputListLno' TraceOutput ["executing command: ", arg0 cmd, " ", LU.join " " cmdline]+    (exitCode, out, err) <- liftIO $+        readCreateProcessWithExitCode process ""+    outputListLno' TraceOutput ["Processing results: (STDOUT=", out, ", STDERR=", err,") with exitCode: ", show exitCode]+    case (exitCode,out,err) of+        (ExitSuccess, "", "") -> return ()+        (ExitSuccess, msg, "") -> outputListLno' TraceOutput ["Module OK. information: ", msg]+        (ExitSuccess, mout, merr) -> outputListLno' TraceOutput ["Module OK. information: ", mout, ". Warning: ", merr]+        (ExitFailure code, _,_) ->+            throwSystemError .concat $ ["Error running command for function ", show funcname, "\n",+                "\texit code = ", show code,"\n",+                "\tstdout='", out, "'\n",+                "\tstderr='", err, "'"]+    let groupName (NGOMappedReadSet g _ _) = g+        groupName (NGOReadSet g _) = g+        groupName _ = ""+    case moarg of+        Nothing -> return NGOVoid+        Just (newfp, _) -> case commandReturnType $ ret cmd of+            NGLCounts -> return $ NGOCounts (File newfp)+            NGLMappedReadSet -> return $ NGOMappedReadSet (groupName input) (File newfp) Nothing+            ret -> throwShouldNotOccur ("Not implemented (ExternalModules.hs:executeCommand commandReturnType = "++show ret++")")++adjustCompression :: Maybe CommandExtra -> FilePath -> NGLessIO FilePath+adjustCompression (Just (FileInfo (FileType _ gz bz2 _))) f =+    -- This could be a call to ensureCompressionIsOneOf+    case inferCompression f of+        NoCompression -> return f+        GzipCompression+            | gz -> return f+        BZ2Compression+            | bz2 -> return f+        _ -> uncompressFile f+adjustCompression _ f = return f++asFilePaths :: NGLessObject -> Maybe CommandExtra -> NGLessIO  [FilePath]+asFilePaths (NGOReadSet _ (ReadSet paired singles)) argOptions = do+    let concatenateFQs' [] = return Nothing+        concatenateFQs' rs = Just <$> concatenateFQs rs+    fq1 <- concatenateFQs' (fst <$> paired)+    fq2 <- concatenateFQs' (snd <$> paired)+    fq3 <- concatenateFQs' singles+    fqs <- case (fq1, fq2, fq3) of+        (Nothing, Nothing, Just f)  -> return [fqpathFilePath f]+        (Just f1, Just f2, Nothing) -> return [fqpathFilePath f1, fqpathFilePath f2]+        (Just f1, Just f2, Just f3) -> return [fqpathFilePath f1, fqpathFilePath f2, fqpathFilePath f3]+        _ -> throwScriptError "Malformed input argument to asFilePaths"+    mapM (adjustCompression argOptions) fqs+asFilePaths input@(NGOCounts _) argOptions = (:[]) <$> asCountsFile input argOptions+asFilePaths (NGOMappedReadSet _ input _) payload = (:[]) <$> do+    filepath <- asFile input+    case payload of+        Nothing -> return filepath+        Just (FileInfo (FileType fb _ _ _)) -> case fb of+            SamFile -> asSamFile filepath payload+            BamFile -> asBamFile filepath+            SamOrBamFile -> adjustCompression payload filepath+            _ -> throwScriptError "Unexpected combination of arguments"+        Just other -> throwShouldNotOccur ("encodeArgument: unexpected payload: "++show other)+asFilePaths invalid _ = throwShouldNotOccur ("AsFile path got "++show invalid)++asCountsFile :: NGLessObject -> Maybe CommandExtra -> NGLessIO String+asCountsFile (NGOCounts icounts) payload =+    asFile icounts >>= adjustCompression payload+asCountsFile v a = throwScriptError ("Expected counts for argument in function call, got " ++ show v ++ ". " ++ show a)++-- Encodes the argument for the command line, performing any necessary+-- transforms (e.g., unzipping).+--+-- The code is not as complex as it seems, but there are a lot of special cases.+encodeArgument :: CommandArgument -> Maybe NGLessObject -> NGLessIO [String]+encodeArgument (CommandArgument ai Nothing _) Nothing+    | not (argRequired ai) = return []+    | otherwise = throwScriptError $ concat ["Missing value for required argument ", T.unpack (argName ai), "."]+encodeArgument ca@(CommandArgument _ v _) Nothing = encodeArgument ca v+encodeArgument (CommandArgument ai _ payload) (Just v)+    | argType ai == NGLBool = do+        val <- boolOrTypeError "in command module" v+        return $! if not val+            then []+            else case payload of+                Just (FlagInfo flags) -> map T.unpack flags+                _ -> ["--" ++ T.unpack (argName ai)]+    | argType ai == NGLReadSet = case v of+        NGOReadSet{} -> asFilePaths v payload+        _ -> throwScriptError ("Expected readset for argument in function call, got " ++ show v)+    | otherwise = do+        asStr <- case argType ai of+            NGLString -> do+                str <- T.unpack <$> stringOrTypeError "in external module" v+                case payload of+                     Just (ExpandSearchPath True) -> fromMaybe str <$> expandPath str+                     _ -> return str+            NGLSymbol -> T.unpack <$> symbolOrTypeError "in external module" v+            NGLInteger ->  show <$> integerOrTypeError "in external module" v+            NGLMappedReadSet -> case v of+                NGOMappedReadSet{} -> head <$> asFilePaths v payload+                _ -> throwScriptError ("Expected mappedreadset for argument in function call, got " ++ show v)+            NGLCounts -> asCountsFile v payload+            other -> throwShouldNotOccur ("Unexpected type tag in external module " ++ show other)+        return $! if argName ai == ""+                    then [asStr]+                    else [concat ["--", T.unpack (argName ai), "=", asStr]]++-- As (possibly compressed) sam file+asSamFile fname payload+    | ".bam" `isSuffixOf` fname = convertBamToSam fname+    | otherwise = adjustCompression payload fname++asBamFile fname+    | ".bam" `isSuffixOf` fname = return fname+    | ".sam.gz" `isSuffixOf` fname = convertSamToBam fname+    | ".sam.bz2" `isSuffixOf` fname = convertSamToBam fname+    | ".sam.zst" `isSuffixOf` fname = convertSamToBam fname+    | ".sam.zstd" `isSuffixOf` fname = convertSamToBam fname+    | ".sam.xz" `isSuffixOf` fname = convertSamToBam fname+    | ".sam" `isSuffixOf` fname = convertSamToBam fname+    | otherwise = return fname++uncompressFile :: FilePath -> NGLessIO FilePath+uncompressFile f = makeNGLTempFile f "uncompress_" (takeBaseName f) $ \hout ->+        withPossiblyCompressedFile f $ \src ->+            C.runConduit (src .| CC.sinkHandle hout)++argsArguments :: Command -> KwArgsValues -> NGLessIO [String]+argsArguments cmd args = concat <$> forM (additional cmd) a1+    where+        a1 ci@(CommandArgument ai _ _) = encodeArgument ci (lookup (argName ai) args)++asInternalModule :: ExternalModule -> NGLessIO Module+asInternalModule em@ExternalModule{..} = do+    validateModule em+    return def+        { modInfo = emInfo+        , modPath = modulePath+        , modCitations = emCitations+        , modReferences = references+        , modFunctions = map asFunction emFunctions+        , runFunction = executeCommand modulePath emFunctions+        }++-- | performs internal validation and calls init-cmd (if any)+validateModule :: ExternalModule -> NGLessIO ()+validateModule  em@ExternalModule{..} = do+    checkSyntax em+    whenJust modNGLessMinVersion $ \(ModuleNGLessMinVersion minV reason) -> do+        curV <- ngleVersion <$> nglEnvironment+        when (minV > curV) $+            throwScriptError $ concat+                [ "Current NGLess version is too old for loading module '"+                , show emInfo, ".\n"+                , "Version ", show minV, " is required.\n"+                , "Reason: ", T.unpack reason]+    whenJust initCmd $ \initCmd' -> do+        outputListLno' DebugOutput ("Running initialization for module ":show emInfo:" ":initCmd':" ":initArgs)+        env <- nglessEnv modulePath+        (exitCode, out, err) <- liftIO $+            readCreateProcessWithExitCode (proc (modulePath </> initCmd') initArgs) { env = Just env } ""+        case (exitCode,out,err) of+            (ExitSuccess, "", "") -> return ()+            (ExitSuccess, msg, "") -> outputListLno' TraceOutput ["Module OK. information: ", msg]+            (ExitSuccess, mout, merr) -> outputListLno' TraceOutput ["Module OK. information: ", mout, ". Warning: ", merr]+            (ExitFailure code, _,_) -> do+                outputListLno' WarningOutput ["Module loading failed for module ", show emInfo]+                throwSystemError .concat $ ["Error loading module ", show emInfo, "\n",+                    "When running the validation command (", initCmd', " with arguments ", show initArgs, ")\n",+                    "\texit code = ", show code,"\n",+                    "\tstdout='", out, "'\n",+                    "\tstderr='", err, "'"]+++-- | Attempts to find bugs in its argument. When no errors are found, it does+-- nothing+checkSyntax :: ExternalModule -> NGLessIO ()+checkSyntax ExternalModule{..} = forM_ emFunctions $ \f -> do+        checkArg1NoName f+        checkArgsTypes (arg1 f)+        forM_ (additional f) $ \a -> do+            checkArgsAllNamed1 a+            checkArgsTypes a+    where+        checkArg1NoName :: Command -> NGLessIO ()+        checkArg1NoName Command{..} =+            when ((argName . cargInfo $ arg1) /= "") $+                throwScriptError "Error in module.yaml: `arg1` cannot have a 'name' attribute"+        checkArgsAllNamed1 :: CommandArgument -> NGLessIO ()+        checkArgsAllNamed1 (CommandArgument ai _ _) =+            when (argName ai == "") $+                throwScriptError "Error in module.yaml: `additional` argument is missing a name"+        checkArgsTypes :: CommandArgument -> NGLessIO ()+        checkArgsTypes (CommandArgument ai _ (Just (FileInfo (FileType ft _ _ _)))) = do+                let atype = argType ai+                when ((atype, ft) `notElem` legalNGLTypeFileTypeCombos) $+                    throwScriptError "Illegal combination of options for atype/filetype"+        checkArgsTypes _ = return ()++        legalNGLTypeFileTypeCombos = [+                (NGLReadSet, FastqFileSingle)+                ,(NGLReadSet, FastqFilePair)+                ,(NGLReadSet, FastqFileTriplet)+                ,(NGLMappedReadSet, SamFile)+                ,(NGLMappedReadSet, BamFile)+                ,(NGLMappedReadSet, SamOrBamFile)+                ,(NGLCounts, TSVFile)+                ]+++findFirstM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+findFirstM _ [] = return Nothing+findFirstM f (x:xs) = f x >>= \case+    Nothing -> findFirstM f xs+    other -> return other++downloadModule :: T.Text -> T.Text -> NGLessIO FilePath+downloadModule modname modversion = do+    dataDirectory <- nConfUserDataDirectory <$> nglConfiguration+    baseUrl <- nConfDownloadBaseURL <$> nglConfiguration+    let nameversion = T.unpack modname <.> "ngm" </> T.unpack modversion+        destdir = dataDirectory </> "Modules" </> nameversion+        url = baseUrl </> "Modules" </> nameversion <.> "tar.gz"+    downloadExpandTar url dataDirectory+    return destdir++-- | Find and load the external module+findLoad :: T.Text -> T.Text -> NGLessIO ExternalModule+findLoad modname version = do+    let modpath' = "Modules" </> T.unpack modname <.> "ngm"+        modpath = modpath' </> T.unpack version+        modfile = "module.yaml"+    globalDir <- nConfGlobalDataDirectory <$> nglConfiguration+    userDir <- nConfUserDataDirectory <$> nglConfiguration+    found <- flip findFirstM [".", globalDir, userDir] $ \basedir -> do+        let fname = basedir </> modpath </> modfile+        exists <- liftIO $ doesFileExist fname+        outputListLno' TraceOutput ["Looking for module ", T.unpack modname, " at `", fname, if exists then "` and found it." else "` and did not find it."]+        return $! if exists+            then Just (basedir </> modpath)+            else Nothing+    found' <- case found of+        Nothing+            | modname `elem` knownModules -> Just <$> downloadModule modname version+        _ -> return found+    case found' of+        Just mdir -> Yaml.decodeEither' <$> liftIO (B.readFile (mdir </> modfile)) >>= \case+                        Right v -> do+                            checkCompatible modname version (emInfo v)+                            return (addPathToRep mdir v)+                        Left err -> throwSystemError ("Could not load module file "++ mdir </> modfile ++ ". Error was `" ++ show err ++ "`")+        Nothing -> do+                others <- forM [".", globalDir, userDir] $ \basedir -> do+                    let dname = basedir </> modpath'+                        listDirectory d = filter (`notElem` [".", ".."]) <$> getDirectoryContents d+                    exists <- liftIO $ doesDirectoryExist dname+                    if not exists+                         then return []+                         else liftIO (listDirectory dname)+                throwSystemError+                    ("Could not find external module '" ++ T.unpack modname +++                        (case concat others of+                            [] -> "'."+                            foundVersions -> "' version " ++ T.unpack version ++ ".\n"+                                            ++ "Please check the version number. I found the following versions:" +++                                                concat ["\n\t- " ++ show v | v <- uniq foundVersions]))++checkCompatible :: T.Text -> T.Text -> ModInfo -> NGLessIO ()+checkCompatible modname version mi = do+        let version' = modVersion mi+        nversion <- norm version+        nversion' <- norm version'+        when (nversion' /= nversion) $+            throwSystemError (concat ["Mismatched version information when loading module `", T.unpack modname, "`.\n\t"+                            ,"Expected ", T.unpack version, " but file contains '", T.unpack version', "'."])+    where+        norm ver = case T.split (== '.') ver of+            (majv:minv:_) -> return (majv, minv)+            _ -> throwScriptError ("Cannot parse version string '"++T.unpack ver++"'.")++loadModule :: ModInfo -> NGLessIO Module+loadModule mi+        | isGlobalImport mi && name `notElem` knownModules =+            throwScriptError (+                    "Module '" ++ T.unpack name ++ "' is not known.\n\t"+                    ++ T.unpack (suggestionMessage name knownModules)+                    ++ "\n\tTo import local modules, use \"local import\"")+        | otherwise = asInternalModule =<< findLoad name version+    where+        isGlobalImport LocalModInfo{} = False+        isGlobalImport ModInfo{} = True+        name = modName mi+        version = modVersion mi+
+ NGLess/FileManagement.hs view
@@ -0,0 +1,427 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, CPP #-}+module FileManagement+    ( InstallMode(..)+    , createTempDir+    , openNGLTempFile+    , openNGLTempFile'+    , makeNGLTempFile+    , removeIfTemporary+    , setupHtmlViewer+    , takeBaseNameNoExtensions++    , samtoolsBin+    , prodigalBin+    , megahitBin+    , bwaBin+    , minimap2Bin+    , expandPath++    , inferCompression+    , ensureCompressionIsOneOf+    , Compression(..)++#ifdef IS_BUILDING_TEST+    , expandPath'+#endif+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Text.RE.TDFA.String as RE+import qualified System.FilePath as FP+import qualified Data.Conduit.Algorithms.Async as CAlg+import qualified Conduit as C+import           Conduit ((.|))+import           System.FilePath (takeDirectory, (</>), (<.>), (-<.>))+import           Control.Monad (unless, forM_, when)+import           System.Posix.Files (setFileMode, createSymbolicLink)+import           System.Posix.Internals (c_getpid)+import           Data.List (isSuffixOf, isPrefixOf)++import qualified System.Directory as SD+import System.IO+import System.IO.Error+import Control.Exception+import System.Environment (getExecutablePath, lookupEnv)+import Control.Monad.Trans.Resource+import Control.Monad.IO.Class (liftIO)+import Data.Maybe++import Configuration+import Version (versionStr)++import Data.FileEmbed (embedDir)+import Output+import NGLess.NGLEnvironment+import qualified Dependencies.Embedded as Deps+import NGLess.NGError+import Utils.LockFile+import Utils.Utils (findM, withOutputFile)+++{- Note on temporary files+ -+ - A big part of this module is handling temporary files. By generating+ - temporary files with the functions in this module, one guarantees that user+ - settings (wrt where to store files, whether to keep them, &c) are respected.+ - It also enables garbage collection.+ -+ -}++data InstallMode = User | Root deriving (Eq, Show)++data Compression = NoCompression+                | GzipCompression+                | BZ2Compression+                | XZCompression+                | ZStdCompression+                deriving (Eq)++inferCompression :: FilePath -> Compression+inferCompression fp+    | isSuffixOf ".gz" fp = GzipCompression+    | isSuffixOf ".bz2" fp = BZ2Compression+    | isSuffixOf ".xz"  fp = XZCompression+    | isSuffixOf ".zst" fp = ZStdCompression+    | isSuffixOf ".zstd" fp = ZStdCompression+    | otherwise = NoCompression+++{- Ensure that the file is compressed using an acceptable compression format+ - (potentially by recompressing).+ -}+ensureCompressionIsOneOf :: [Compression] -- ^ Acceptable formats+                                -> FilePath -- ^ input file+                                -> NGLessIO FilePath+ensureCompressionIsOneOf [] fp = return fp+ensureCompressionIsOneOf cs fp+        | inferCompression fp `elem` cs = return fp+        | otherwise = makeNGLTempFile fp "adjust_compression_" ext' $ \h ->+            CAlg.withPossiblyCompressedFile fp $ \src ->+                C.runConduit $+                    src .| (if GzipCompression `elem` cs+                        then CAlg.asyncGzipTo+                        else C.sinkHandle) h+    where+        ext' = case FP.takeExtensions fp of+                "" -> ""+                (_:rest)+                    | GzipCompression `elem` cs -> rest -<.> "gz"+                    | otherwise -> rest+++-- | Shorten filename if longer than 240 characters+-- If base + ext is above 240 chars, avoid reaching the system limit of 255+-- by shortening the middle part of the filename+checkFilenameLength :: FilePath -> String -> String+checkFilenameLength base ext = if len > 240+                                  then shorten base+                                  else base+    where len = length base + length ext+          -- Take first 1/3 and last 1/3 of the original base name+          shorten f = take (div len 3) f ++ "..." ++ drop (div (2 * len) 3) f++-- | open a temporary file+-- This respects the preferences of the user (using the correct temporary+-- directory and deleting the file when necessary)+--+-- These files will be auto-removed when ngless exits+openNGLTempFile' :: FilePath -- ^ basename+                        -> String -- ^ prefix+                        -> String -- ^ extension+                        -> NGLessIO (ReleaseKey, (FilePath, Handle))+openNGLTempFile' base prefix ext = do+    tdir <- nConfTemporaryDirectory <$> nglConfiguration+    liftIO $ SD.createDirectoryIfMissing True tdir+    keepTempFiles <- nConfKeepTemporaryFiles <$> nglConfiguration+    let cleanupAction = if not keepTempFiles+                then deleteTempFile+                else hClose . snd++        filename = checkFilenameLength base ext+    (key,(fp,h)) <- allocate+                (openTempFileWithDefaultPermissions tdir (prefix ++ takeBaseNameNoExtensions filename ++ "." ++ ext))+                cleanupAction+    outputListLno' DebugOutput ["Created & opened temporary file ", fp]+    updateNglEnvironment $ \e -> e { ngleTemporaryFilesCreated = fp : ngleTemporaryFilesCreated e }+    return (key,(fp,h))++-- | Open a temporary file+-- See openNGLTempFile'+openNGLTempFile :: FilePath -> String -> String -> NGLessIO (FilePath, Handle)+openNGLTempFile base pre ext = snd <$> openNGLTempFile' base pre ext++deleteTempFile (fp, h) = do+    hClose h+    removeFileIfExists fp++-- | Create a temporary file+-- The Handle is closed after the action is performed+--+-- See 'openNGLTempFile'+makeNGLTempFile :: FilePath -> String -> String -> (Handle -> NGLessIO ()) -> NGLessIO FilePath+makeNGLTempFile base pre ext act = do+    (fpath, h) <- openNGLTempFile base pre ext+    act h+    liftIO $ hClose h+    return fpath++-- | removeIfTemporary removes files if (and only if):+-- 1. this was a temporary file created by 'openNGLTempFile'+-- 2. the user has not requested that temporary files be kept+--+-- It is *not necessary* to call this function, but it may save on temporary+-- disk space to clean up early.+removeIfTemporary :: FilePath -> NGLessIO ()+removeIfTemporary fp = do+    keepTempFiles <- nConfKeepTemporaryFiles <$> nglConfiguration+    createdFiles <- ngleTemporaryFilesCreated <$> nglEnvironment+    unless (keepTempFiles || fp `notElem` createdFiles) $ do+        outputListLno' DebugOutput ["Removing temporary file: ", fp]+        liftIO $ removeFileIfExists fp+        updateNglEnvironment $ \e -> e { ngleTemporaryFilesCreated = filter (/=fp) (ngleTemporaryFilesCreated e) }+{-# NOINLINE removeIfTemporary #-}+++-- | This is a version of 'takeBaseName' which drops all extension+-- ('takeBaseName' only takes out the first extension)+takeBaseNameNoExtensions = FP.dropExtensions . FP.takeBaseName+{-# INLINE takeBaseNameNoExtensions #-}++-- | create a temporary directory as a sub-directory of the user-specified+-- temporary directory.+--+-- Releasing deletes the directory and all its contents (unless the user+-- requested that temporary files be preserved).+createTempDir :: String -> NGLessIO (ReleaseKey,FilePath)+createTempDir template = do+        tbase <- nConfTemporaryDirectory <$> nglConfiguration+        liftIO $ SD.createDirectoryIfMissing True tbase+        keepTempFiles <- nConfKeepTemporaryFiles <$> nglConfiguration+        allocate+            (c_getpid >>= createFirst tbase (takeBaseNameNoExtensions template))+            (if not keepTempFiles+                then SD.removeDirectoryRecursive+                else const (return ()))+    where+        createFirst :: (Num a, Show a) => FilePath -> String -> a -> IO FilePath+        createFirst dirbase t n = do+            let dirpath = dirbase </> t <.> "tmp" ++ show n+            try (SD.createDirectory dirpath) >>= \case+                Right () -> return dirpath+                Left e+                    | isAlreadyExistsError e -> createFirst dirbase t (n + 1)+                    | otherwise -> ioError e++-- This is in IO because it is run after NGLessIO has finished.+setupHtmlViewer :: FilePath -> IO ()+setupHtmlViewer dst = do+    exists <- SD.doesFileExist (dst </> "index.html")+    unless exists $ do+        SD.createDirectoryIfMissing False dst+        forM_ $(embedDir "Html") $ \(fp,bs) ->+            B.writeFile (dst </> fp) bs+++-- | path to bwa+bwaBin :: NGLessIO FilePath+bwaBin = findNGLessBin "NGLESS_BWA_BIN" "bwa" Deps.bwaData++-- | path to samtools+samtoolsBin :: NGLessIO FilePath+samtoolsBin = findNGLessBin "NGLESS_SAMTOOLS_BIN" "samtools" Deps.samtoolsData+        --+-- | path to prodigal+prodigalBin :: NGLessIO FilePath+prodigalBin = findNGLessBin "NGLESS_PRODIGAL_BIN" "prodigal" Deps.prodigalData++-- | path to minimap2+minimap2Bin :: NGLessIO FilePath+minimap2Bin = findNGLessBin "NGLESS_MINIMAP2_BIN" "minimap2" Deps.minimap2Data++-- | path to megahit+megahitBin :: NGLessIO FilePath+megahitBin = liftIO (lookupEnv "NGLESS_MEGAHIT_BIN") >>= \case+    Just bin -> checkExecutable "megahit" bin+    Nothing -> do+        findBin ("ngless-"++versionStr ++ "-megahit/megahit") >>= \case+            Just bin -> return bin+            Nothing -> do+                megahitData' <- liftIO Deps.megahitData+                if B.null megahitData'+                    then findBin "megahit" >>= \case+                        Just bin -> do+                            outputListLno' WarningOutput+                                ["Could not find NGLess-specific megahit installation, using ", bin]+                            return bin+                        Nothing -> throwSystemError "Cannot find megahit on the system and this is a build without embedded dependencies."+                    else createMegahitBin megahitData'+++binPath :: InstallMode -> NGLessIO FilePath+binPath Root = do+    nglessBinDirectory <- takeDirectory <$> liftIO getExecutablePath+#ifndef WINDOWS+    return (nglessBinDirectory </> "../share/ngless/bin")+#else+    return nglessBinDirectory+#endif+binPath User = ((</> "bin") . nConfUserDirectory) <$> nglConfiguration++-- | Attempts to find the absolute path for the requested binary (checks permissions)+findBin :: FilePath -> NGLessIO (Maybe FilePath)+findBin fname = do+        nglPath <- findM [Root, User] $ \p -> do+            path <- (</> fname) <$> binPath p+            ex <- canExecute path+            if ex+                then return (Just path)+                else return Nothing+        case nglPath of+            Just p -> return (Just p)+            Nothing -> liftIO $ SD.findExecutable fname+    where+        canExecute :: FilePath -> NGLessIO Bool+        canExecute bin = do+            exists <- liftIO $ SD.doesFileExist bin+            if exists+                then do+                    isExecutable <- SD.executable <$> (liftIO $ SD.getPermissions bin)+                    unless isExecutable $+                        outputListLno' WarningOutput [+                            "Found file `", bin,+                            "`, but it is not executable by NGLess (may indicate a permission error)."]+                    return isExecutable+                else return False+++findNGLessBin :: String -> FilePath -> IO B.ByteString -> NGLessIO FilePath+findNGLessBin envvar fname bindata = liftIO (lookupEnv envvar) >>= \case+    Just bin -> checkExecutable envvar bin+    Nothing -> do+        let versionTaggedFname =+                "ngless-" ++ versionStr ++ "-" ++ fname ++ binaryExtension+        findBin versionTaggedFname >>= \case+            Just bin -> return bin+            Nothing -> do+                bindata' <- liftIO bindata+                if B.null bindata'+                    then findBin fname >>= \case+                        Just bin -> do+                            outputListLno' WarningOutput+                                ["Could not find an NGLess specific executable for ", fname, ", using ", bin]+                            return bin+                        Nothing -> throwSystemError ("Cannot find " ++ fname ++ " on the system and this is a build without embedded dependencies.")+                    else writeBin versionTaggedFname bindata++writeBin :: FilePath -> IO B.ByteString -> NGLessIO FilePath+writeBin fname bindata = do+    userBinPath <- binPath User+    bindata' <- liftIO bindata+    when (B.null bindata') $+        throwSystemError ("Cannot find " ++ fname ++ " on the system and this is a build without embedded dependencies.")+    liftIO $ SD.createDirectoryIfMissing True userBinPath+    let fname' = userBinPath </> fname+    withLockFile LockParameters+                    { lockFname = fname' ++ ".expand.lock"+                    , maxAge = 300+                    , whenExistsStrategy = IfLockedRetry { nrLockRetries = 60, timeBetweenRetries = 60 }+                    , mtimeUpdate = True+                    } $ liftIO $ do+        withOutputFile fname' (flip B.hPut bindata')+        p <- SD.getPermissions fname'+        SD.setPermissions fname' (SD.setOwnerExecutable True p)+        return fname'++createMegahitBin :: B.ByteString-> NGLessIO FilePath+createMegahitBin megahitData = do+    destdir <- (</> ("ngless-" ++ versionStr ++ "-megahit")) <$> binPath User+    liftIO $ SD.createDirectoryIfMissing True destdir+    withLockFile LockParameters+                { lockFname = destdir ++ "lock.megahit-expand"+                , maxAge = 300+                , whenExistsStrategy = IfLockedRetry { nrLockRetries = 37*60, timeBetweenRetries = 60 }+                , mtimeUpdate = True+               } $ do+        outputListLno' TraceOutput ["Expanding megahit binaries into ", destdir]+        unpackMegahit destdir $ Tar.read . GZip.decompress $ BL.fromChunks [megahitData]+    return $ destdir </> "megahit"+    where+        unpackMegahit :: FilePath -> Tar.Entries Tar.FormatError -> NGLessIO ()+        unpackMegahit _ Tar.Done = return ()+        unpackMegahit _ (Tar.Fail err) = throwSystemError ("Error expanding megahit archive: " ++ show err)+        unpackMegahit destdir (Tar.Next e next) = do+            let dest = destdir </> FP.takeBaseName (Tar.entryPath e)+            case Tar.entryContent e of+                Tar.NormalFile content _ -> do+                    liftIO $ do+                        BL.writeFile dest content+                        --setModificationTime dest (posixSecondsToUTCTime (fromIntegral $ Tar.entryTime e))+                        setFileMode dest (Tar.entryPermissions e)+                Tar.Directory -> return ()+                Tar.SymbolicLink lt -> do+                    liftIO $ createSymbolicLink (Tar.fromLinkTarget lt) dest+                _ -> throwSystemError ("Unexpected entry in megahit tarball: " ++ show e)+            unpackMegahit destdir next++++checkExecutable :: String -> FilePath -> NGLessIO FilePath+checkExecutable name bin = do+    exists <- liftIO $ SD.doesFileExist bin+    unless exists+        (throwSystemError $ concat [name, " binary not found!\n","Expected it at ", bin])+    is_executable <- SD.executable <$> liftIO (SD.getPermissions bin)+    unless is_executable+        (throwSystemError $ concat [name, " binary found at ", bin, ".\nHowever, it is not an executable file!"])+    return bin+++expandPath :: FilePath -> NGLessIO (Maybe FilePath)+expandPath fbase = do+        searchpath <- nConfSearchPath <$> nglConfiguration+        outputListLno' TraceOutput ["Looking for file '", fbase, "' (search path is ", show searchpath, ")"]+        let candidates = expandPath' fbase searchpath+        findMaybeM candidates $ \p -> do+            outputListLno' TraceOutput ["Looking for file (", fbase, ") in ", p]+            exists <- liftIO (SD.doesFileExist p)+            return $! if exists+                            then Just p+                            else Nothing+    where+        findMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m (Maybe b)+        findMaybeM [] _ = return Nothing+        findMaybeM (x:xs) f = f x >>= \case+            Nothing -> findMaybeM xs f+            val -> return val++expandPath' :: FilePath -> [FilePath] -> [FilePath]+expandPath' fbase search = case RE.matchedText $ fbase RE.?=~ [RE.re|<(@{%id})?>|] of+        Nothing -> [fbase]+        Just c -> mapMaybe (expandPath'' $ trim c) search+    where+        trim = init . drop 1+        expandPath'' :: FilePath -> FilePath -> Maybe FilePath+        expandPath'' code path = (</> fbase') <$> simplify code path+        simplify :: FilePath -> FilePath -> Maybe FilePath+        simplify c path+            | '=' `notElem` path = Just path+            | (c++"=")`isPrefixOf` path = Just $ drop (length c + 1) path+            | otherwise = Nothing+        fbase' = removeSlash1 $ fbase RE.*=~/ [RE.ed|<(@{%id})?>///|]+        removeSlash1 "" = ""+        removeSlash1 ('/':p) = removeSlash1 p+        removeSlash1 p = p++binaryExtension :: String+#ifdef WINDOWS+binaryExtension = ".exe"+#else+binaryExtension = ""+#endif
+ NGLess/FileOrStream.hs view
@@ -0,0 +1,45 @@+{- Copyright 2016-2021 NGLess Authors+ - License: MIT+ -}++module FileOrStream+    ( FileOrStream(..)+    , asFile+    , asStream+    , asSamStream+    , origin+    ) where++import           Data.Conduit ((.|))+import qualified Data.Vector as V+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.Binary as C+import System.FilePath++import FileOrStream.Types (FileOrStream(..))+import NGLess.NGError+import Utils.Conduit+import Utils.Samtools+import FileManagement++asFile :: FileOrStream -> NGLessIO FilePath+asFile (File fp) = return fp+asFile (Stream _ fp istream) =+    makeNGLTempFile "streamed_" (takeBaseNameNoExtensions fp) (takeExtensions fp) $ \hout ->+        C.runConduit $+            istream+                .| CC.concat+                .| byteLineSinkHandle hout+++asStream :: FileOrStream -> (FilePath, C.ConduitT () (V.Vector ByteLine) NGLessIO ())+asStream (Stream _ fp istream) = (fp, istream)+asStream (File fp) = (fp, C.sourceFile fp .| linesVC 4096)++asSamStream (File fname) = (fname, samBamConduit fname .| linesVC 4096)+asSamStream (Stream _ fname istream) = (fname, istream)++origin :: FileOrStream -> [FilePath]+origin (File f) = [f]+origin (Stream os _ _) = concatMap origin os
+ NGLess/FileOrStream/Types.hs view
@@ -0,0 +1,36 @@+{- Copyright 2016-2022 NGLess Authors+ - License: MIT+ -}++module FileOrStream.Types+    ( FileOrStream(..)+    ) where++import qualified Data.Vector as V+import qualified Data.Conduit as C++import NGLess.NGError+import Utils.Conduit++{- FileOrStream is either a file or a stream, with the following extra information+ -  1. A filename+ -  2. The origin of the data+ -+ -  If it is a file, then both (1) and (2) are just the actual filename, but if+ -  it's a stream then (1) is the fake name of the file and (2) points+ -  (potentially removed) to where the original data is on disk. It is+ -  necessary to keep track of this to implement GC correctly.+-}+data FileOrStream = File FilePath+                    | Stream [FileOrStream] -- ^ the origin of stream+                                FilePath -- ^ the "filename"+                                (C.ConduitT () (V.Vector ByteLine) NGLessIO ())++instance Show FileOrStream where+    show (File fp) = "File " ++ fp+    show Stream{} = "<STREAM>"++instance Eq FileOrStream where+    (File fp) == (File fp') = fp == fp'+    _ == _ = False+
+ NGLess/Interpret.hs view
@@ -0,0 +1,731 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts, CPP #-}+module Interpret+    ( interpret+#ifdef IS_BUILDING_TEST+    , _evalIndex+    , _evalUnary+    , evalBinary+#endif+    ) where++{-| This is the interpreter module. The main function, 'interpet' expects an+ - AST and executes it.+ -+ - Most types in ngless refer to files on disk or streams and not to data (as+ - the data elements are quite large).+ -+ - Interpretation is fairly trivial pattern matching, with the exception that+ - interpreting blocks uses heavily tuned code.+ -+ - Ngless functions are implemented by Haskell functions with the signature+ - 'NGLessObject -> KwArgsValues -> NGLessIO NGLessObject' (the first argument+ - is the unnamed argument, followed by a list of keyword arguments). By+ - convention, they are named 'execute*' (this is a convention only).+ -+ - Several builtin functions are implemented by the files in the+ - Interpretation/ directory.+ -+ - # Interpretation+ -+ -  Interpretation is done inside two monads+ -  1. InterpretationEnvIO+ -      This is the NGLessIO monad with a variable environment on top+ -  2. InterpretationROEnv+ -      This is a read-only variable environment on top of NGLess+ -+ - For blocks, we have a special system where block-variables are read-write,+ - but others are read-only.+ -+ - Functions inside the interpret monads are named interpret*, helper+ - non-monadic functions which perform computations are named eval*.+ -+ - # TODO/Improvement ideas+ -+ - Replacing the variable map with a vector could potentially be faster (only+ - matters for block interpretation).+ -}+++import Control.Applicative+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Resource++import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString as B+import qualified Data.Map.Strict as Map++import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import qualified Data.Conduit.Algorithms.Utils as CAlg+import qualified Data.Conduit.Algorithms.Async as CAlg+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import qualified Control.Concurrent.Async as A+import qualified Control.Concurrent.STM.TBMQueue as TQ+import qualified Data.Conduit.TQueue as CA+import           Control.Monad.Extra (whenJust)+import           Control.Concurrent.STM (atomically)+import           Control.DeepSeq (NFData(..))+import qualified Data.Vector as V+import           Safe (atMay)+import           Control.Error (note)+import           Text.Read (readEither)++import System.IO+import System.Directory+import Data.List (find)+import GHC.Conc                 (getNumCapabilities)++import Language+import FileManagement+import FileOrStream+import Output+import Modules+import NGLess+import Data.Sam+import Data.FastQ+import NGLess.NGLEnvironment+import NGLess.NGError++import Interpretation.Map+import Interpretation.Count (executeCount, executeCountCheck)+import Interpretation.CountFile (executeCountFile)+import Interpretation.FastQ+import Interpretation.Write+import Interpretation.Select (executeSelect, executeMappedReadMethod, reinjectSequences)+import Interpretation.Unique+import Interpretation.Substrim+import Utils.Utils+import Utils.Suggestion+import Utils.Conduit+++type SimpleVariableMap = Map.Map T.Text NGLessObject+data VariableMap = VariableMapGlobal SimpleVariableMap+                    | VariableMapBlock BlockVariables SimpleVariableMap++variableMapLookup v (VariableMapGlobal sm) = Map.lookup v sm+variableMapLookup v (VariableMapBlock b sm) = lookupBlockVar v b <|> Map.lookup v sm++data NGLInterpretEnv = NGLInterpretEnv+    { ieModules :: [Module]+    , ieVariableEnv :: VariableMap+    }++-- Monad 1: IO + read-write environment+type InterpretationEnvIO = StateT  NGLInterpretEnv NGLessIO+-- Monad 2: pure read-only environment+type InterpretationROEnv = ReaderT NGLInterpretEnv NGLess++runInterpretationRO :: NGLInterpretEnv -> InterpretationROEnv a -> NGLess a+runInterpretationRO env act = runReaderT act env++runNGLessIO :: NGLessIO a -> InterpretationEnvIO a+runNGLessIO = lift++liftNGLessIO :: NGLessIO a -> InterpretationEnvIO a+liftNGLessIO = lift++runInROEnvIO :: InterpretationROEnv a -> InterpretationEnvIO a+runInROEnvIO act = do+    env <- get+    runNGLess $ runReaderT act env++{-| The result of a block is a status indicating why the block finished+ - and the value of all block variables.+ -}+data BlockStatus = BlockOk | BlockDiscarded | BlockContinued+    deriving (Eq,Show)++data BlockVariables = BlockVariables1 !T.Text NGLessObject+            deriving (Eq, Show)++data BlockResult = BlockResult+                { blockStatus :: {-# UNPACK #-} !BlockStatus+                , blockValues :: BlockVariables+                } deriving (Eq,Show)++autoComprehendNB f (NGOList es) args = NGOList <$> sequence [f e args | e <- es]+autoComprehendNB f e args = f e args++-- Set line number+setlno :: Int -> InterpretationEnvIO ()+setlno !n = runNGLessIO $ updateNglEnvironment (\e -> e { ngleLno = Just n } )++lookupVariable :: T.Text -> InterpretationROEnv (Maybe NGLessObject)+lookupVariable !k = liftM2 (<|>)+    (lookupConstant k)+    (asks (variableMapLookup k . ieVariableEnv))++lookupConstant :: T.Text -> InterpretationROEnv (Maybe NGLessObject)+lookupConstant !k = do+    constants <- asks (concatMap modConstants . ieModules)+    case filter ((==k) . fst) constants of+        [] -> return Nothing+        [(_,v)] -> return (Just v)+        _ -> throwShouldNotOccur ("Multiple hits found for constant " ++ T.unpack k)+++setVariableValue :: T.Text -> NGLessObject -> InterpretationEnvIO ()+setVariableValue !k !v = modify $ \case+                            (NGLInterpretEnv mods (VariableMapGlobal vm)) -> (NGLInterpretEnv mods (VariableMapGlobal (Map.insert k v vm)))+                            _ -> error "This should never happen (setVariableValue)"++findFunction :: FuncName -> InterpretationEnvIO (NGLessObject -> KwArgsValues -> NGLessIO NGLessObject)+findFunction fname@(FuncName fname') = do+        mods <- gets ieModules+        case filter hasF mods of+            [m] -> case find ((== fname) . funcName) (modFunctions m) of+                    Just func -> do+                        let wrap = if funcAllowsAutoComprehension func+                                        then autoComprehendNB+                                        else id+                        return $ wrap $ (runFunction m) fname'+                    _ ->  throwShouldNotOccur . T.unpack $ T.concat ["Function '", fname', "' not found (not builtin and not in any loaded module), even though it should have."]+            [] -> throwShouldNotOccur . T.unpack $ T.concat ["Function '", fname', "' not found (not builtin and not in any loaded module)"]+            ms -> throwShouldNotOccur . T.unpack $ T.concat (["Function '", T.pack $ show fname, "' found in multiple modules! ("] ++ [T.concat [modname, ":"] | modname <- modName . modInfo <$> ms])+    where+        hasF m = fname `elem` (funcName `fmap` modFunctions m)+++-- | By necessity, this code has several unreachable corners++unreachable :: (MonadError NGError m) => String -> m a+unreachable err = throwShouldNotOccur ("Reached code that was thought to be unreachable!\n"++err)+nglTypeError err = throwShouldNotOccur ("Unexpected type error! This should have been caught by validation!\n"++err)++traceExpr m e =+    runNGLessIO $ outputListLno' TraceOutput ["Interpreting [", m , "]: ", show e]++interpret :: [Module] -> [(Int,Expression)] -> NGLessIO ()+interpret modules es = do+    evalStateT (interpretIO es) (NGLInterpretEnv modules $ VariableMapGlobal Map.empty)+    outputListLno InfoOutput Nothing ["Interpretation finished."]++interpretIO :: [(Int, Expression)] -> InterpretationEnvIO ()+interpretIO es = forM_ es $ \(ln,e) -> do+    setlno ln+    gcTemps+    traceExpr "interpretIO" e+    interpretTop e++gcTemps :: InterpretationEnvIO ()+gcTemps = do+    active <- gets $ \case+                NGLInterpretEnv _ (VariableMapGlobal t) -> Map.elems t+                _ -> error "gcTemps in BLOCK?!"+    let extractFiles = \case+                            NGOString _ -> []+                            NGOBool _ -> []+                            NGOInteger _ -> []+                            NGODouble _ -> []+                            NGOSymbol _ -> []+                            NGOFilename f -> [f]+                            NGOShortRead _ -> []+                            NGOReadSet _ rs -> extractFilesRS rs+                            NGOSequenceSet s -> origin s+                            NGOMappedReadSet _ s _ -> origin s+                            NGOMappedRead _ -> []+                            NGOCounts s -> origin s+                            NGOVoid -> []+                            NGOList lst -> concatMap extractFiles lst+        extractFilesRS (ReadSet ps p3) = concatMap (extractFilesRS' . fst) ps+                                                ++ concatMap (extractFilesRS' . snd) ps+                                                ++ concatMap extractFilesRS' p3+        extractFilesRS' (FastQFilePath _ f) = [f]+        activeFiles = concatMap extractFiles active+    runNGLessIO $ do+        outputListLno' DebugOutput ["Running garbage collection."]+        createdFiles <- ngleTemporaryFilesCreated <$> nglEnvironment+        let garbage = filter (`notElem` activeFiles) createdFiles+        -- Use removeIfTemporary because it respects command line flags &c+        forM_ garbage removeIfTemporary++interpretTop :: Expression -> InterpretationEnvIO ()+interpretTop (Assignment (Variable var) val) = traceExpr "assignment" val >> interpretTopValue val >>= setVariableValue var+interpretTop (FunctionCall f e args b) = void $ interpretFunction f e args b+interpretTop (Condition c ifTrue ifFalse) = do+    c' <- runInROEnvIO (interpretExpr c >>= boolOrTypeError "interpreting if condition")+    interpretTop (if c'+        then ifTrue+        else ifFalse)+interpretTop (Sequence es) = forM_ es interpretTop+interpretTop e = throwShouldNotOccur ("Unexpected top level statement: "++show e)++interpretTopValue :: Expression -> InterpretationEnvIO NGLessObject+interpretTopValue (FunctionCall f e args b) = interpretFunction f e args b+interpretTopValue (ListExpression es) = NGOList <$> mapM interpretTopValue es+interpretTopValue e = runInROEnvIO (interpretExpr e)++interpretExpr :: Expression -> InterpretationROEnv NGLessObject+interpretExpr (Lookup _ (Variable v)) = lookupVariable v >>= \case+        Nothing -> throwScriptError ("Could not lookup variable `"++show v++"`")+        Just r' -> return r'+interpretExpr (BuiltinConstant (Variable "STDIN")) = return (NGOString "/dev/stdin")+interpretExpr (BuiltinConstant (Variable "STDOUT")) = return (NGOString "/dev/stdout")+interpretExpr (BuiltinConstant (Variable "__VOID")) = return NGOVoid+interpretExpr (BuiltinConstant (Variable v)) = throwShouldNotOccur ("Unknown builtin constant '" ++ show v ++ "': it should not have been accepted.")+interpretExpr (ConstStr t) = return (NGOString t)+interpretExpr (ConstBool b) = return (NGOBool b)+interpretExpr (ConstSymbol s) = return (NGOSymbol s)+interpretExpr (ConstInt n) = return (NGOInteger n)+interpretExpr (ConstDouble n) = return (NGODouble n)+interpretExpr (UnaryOp op v) = do+    v' <- interpretExpr v+    runNGLess (_evalUnary op v')+interpretExpr (BinaryOp bop v1 v2) = do+    v1' <- interpretExpr v1+    v2' <- interpretExpr v2+    runNGLess (evalBinary bop v1' v2')+interpretExpr (IndexExpression expr ie) = do+    expr' <- interpretExpr expr+    ie' <- interpretIndex ie+    runNGLess (_evalIndex expr' ie')+interpretExpr (ListExpression e) = NGOList <$> mapM interpretExpr e+interpretExpr (MethodCall met self arg args) = do+    self' <- interpretExpr self+    arg' <- fmapMaybeM interpretExpr arg+    args' <- forM args $ \(Variable v, e) -> do+        e' <- interpretExpr e+        return (v, e')+    executeMethod met self' arg' args'+interpretExpr not_expr = throwShouldNotOccur ("Expected an expression, received " ++ show not_expr ++ " (in interpretExpr)")++interpretIndex :: Index -> InterpretationROEnv [Maybe NGLessObject]+interpretIndex (IndexTwo a b) = forM [a,b] maybeInterpretExpr+interpretIndex (IndexOne a) = forM [Just a] maybeInterpretExpr++maybeInterpretExpr :: Maybe Expression -> InterpretationROEnv (Maybe NGLessObject)+maybeInterpretExpr = fmapMaybeM interpretExpr++interpretFunction :: FuncName -> Expression -> [(Variable, Expression)] -> Maybe Block -> InterpretationEnvIO NGLessObject+interpretFunction (FuncName "preprocess") expr args (Just block) = do+    expr' <- runInROEnvIO $ interpretExpr expr+    args' <- interpretArguments args+    executePreprocess expr' args' block+interpretFunction (FuncName "preprocess") expr _ _ = throwShouldNotOccur ("preprocess expected a variable holding a NGOReadSet, but received: " ++ show expr)+interpretFunction f expr args block = do+    expr' <- interpretTopValue expr+    args' <- interpretArguments args+    interpretFunction' f expr' args' block++interpretFunction' :: FuncName -> NGLessObject -> KwArgsValues -> Maybe Block -> InterpretationEnvIO NGLessObject+interpretFunction' (FuncName "fastq")     expr args Nothing = runNGLessIO (executeFastq expr args)+interpretFunction' (FuncName "group")     expr args Nothing = runNGLessIO (executeGroup expr args)+interpretFunction' (FuncName "samfile")   expr args Nothing = autoComprehendNB executeSamfile expr args+interpretFunction' (FuncName "unique")    expr args Nothing = runNGLessIO (executeUnique expr args)+interpretFunction' (FuncName "write")     expr args Nothing = traceExpr "write" expr >> runNGLessIO (executeWrite expr args)+interpretFunction' (FuncName "map")       expr args Nothing = runNGLessIO (executeMap expr args)+interpretFunction' (FuncName "mapstats")  expr args Nothing = runNGLessIO (executeMapStats expr args)+interpretFunction' (FuncName "__merge_samfiles")  expr args Nothing = runNGLessIO (executeMergeSams expr args)+interpretFunction' (FuncName "select")    expr args Nothing = runNGLessIO (executeSelect expr args)+interpretFunction' (FuncName "count")     expr args Nothing = runNGLessIO (executeCount expr args)+interpretFunction' (FuncName "__check_count") expr args Nothing = runNGLessIO (executeCountCheck expr args)+interpretFunction' (FuncName "countfile") expr args Nothing = runNGLessIO (executeCountFile expr args)+interpretFunction' (FuncName "print")     expr args Nothing = executePrint expr args+interpretFunction' (FuncName "read_int")  expr args Nothing = executeReadInt expr args+interpretFunction' (FuncName "read_double")  expr args Nothing = executeReadDouble expr args+interpretFunction' (FuncName "paired")   mate1 args Nothing = runNGLessIO (executePaired mate1 args)+interpretFunction' (FuncName "select")    expr args (Just b) = executeSelectWBlock expr args b+interpretFunction' (FuncName "__assert")  expr [] args       = executeAssert expr args+interpretFunction' fname@(FuncName fname') expr args Nothing = do+    traceExpr ("executing module function: '"++T.unpack fname'++"'") expr+    execF <- findFunction fname+    runNGLessIO (execF expr args)+interpretFunction' f _ _ _ = throwShouldNotOccur . concat $ ["Interpretation of ", show f, " is not implemented"]++executeSamfile expr@(NGOString fname) args = do+    traceExpr "samfile" expr+    gname <- lookupStringOrScriptErrorDef (return fname) "samfile group name" "name" args+    headers <- lookupStringOrScriptErrorDef (return "") "samfile headers" "headers" args+    let headers' = T.unpack headers+        fname' = T.unpack fname+    let checkf f = do+            err <- liftIO (checkFileReadable f)+            whenJust err (throwDataError . T.unpack)+    checkf fname'+    if null headers'+        then return $ NGOMappedReadSet gname (File fname') Nothing+        else do+            checkf headers'+            let out = Stream+                            [File fname', File headers']+                            fname'+                            ((CB.sourceFile headers' >> CB.sourceFile fname') .| linesVC 4096)+            return $ NGOMappedReadSet gname out Nothing+executeSamfile e args = unreachable ("executeSamfile " ++ show e ++ " " ++ show args)++data PreprocessPairOutput = Paired !ShortRead !ShortRead | Single !ShortRead+instance NFData PreprocessPairOutput where+    rnf (Paired _ _) = ()+    rnf (Single _) = ()++splitPreprocessPair :: V.Vector PreprocessPairOutput -> (V.Vector ShortRead, V.Vector ShortRead, V.Vector ShortRead)+splitPreprocessPair input = (V.mapMaybe extract1 input, V.mapMaybe extract2 input, V.mapMaybe extractS input)+    where+        extract1 = \case+            Paired sr _ -> Just sr+            _ -> Nothing+        extract2 = \case+            Paired _ sr -> Just sr+            _ -> Nothing+        extractS = \case+            Single sr -> Just sr+            _ -> Nothing+++vMapMaybeLifted :: (a -> Either e (Maybe b)) -> V.Vector a -> Either e (V.Vector b)+vMapMaybeLifted f v = sequence $ V.unfoldr loop 0+    where+        loop i+            | i < V.length v = let !n = i+1 in+                            case f (v V.! i) of+                                Right Nothing -> loop n+                                Right (Just val) -> Just (Right val, n)+                                Left err -> Just (Left err, V.length v) -- early exit: we are done+            | otherwise = Nothing++shortReadVectorStats :: (MonadIO m, MonadResource m) => m (TQ.TBMQueue (V.Vector ShortRead), ReleaseKey, A.Async FQStatistics)+shortReadVectorStats = do+    q <- liftIO $ TQ.newTBMQueueIO 8+    p <- liftIO . A.async $+        C.runConduit $ CA.sourceTBMQueue q+            .| CC.concat+            .| fqStatsC+    k <- register (atomically . TQ.closeTBMQueue $ q)+    return (q, k, p)++writeAndContinue :: MonadIO m => TQ.TBMQueue (V.Vector ShortRead) -> C.ConduitT (V.Vector ShortRead) (V.Vector ShortRead) m ()+writeAndContinue q = CL.iterM (liftIO . atomically . TQ.writeTBMQueue q)++executePreprocess :: NGLessObject -> [(T.Text, NGLessObject)] -> Block -> InterpretationEnvIO NGLessObject+executePreprocess (NGOList e) args _block = NGOList <$> mapM (\x -> executePreprocess x args _block) e+executePreprocess (NGOReadSet name (ReadSet pairs singles)) args (Block (Variable var) block) = do+        -- This is a bit complex, but preprocess was slow at first and we try+        -- to take full advantage of parallelism.+        --+        -- Pipeline is+        --    [read file *] -> [decode in blocks] -> [pre QC *] -> [preproc*] -> [post QC*] -> [encode & write *]+        -- where the starred (*) elements are done in a separate thread+        -- for the QC threads, this is done by using a queue & writing data there+        env <- gets id+        liftNGLessIO $ do+            keepSingles <- lookupBoolOrScriptErrorDef (return True) "preprocess argument" "keep_singles" args+            qcInput <- lookupBoolOrScriptErrorDef (return False) "preprocess" "__input_qc" args+            numCapabilities <- liftIO getNumCapabilities+            let mapthreads = 4 * max 1 (numCapabilities - 2)++            [(q1, k1, s1), (q2, k2, s2), (q3, k3, s3)] <- replicateM 3 shortReadVectorStats+++            let inencs = fqpathEncoding <$> (fst <$> pairs) ++ (snd <$> pairs) ++ singles+                outenc+                    | allSame inencs = head inencs+                    | otherwise = SangerEncoding+            let asSource :: [FastQFilePath] -> C.ConduitT () (V.Vector ShortRead) NGLessIO ()+                asSource [] = return ()+                asSource (FastQFilePath enc f:rest) =+                        let input = conduitPossiblyCompressedFile f+                                .| linesVC 4096+                                .| CAlg.enumerateC+                                .| CAlg.asyncMapEitherC mapthreads (\(!i,v) -> fqDecodeVector (4096*i) enc v)+                        in do+                            if not qcInput+                                then input+                                else do+                                    (q, k, s) <- lift shortReadVectorStats+                                    input .| writeAndContinue q+                                    lift $ release k+                                    s' <- liftIO $ A.wait s+                                    lift $ outputFQStatistics f s' enc+                            asSource rest+++                write nt h q =+                        writeAndContinue q+                            .| CAlg.asyncMapC nt (B.concat . map (fqEncode outenc) . V.toList)+                            .| CAlg.asyncZstdTo 3 h++            let processpairs :: (V.Vector ShortRead, V.Vector ShortRead) -> NGLess (V.Vector ShortRead, V.Vector ShortRead, V.Vector ShortRead)+                processpairs = fmap splitPreprocessPair . vMapMaybeLifted (runInterpretationRO env . intercalate keepSingles) . uncurry V.zip+            (fp1', out1) <- openNGLTempFile "" "preprocessed.1." "fq.zst"+            (fp2', out2) <- openNGLTempFile "" "preprocessed.2." "fq.zst"+            (fp3', out3) <- openNGLTempFile "" "preprocessed.singles." "fq.zst"++            C.runConduit $+                zipSource2 (asSource (fst <$> pairs)) (asSource (snd <$> pairs))+                    .| CAlg.asyncMapEitherC mapthreads processpairs+                    .| (void $ C.sequenceSinks+                        [CL.map (\(a,_,_) -> a) .| write mapthreads out1 q1+                        ,CL.map (\(_,a,_) -> a) .| write mapthreads out2 q2+                        ,CL.map (\(_,_,a) -> a) .| write mapthreads out3 q3+                        ])++            C.runConduit $+                asSource singles+                    .| CAlg.asyncMapEitherC mapthreads (vMapMaybeLifted (runInterpretationRO env . interpretPBlock1 block var))+                    .| void (write mapthreads out3 q3)++            forM_ [k1, k2, k3] release+            liftIO $ forM_ [out1, out2, out3] hClose+            [s1',s2',s3'] <- forM [s1,s2,s3] (liftIO . A.wait)++            outputListLno' DebugOutput ["Preprocess finished"]++            Just lno <- ngleLno <$> nglEnvironment+            outputFQStatistics ("preproc.lno"++show lno++".pairs.1") s1' outenc+            outputFQStatistics ("preproc.lno"++show lno++".pairs.2") s2' outenc+            outputFQStatistics ("preproc.lno"++show lno++".singles") s3' outenc+            NGOReadSet name <$> case (nSeq s1' > 0, nSeq s2' > 0, nSeq s3' > 0) of+                        (True, True, False) -> do+                            liftIO $ removeFile fp3'+                            return $ ReadSet [(FastQFilePath outenc fp1', FastQFilePath outenc fp2')] []+                        (False, False, True) -> do+                            forM_ [fp1', fp2'] (liftIO . removeFile)+                            return $ ReadSet [] [FastQFilePath outenc fp3']+                        _+                            | null pairs -> do+                                forM_ [fp1', fp2'] (liftIO . removeFile)+                                return $ ReadSet [] [FastQFilePath outenc fp3']+                            | otherwise -> return $ ReadSet [(FastQFilePath outenc fp1', FastQFilePath outenc fp2')] [FastQFilePath outenc fp3']+    where+        intercalate :: Bool -> (ShortRead, ShortRead) -> InterpretationROEnv (Maybe PreprocessPairOutput)+        intercalate keepSingles (r1, r2) = do+                r1' <- interpretPBlock1 block var r1+                r2' <- interpretPBlock1 block var r2+                return $ case (r1',r2') of+                    (Just r1'', Just r2'') -> Just (Paired r1'' r2'')+                    (Just r, Nothing) -> if keepSingles+                                                then Just (Single r)+                                                else Nothing+                    (Nothing, Just r) -> if keepSingles+                                                then Just (Single r)+                                                else Nothing+                    (Nothing, Nothing) -> Nothing+executePreprocess v _ _ = unreachable ("executePreprocess: Cannot handle this input: " ++ show v)++executeMethod :: MethodName -> NGLessObject -> Maybe NGLessObject -> [(T.Text, NGLessObject)] -> InterpretationROEnv NGLessObject+executeMethod method (NGOMappedRead samline) arg kwargs = runNGLess (executeMappedReadMethod method samline arg kwargs)+executeMethod method (NGOShortRead sr) arg kwargs = runNGLess (executeShortReadsMethod method sr arg kwargs)+executeMethod (MethodName "to_string") (NGODouble val) _ _  = return . NGOString . T.pack . show $ val+executeMethod (MethodName "to_string") (NGOInteger val) _ _ = return . NGOString . T.pack . show $ val+executeMethod m self arg kwargs = throwShouldNotOccur ("Method " ++ show m ++ " with self="++show self ++ " arg="++ show arg ++ " kwargs="++show kwargs ++ " is not implemented")+++interpretPBlock1 :: Expression -> T.Text -> ShortRead -> InterpretationROEnv (Maybe ShortRead)+interpretPBlock1 block var r = do+    r' <- interpretBlock1 (BlockVariables1 var (NGOShortRead r)) block+    case blockStatus r' of+        BlockDiscarded -> return Nothing -- Discard Read.+        _ -> case lookupBlockVar var (blockValues r') of+                Just (NGOShortRead rr) -> case srLength rr of+                    0 -> return Nothing+                    _ -> return (Just rr)+                _ -> nglTypeError ("Expected variable "++show var++" to contain a short read.")++executePrint :: NGLessObject -> [(T.Text, NGLessObject)] -> InterpretationEnvIO NGLessObject+executePrint (NGOString s) [] = liftIO (T.putStr s) >> return NGOVoid+executePrint err  _ = throwScriptError ("Cannot print " ++ show err)++executeReadInt :: NGLessObject -> [(T.Text, NGLessObject)] -> InterpretationEnvIO NGLessObject+executeReadInt (NGOString "") kwargs = NGOInteger <$> lookupIntegerOrScriptError "read_int" "on_empty_return" kwargs+executeReadInt (NGOString s) _ = case readEither (T.unpack s) of+    Right val -> return $! NGOInteger val+    Left err -> throwDataError ("Could not parse integer from '"++T.unpack s++"'. Error: "++err)+executeReadInt s _ = throwScriptError ("Cannot parse this object as integer: "++ show s)++executeReadDouble :: NGLessObject -> [(T.Text, NGLessObject)] -> InterpretationEnvIO NGLessObject+executeReadDouble (NGOString "") kwargs = NGODouble <$> lookupDoubleOrScriptError "read_int" "on_empty_return" kwargs+executeReadDouble (NGOString s) _ = case readEither (T.unpack s) of+    Right val -> return $! NGODouble val+    Left err -> throwDataError ("Could not parse double from '"++T.unpack s++"'. Error: "++err)+executeReadDouble s _ = throwScriptError ("Cannot parse this object as double: "++ show s)++executeAssert (NGOBool True) _ = return NGOVoid+executeAssert (NGOBool False) _ = throwScriptError "Assert failed"+executeAssert _ _ = throwShouldNotOccur "Assert did not receive a boolean!"++executeSelectWBlock :: NGLessObject -> [(T.Text, NGLessObject)] -> Block -> InterpretationEnvIO NGLessObject+executeSelectWBlock input@NGOMappedReadSet{ nglSamFile = isam} args (Block (Variable var) body) = do+        paired <- lookupBoolOrScriptErrorDef (return True) "select" "paired" args+        outputHeader <- lookupBoolOrScriptErrorDef (return True) "select" "__output_header" args+        let (samfp, istream) = asSamStream isam+        runNGLessIO $ outputListLno' TraceOutput ["Executing blocked select on file ", samfp]+        env <- gets id+        numCapabilities <- liftIO getNumCapabilities+        let mapthreads = max 1 (numCapabilities - 1)+        -- See "Notes on 'Sequence reinjection'" in NGLess/Environment/Select.hs+        doReinject <- runNGLessIO $ do+                            v <- ngleVersion <$> nglEnvironment+                            if v < NGLVersion 0 8+                                then do+                                    outputListLno' WarningOutput ["Select changed behaviour (for the better) in ngless 0.8. If possible, upgrade your version statement."]+                                    return False+                                else return True+        oname <- runNGLessIO $ makeNGLTempFile samfp "block_selected_" "sam.zstd" $ \ohandle ->+                C.runConduit $+                    istream+                        .| do+                            when outputHeader $+                                CC.takeWhileE (isSamHeaderString . unwrapByteLine)+                                .| CL.map concatBytelines+                            readSamGroupsC' mapthreads paired+                                .| CAlg.asyncMapEitherC mapthreads (fmap concatLines . V.mapM (runInterpretationRO env . selectBlock doReinject))+                        .|  CAlg.asyncZstdTo 3 ohandle+        return input { nglSamFile = File oname }+    where+        concatBytelines :: V.Vector ByteLine -> B.ByteString+        concatBytelines =  concatLines' . map (BB.byteString . unwrapByteLine) . V.toList++        concatLines :: V.Vector [BB.Builder] -> B.ByteString+        concatLines = concatLines' . concat . V.toList++        concatLines' :: [BB.Builder] -> B.ByteString+        concatLines' = BL.toStrict . BB.toLazyByteString . mconcat . map (`mappend` BB.char7 '\n')++        selectBlock :: Bool -> [SamLine] -> InterpretationROEnv [BB.Builder]+        selectBlock _ [] = return []+        selectBlock _ [SamHeader line] = return [BB.byteString line]+        selectBlock doReinject mappedreads  = do+                    mrs' <- interpretBlock1 (BlockVariables1 var (NGOMappedRead mappedreads)) body+                    if blockStatus mrs' `elem` [BlockContinued, BlockOk]+                        then case lookupBlockVar var (blockValues mrs') of+                            Just (NGOMappedRead []) -> return []+                            Just (NGOMappedRead rs) -> do+                                rs' <- runNGLess $ reinjectSequences mappedreads rs+                                return (encodeSamLine <$> (if doReinject then rs' else rs))+                            _ -> nglTypeError ("Expected variable "++show var++" to contain a mapped read.")++                        else return []+executeSelectWBlock expr _ _ = unreachable ("Select with block, unexpected argument: " ++ show expr)+++interpretArguments :: [(Variable, Expression)] -> InterpretationEnvIO [(T.Text, NGLessObject)]+interpretArguments args =+    forM args $ \(Variable v, e) -> do+        e' <- interpretTopValue e+        return (v, e')++lookupBlockVar :: T.Text -> BlockVariables -> Maybe NGLessObject+lookupBlockVar n' (BlockVariables1 n v)+    | n == n' = Just v+    | otherwise = Nothing++updateBlockVar (BlockVariables1 n _) n' v'+    | n /= n' = throwShouldNotOccur ("only assignments to block variable are possible [assigning to '"++show n'++"']")+    | otherwise = return $! BlockVariables1 n v'++interpretBlock :: BlockVariables -> [Expression] -> InterpretationROEnv BlockResult+interpretBlock vs [] = return (BlockResult BlockOk vs)+interpretBlock vs (e:es) = do+    r <- interpretBlock1 vs e+    case blockStatus r of+        BlockOk -> interpretBlock (blockValues r) es+        _ -> return r++interpretBlock1 :: BlockVariables -> Expression -> InterpretationROEnv BlockResult+interpretBlock1 vs (Optimized (LenThresholdDiscard (Variable v) bop thresh)) = case lookupBlockVar v vs of+        Just (NGOShortRead r) -> do+            let status = if binInt bop (srLength r) thresh+                    then BlockDiscarded+                    else BlockOk+            return (BlockResult status vs)+        _ -> throwShouldNotOccur ("Variable name not found in optimized processing " ++ show v)+    where+        binInt :: BOp -> Int -> Int -> Bool+        binInt BOpLT a b = a < b+        binInt BOpGT a b = a > b+        binInt BOpLTE a b = a <= b+        binInt BOpGTE a b = a >= b+        binInt _ _ _ = error "This is impossible: the optimized transformation should ensure this case never exists"+interpretBlock1 vs (Optimized (SubstrimReassign (Variable v) mq)) = case lookupBlockVar v vs  of+        Just (NGOShortRead r) -> do+            let nv = NGOShortRead $! substrim mq r+            vs' <- updateBlockVar vs v nv+            return $! BlockResult BlockOk vs'+        _ -> throwShouldNotOccur ("Variable name not found in optimized processing " ++ show v)+interpretBlock1 vs (Assignment (Variable n) val) = do+    val' <- interpretBlockExpr vs val+    vs' <- updateBlockVar vs n val'+    return $ BlockResult BlockOk vs'+interpretBlock1 vs Discard = return (BlockResult BlockDiscarded vs)+interpretBlock1 vs Continue = return (BlockResult BlockContinued vs)+interpretBlock1 vs (Condition c ifT ifF) = do+    v' <- interpretBlockExpr vs c >>= \case+                    NGOBool c' -> return c'+                    _ -> throwShouldNotOccur "Wrong type for condition (Interpret.hs:interpretBlock1)"+    interpretBlock1 vs (if v' then ifT else ifF)+interpretBlock1 vs (Sequence expr) = interpretBlock vs expr -- interpret [expr]+interpretBlock1 vs x = unreachable ("interpretBlock1: This should not have happened " ++ show vs ++ " " ++ show x)++interpretBlockExpr :: BlockVariables -> Expression -> InterpretationROEnv NGLessObject+interpretBlockExpr vs val = local (\(NGLInterpretEnv mods (VariableMapGlobal sm)) -> (NGLInterpretEnv mods (VariableMapBlock vs sm))) (interpretPreProcessExpr val)++interpretPreProcessExpr :: Expression -> InterpretationROEnv NGLessObject+interpretPreProcessExpr (FunctionCall (FuncName "substrim") var args _) = do+    r <- interpretExpr var >>= \case+                        NGOShortRead r -> return r+                        _ -> throwShouldNotOccur "Wrong type in Interpret.hs:interpretExpr"+    args' <- forM args $ \(Variable v, e) -> do+        e' <- interpretExpr e+        return (v, e')+    mq <- fromInteger <$> lookupIntegerOrScriptErrorDef (return 0) "substrim argument" "min_quality" args'+    return . NGOShortRead $ substrim mq r+interpretPreProcessExpr (FunctionCall (FuncName "endstrim") var args _) = do+    r <- interpretExpr var >>= \case+                        NGOShortRead r -> return r+                        _ -> throwShouldNotOccur "Wrong type in Interpret.hs:interpretExpr"+    args' <- forM args $ \(Variable v, e) -> do+        e' <- interpretExpr e+        return (v, e')+    mq <- fromInteger <$> lookupIntegerOrScriptErrorDef (return 0) "endstrim argument" "min_quality" args'+    ends <- lookupSymbolOrScriptErrorDef (return "both") "endstrim argument" "from_ends" args'+    ends' <- case ends of+        "both" -> return EndstrimBoth+        "3" -> return Endstrim3+        "5" -> return Endstrim5+        other -> throwScriptError ("Illegal argument for `from_ends`: "++show other)+    return . NGOShortRead $ endstrim ends' mq r+interpretPreProcessExpr (FunctionCall (FuncName "smoothtrim") var args _) = do+    r <- interpretExpr var >>= \case+                        NGOShortRead r -> return r+                        _ -> throwShouldNotOccur "Wrong type in Interpret.hs:interpretExpr"+    args' <- forM args $ \(Variable v, e) -> do+        e' <- interpretExpr e+        return (v, e')+    mq <- fromInteger <$> lookupIntegerOrScriptErrorDef (return 0) "smoothtrim argument" "min_quality" args'+    w <- fromInteger <$> lookupIntegerOrScriptErrorDef (return 0) "smoothtrim argument" "window" args'+    return . NGOShortRead $ smoothtrim w mq r++interpretPreProcessExpr expr = interpretExpr expr++_evalUnary :: UOp -> NGLessObject -> Either NGError NGLessObject+_evalUnary UOpMinus (NGOInteger n) = return $ NGOInteger (-n)+_evalUnary UOpLen (NGOShortRead r) = return $ NGOInteger . toInteger $ srLength r+_evalUnary UOpLen (NGOList elems) = return $ NGOInteger . toInteger $ length elems+_evalUnary UOpNot (NGOBool v) = return $ NGOBool (not v)+_evalUnary op v = nglTypeError ("invalid unary operation ("++show op++") on value " ++ show v)++_evalIndex :: NGLessObject -> [Maybe NGLessObject] -> Either NGError NGLessObject+_evalIndex (NGOList elems) [Just (NGOInteger ix)] = note (NGError ScriptError errmsg) $ atMay elems (fromInteger ix)+    where errmsg = "Accessing element "++show ix ++ " in list of size "++show (length elems) ++ "."+_evalIndex sr index@[Just (NGOInteger a)] = _evalIndex sr $ Just (NGOInteger (a + 1)) : index+_evalIndex (NGOShortRead sr) [Just (NGOInteger s), Nothing] = let s' = fromInteger s in+    return . NGOShortRead $ srSlice s' (srLength sr - s') sr+_evalIndex (NGOShortRead sr) [Nothing, Just (NGOInteger e)] =+    return . NGOShortRead $ srSlice 0 (fromInteger e) sr+_evalIndex (NGOShortRead sr) [Just (NGOInteger s), Just (NGOInteger e)] =+    return . NGOShortRead $ srSlice (fromInteger s) (fromInteger $ e - s) sr+_evalIndex _ _ = nglTypeError ("_evalIndex: invalid operation" :: String)+
+ NGLess/Interpretation/Count.hs view
@@ -0,0 +1,971 @@+{- Copyright 2015-2020 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts, CPP, TypeApplications #-}+{-# OPTIONS_GHC -fno-full-laziness #-}+module Interpretation.Count+    ( executeCount+    , executeCountCheck+    , Annotator(..)+    , CountOpts(..)+    , AnnotationMode(..)+    , AnnotationIntersectionMode(..)+    , MMMethod(..)+    , NMode(..)+    , StrandMode(..)+    , annotationRule+    , loadAnnotator+    , loadFunctionalMap+    , performCount+    , RSV.RefSeqInfo(..)+#ifdef IS_BUILDING_TEST+    , AnnotationInfo(..)+#endif+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import qualified Data.Vector.Algorithms.Intro as VA++import qualified Data.IntervalIntMap as IM+import qualified Data.Map.Strict as M+import qualified Data.Set as S++import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Algorithms.Async as CAlg+import qualified Data.Conduit.Algorithms.Utils as CAlg+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import           Data.Conduit ((.|))+import           Data.Strict.Tuple (Pair(..))+import           Control.Monad (when, unless, forM, forM_, foldM)+import           Foreign.Storable (Storable(..))+import           Foreign.Ptr (castPtr)+import           Control.Monad.Primitive (PrimMonad(..))+++import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class   (liftIO)+import Data.List                (foldl', sort, sortOn)+import GHC.Conc                 (getNumCapabilities)+import Control.DeepSeq          (NFData(..))+import Control.Error            (note)+import Control.Applicative      ((<|>))+import Data.Maybe++import Data.Convertible         (convert)++import Data.GFF+import Data.Sam (SamLine(..), isSamHeaderString, samLength, isAligned, isPositive, readSamGroupsC')+import FileManagement (makeNGLTempFile, expandPath)+import NGLess.NGLEnvironment+import ReferenceDatabases+import NGLess.NGError+import FileOrStream+import Language+import Output+import NGLess++import Utils.Utils+import Utils.Vector+import Utils.Conduit+import Utils.Suggestion+import qualified Utils.IntGroups as IG+import qualified Interpretation.Count.RefSeqInfoVector as RSV++#ifndef WINDOWS+import Data.Double.Conversion.ByteString (toShortest)+#else+-- On Windows, double-conversion is problematic, so fall back on a basic+-- implementation+-- See https://github.com/bos/double-conversion/issues/7+toShortest :: Double -> B.ByteString+toShortest = B8.pack . show+#endif++{- Implementation of count()+ -+ - The main function is performCount which loops over mapped read groups+ - annotating them with an Annotator. At a high level this code does:+ -+ - annotators <- loadAnnotators opts+ - readgroups <- loadReadGroups inputSAMFile+ - annotated <- forM annotators $ \ann ->+ -                  forM readgroups $ \rg ->+ -                      annotate ann rg+ - final <- forM annotated (normalize opts)+ -+ - While this is simple, the actual code is much more complex for efficiency+ - and because annotation of read groups has a lot of complicated subcases. One+ - particularly optimization is that the annotations are done by mapping to+ - integer indices. While this is much more error prone than using the strings+ - directly, it proved a massive speed-up in computation and memory usage.+ -+ - There are three annotation modes:+ -+ -   1. seqname+ -   2. GFF-based+ -   3. MOCAT-style "gene name" -> "feature"+ -}++data AnnotationInfo = AnnotationInfo !GffStrand !Int+    deriving (Eq)++instance NFData AnnotationInfo where+    rnf (AnnotationInfo !_ !_) = ()+++instance Storable AnnotationInfo where+    sizeOf _ = 2 * sizeOf (undefined :: Int)+    alignment _ = alignment (undefined :: Int)+    poke ptr (AnnotationInfo s ix) =+        let+            ptr' = castPtr ptr+        in do+            pokeElemOff @Int ptr' 0 (fromEnum s)+            pokeElemOff @Int ptr' 1 (fromEnum ix)++    peek ptr =+        let+            ptr' = castPtr ptr+        in do+            s <- peekElemOff @Int ptr' 0+            ix <- peekElemOff @Int ptr' 1+            return $! AnnotationInfo+                    (toEnum s)+                    (toEnum ix)++++type GffIMMap = IM.IntervalIntMap AnnotationInfo+type GffIMMapAcc = IM.IntervalIntMapAccumulator (PrimState IO) AnnotationInfo++-- GFFAnnotationMap maps from `References` (e.g., chromosomes) to positions to (strand/feature-id)+type GFFAnnotationMap = M.Map BS.ShortByteString GffIMMap++type GFFAnnotationMapAcc = M.Map BS.ShortByteString GffIMMapAcc+type AnnotationRule = GffIMMap -> GffStrand -> IM.Interval -> [AnnotationInfo]++-- This implements MOCAT-style "gene name" -> "feature" annotation+type GeneMapAnnotation = M.Map B.ByteString [Int]++data MMMethod = MMCountAll | MM1OverN | MMDist1 | MMUniqueOnly+    deriving (Eq)++data NMode = NMRaw | NMNormed | NMScaled | NMFpkm+    deriving (Eq)++data StrandMode = SMBoth | SMSense | SMAntisense+    deriving (Eq)++minDouble :: Double+minDouble = (2.0 :: Double) ^^ fst (floatRange (1.0 :: Double))++data CountOpts =+    CountOpts+    { optFeatures :: [B.ByteString] -- ^ list of features to condider+    , optSubFeatures :: Maybe [B.ByteString] -- ^ list of sub-features to condider+    , optAnnotationMode :: !AnnotationMode+    , optIntersectMode :: AnnotationRule+    , optStrandMode :: !StrandMode+    , optMinCount :: !Double+    , optMMMethod :: !MMMethod+    , optDelim :: !B.ByteString+    , optNormMode :: !NMode+    , optIncludeMinus1 :: !Bool+    }++data AnnotationMode = AnnotateSeqName | AnnotateGFF FilePath | AnnotateFunctionalMap FilePath+    deriving (Eq)++data Annotator =+                SeqNameAnnotator (Maybe RSV.RefSeqInfoVector) -- ^ Just annotate by sequence names+                | GFFAnnotator GFFAnnotationMap (V.Vector BS.ShortByteString) !(VU.Vector Double) -- ^ map reference regions to features + feature sizes+                | GeneMapAnnotator B.ByteString GeneMapAnnotation RSV.RefSeqInfoVector -- ^ map reference (gene names) to indices, indexing into the vector of refseqinfo+instance NFData Annotator where+    rnf (SeqNameAnnotator m) = rnf m+    rnf (GFFAnnotator amap headers szmap) = amap `seq` rnf headers `seq` rnf szmap -- amap is already strict+    rnf (GeneMapAnnotator !_ amap szmap) = rnf amap `seq` rnf szmap++annotateReadGroup :: CountOpts -> Annotator -> [SamLine] -> NGLess [Int]+annotateReadGroup opts ann samlines = add1 . listNub <$> case ann of+        SeqNameAnnotator Nothing -> throwShouldNotOccur "Incomplete annotator used"+        SeqNameAnnotator (Just szmap) -> mapMaybeM (getID szmap) samlines+        GFFAnnotator amap _ _ -> return . concatMap (annotateSamLineGFF opts amap) $ samlines+        GeneMapAnnotator _ amap _ -> return . concatMap (mapAnnotation1 amap) $ samlines+    where+        -- this is because "unmatched" is -1+        add1 [] = [0]+        add1 vs = (+ 1) <$> vs+        getID :: RSV.RefSeqInfoVector -> SamLine -> NGLess (Maybe Int)+        getID szmap sr@SamLine{samRName = rname }+            | isAligned sr = case RSV.lookup szmap rname of+                    Nothing -> throwDataError ("Unknown sequence id: " ++ show rname)+                    ix -> return ix+        getID _ _ = Right Nothing+        mapAnnotation1 :: GeneMapAnnotation ->  SamLine -> [Int]+        mapAnnotation1 amap samline = fromMaybe [] $ M.lookup (samRName samline) amap++annSizeAt :: Annotator -> Int -> NGLess Double+annSizeAt _ 0 = return 0.0+annSizeAt (SeqNameAnnotator Nothing) _ = throwShouldNotOccur "Using unloaded annotator"+annSizeAt ann ix+    | ix >= annSize ann = throwShouldNotOccur "Looking up size of inexistent index counts/annSizeAt"+annSizeAt (SeqNameAnnotator (Just vec)) ix = return $! RSV.retrieveSize vec (ix - 1)+annSizeAt (GFFAnnotator _ _ szmap) ix = return $! szmap VU.! (ix - 1)+annSizeAt (GeneMapAnnotator _ _ vec) ix = return $! RSV.retrieveSize vec (ix - 1)++annEnumerate :: Annotator -> [(B.ByteString, Int)]+annEnumerate (SeqNameAnnotator Nothing)   = error "Using unfinished annotator"+annEnumerate (SeqNameAnnotator (Just ix)) = ("-1",0):enumerateRSVector ix+annEnumerate (GeneMapAnnotator tag _ ix) = let+                            addTag+                                | B.null tag = id+                                | otherwise = \(name, v) -> (B.concat [tag, ":", name], v)+                        in addTag <$> ("-1",0):enumerateRSVector ix+annEnumerate (GFFAnnotator _ headers _)   = zip ("-1":(map BS.fromShort $ V.toList headers)) [0..]+enumerateRSVector rfv = [(RSV.retrieveName rfv i, i + 1) | i <- [0.. RSV.length rfv - 1]]++-- Number of elements+annSize :: Annotator -> Int+annSize (SeqNameAnnotator Nothing) = error "annSize (SeqNameAnnotator Nothing) is illegal"+annSize (SeqNameAnnotator (Just rfv)) = RSV.length rfv + 1+annSize (GeneMapAnnotator _ _ rfv) = RSV.length rfv + 1+annSize (GFFAnnotator _ _ szmap) = VU.length szmap + 1++{- We define the type AnnotationIntersectionMode mainly to facilitate tests,+ - which depend on being able to write code such as+ -+ -      annotationRule IntersectUnion+ -}+data AnnotationIntersectionMode = IntersectUnion | IntersectStrict | IntersectNonEmpty+    deriving (Eq, Show)+++annotationRule :: AnnotationIntersectionMode -> AnnotationRule+annotationRule IntersectUnion = union+annotationRule IntersectStrict = intersection_strict+annotationRule IntersectNonEmpty = intersection_non_empty++parseOptions :: Maybe (Maybe T.Text) -> KwArgsValues -> NGLessIO CountOpts+parseOptions mappedref args = do+    when ("strand" `elem` (map fst args) && "sense" `elem` (map fst args)) $+        (case lookup "original_lno" args of+            Just (NGOInteger lno) -> flip outputListLno (Just $ fromIntegral lno)+            _ -> outputListLno') WarningOutput ["Both `strand` and `sense` arguments passed to count() function. The `strand` argument will be ignored.\n"]+    minCount <- lookupIntegerOrScriptErrorDef (return 0) "count argument parsing" "min" args+    method <- decodeSymbolOrError "multiple argument in count() function"+                    [("1overN", MM1OverN)+                    ,("dist1", MMDist1)+                    ,("all1", MMCountAll)+                    ,("unique_only", MMUniqueOnly)+                    ] =<< lookupSymbolOrScriptErrorDef (return "dist1")+                                    "multiple argument to count " "multiple" args+    strand_specific <- lookupBoolOrScriptErrorDef (return False) "count function" "strand" args+    smode <- decodeSymbolOrError "strand argument to count() function"+                    [("both", SMBoth)+                    ,("sense", SMSense)+                    ,("antisense", SMAntisense)+                    ] =<< lookupSymbolOrScriptErrorDef (return (if strand_specific then "sense" else "both")) "count function" "sense" args+    include_minus1 <- lookupBoolOrScriptErrorDef defaultMinus1 "count function" "include_minus1" args+    mocatMap <- lookupFilePath "functional_map argument to count()" "functional_map" args+    gffFile <- lookupFilePath "gff_file argument to count()" "gff_file" args+    discardZeros <- lookupBoolOrScriptErrorDef (return False) "count argument parsing" "discard_zeros" args+    m <- fmap annotationRule $ decodeSymbolOrError "mode argument to count"+                    [("union", IntersectUnion)+                    ,("intersection_strict", IntersectStrict)+                    ,("intersection_non_empty", IntersectNonEmpty)+                    ] =<< lookupSymbolOrScriptErrorDef (return "union") "mode argument to count" "mode" args+    delim <- T.encodeUtf8 <$> lookupStringOrScriptErrorDef (return "\t") "count hidden argument (should always be valid)" "__delim" args+    when ("norm" `elem` (fst <$> args) && "normalization" `elem` (fst <$> args)) $+        outputListLno' WarningOutput ["In count() function: both `norm` and `normalization` used. `norm` is semi-deprecated and will be ignored in favor of `normalization`"]+    normSize <- lookupBoolOrScriptErrorDef (return False) "count function" "norm" args+    normMode <- decodeSymbolOrError "normalization option"+                        [("raw", NMRaw)+                        ,("normed", NMNormed)+                        ,("scaled", NMScaled)+                        ,("fpkm", NMFpkm)] =<< lookupSymbolOrScriptErrorDef+                                                    (return $! if normSize then "normed" else "raw") "count function" "normalization" args+    fs <- case lookup "features" args of+        Nothing -> return ["gene"]+        Just (NGOString f) -> return [f]+        Just (NGOList feats') -> mapM (stringOrTypeError "count features argument") feats'+        _ -> throwShouldNotOccur "executeAnnotation: TYPE ERROR"+    subfeatures <- case lookup "subfeatures" args of+        Nothing -> return Nothing+        Just (NGOString sf) -> return $ Just [sf]+        Just (NGOList subfeats') -> Just <$> mapM (stringOrTypeError "count subfeatures argument") subfeats'+        _ -> throwShouldNotOccur "executeAnnotation: TYPE ERROR"+    refinfo <- case lookup "reference" args of+        Nothing -> return mappedref+        Just val -> Just . Just <$> stringOrTypeError "reference for count()" val+    let features = map (B8.pack . T.unpack) fs+        parseAnnotationMode :: [B.ByteString] -> Maybe (Maybe T.Text) -> Maybe FilePath -> Maybe FilePath -> NGLessIO AnnotationMode+        parseAnnotationMode _ _ (Just _) (Just _) =+            throwScriptError "Cannot simultaneously pass a gff_file and an annotation_file for count() function"+        parseAnnotationMode ["seqname"] _ _ _ = return AnnotateSeqName+        parseAnnotationMode _ _ (Just r) _ = return (AnnotateFunctionalMap r)+        parseAnnotationMode _ _ _ (Just g) = return (AnnotateGFF g)+        parseAnnotationMode _ (Just (Just ref)) Nothing Nothing = do+            outputListLno' InfoOutput ["Annotate with reference: ", show ref]+            ReferenceFilePaths _ mgffpath mfuncpath <- ensureDataPresent ref+            case (mgffpath, mfuncpath) of+                (Just gffpath, Nothing) -> return $! AnnotateGFF gffpath+                (Nothing, Just fmpath) -> return $! AnnotateFunctionalMap fmpath+                (Nothing, Nothing) -> throwScriptError ("Could not find annotation file for '" ++ T.unpack ref ++ "'")+                (Just _, Just _) -> throwDataError ("Reference " ++ T.unpack ref ++ " has both a GFF and a functional map file. Cannot figure out what to do.")+        parseAnnotationMode _ Nothing _ _ = return AnnotateSeqName -- placeholder, but will only happen in __check_count call+        parseAnnotationMode _ _ _ _ =+            throwScriptError ("For counting, you must do one of\n" +++                              "1. use seqname mode\n" +++                              "2. pass in a GFF file using the argument 'gff_file'\n" +++                              "3. pass in a gene map using the argument 'functional_map'")+++    amode <- parseAnnotationMode features refinfo mocatMap gffFile+    return $! CountOpts+            { optFeatures = features+            , optSubFeatures = map (B8.pack . T.unpack) <$> subfeatures+            , optAnnotationMode = amode+            , optIntersectMode = m+            , optStrandMode = smode+            , optMinCount = if discardZeros+                                then minDouble+                                else fromInteger minCount+            , optMMMethod = method+            , optDelim = delim+            , optNormMode = normMode+            , optIncludeMinus1 = include_minus1+            }++executeCount :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeCount (NGOList e) args = NGOList <$> mapM (`executeCount` args) e+executeCount (NGOMappedReadSet rname istream mappedref) args = do+    opts <- parseOptions (Just mappedref) args+    annotators <- loadAnnotator (optAnnotationMode opts) opts+    NGOCounts . File <$> performCount istream rname annotators opts+executeCount err _ = throwScriptError ("Invalid Type. Should be used NGOList or NGOAnnotatedSet but type was: " ++ show err)++executeCountCheck :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeCountCheck _ kwargs = do+    opts <- parseOptions Nothing kwargs+    lno <- lookupIntegerOrScriptErrorDef (return 0) "hidden lno argument" "original_lno" kwargs+    case optAnnotationMode opts of+        AnnotateFunctionalMap fname -> do+            columns <- C.runConduit $+                    conduitPossiblyCompressedFile fname+                    .| linesC+                    .| CAlg.enumerateC+                    .| (lastCommentOrHeader fname True >>= \case+                            Nothing -> return []+                            Just (_,ByteLine line) -> return $ B8.split '\t' line)+            let missing = [f | f <- optFeatures opts, f `notElem` columns]+            case missing of+                [] -> return ()+                ms -> do+                    let errormsg = [+                                "In call to count() [line ",+                                show lno,+                                "], missing features:"+                                ] ++ concat [[" ", B8.unpack f]  | f <- ms]+                    throwDataError (concat errormsg)+        _ -> return ()+    return NGOVoid++-- | The include_minus1 argument defaulted to False up to version 0.5. Now, it+-- defaults to true as it seems to be what most users expect.+defaultMinus1 :: NGLessIO Bool+defaultMinus1 = do+    v <- ngleVersion <$> nglEnvironment+    return $! v > NGLVersion 0 5++loadAnnotator :: AnnotationMode -> CountOpts -> NGLessIO [Annotator]+loadAnnotator AnnotateSeqName _ = return [SeqNameAnnotator Nothing]+loadAnnotator (AnnotateGFF gf) opts = loadGFF gf opts+loadAnnotator (AnnotateFunctionalMap mm) opts = loadFunctionalMap mm (optFeatures opts)+++-- First pass over the data+performCount1Pass :: MMMethod+                        -> VUM.IOVector Double -- ^ counts vector. Will be modified+                        -> C.ConduitT (VU.Vector Int, IG.IntGroups) C.Void NGLessIO [IG.IntGroups]+performCount1Pass MMUniqueOnly mcounts = do+    C.awaitForever $ \(singles, _) -> liftIO (incrementAll mcounts singles)+    return []+performCount1Pass MMCountAll mcounts = do+    C.awaitForever $ \(singles, mms) -> liftIO $ do+        incrementAll mcounts singles+        IG.forM_ mms (incrementAllV mcounts)+    return []+performCount1Pass MM1OverN mcounts = do+    C.awaitForever $ \(singles, mms) -> liftIO $ do+        incrementAll mcounts singles+        IG.forM_ mms (increment1OverN mcounts)+    return []+performCount1Pass MMDist1 mcounts = loop []+    where+        loop :: [IG.IntGroups] -> C.ConduitT (VU.Vector Int, IG.IntGroups) C.Void NGLessIO [IG.IntGroups]+        loop acc = C.await >>= \case+            Nothing -> return acc+            Just (singles, mms) ->  do+                    liftIO $ incrementAll mcounts singles+                    loop $ if not (IG.null mms)+                                then mms:acc+                                else acc++-- | This is a version of C.sequenceSinks which optimizes the case where a+-- single element is passed (it makes a small, but noticeable difference in+-- benchmarking)+sequenceSinks :: (Monad m) => [C.ConduitT a C.Void m b] -> C.ConduitT a C.Void m [b]+sequenceSinks [s] = (:[]) <$> s+sequenceSinks ss = C.sequenceSinks ss++annSamHeaderParser :: Int -> [Annotator] -> CountOpts -> C.ConduitT ByteLine C.Void NGLessIO [Annotator]+annSamHeaderParser mapthreads anns opts = lineGroups .| sequenceSinks (map annSamHeaderParser1 anns)+    where+        annSamHeaderParser1 (SeqNameAnnotator Nothing) = do+            rfvm <- liftIO RSV.newRefSeqInfoVector+            CAlg.asyncMapEitherC mapthreads (\(!vi, v) -> V.imapM (\ix ell -> seqNameSize (vi*32768+ix, ell)) v)+                .| CL.mapM_ (\v -> liftIO $+                                    V.forM_ v $ \(RSV.RefSeqInfo n val) ->+                                        RSV.insert rfvm n val)+            vsorted <- liftIO $ do+                RSV.sort rfvm+                RSV.unsafeFreeze rfvm+            return $! SeqNameAnnotator (Just vsorted)+        annSamHeaderParser1 (GeneMapAnnotator tag gmap isizes)+            | optNormMode opts == NMNormed = do+                msizes <- liftIO $ RSV.unsafeThaw isizes+                CAlg.asyncMapEitherC mapthreads (\(!vi,headers) -> flattenVs <$> V.imapM (\ix ell -> indexUpdates gmap (vi*32768+ix, ell)) headers)+                    .| CL.mapM_ (liftIO . updateSizes msizes)+                GeneMapAnnotator tag gmap <$> liftIO (RSV.unsafeFreeze msizes)+        annSamHeaderParser1 ann = CC.sinkNull >> return ann+        lineGroups = CL.filter (B.isPrefixOf "@SQ\tSN:" . unwrapByteLine)+                    .| CC.conduitVector 32768+                    .| CAlg.enumerateC+        flattenVs :: VU.Unbox a => V.Vector [a] -> VU.Vector a+        flattenVs chunks = VU.unfoldr getNext (0,[])+            where+                getNext (!vi, v:vs) = Just (v, (vi,vs))+                getNext (vi,[])+                    | vi >= V.length chunks = Nothing+                    | otherwise = getNext (vi + 1, chunks V.! vi)++        updateSizes :: RSV.RefSeqInfoVectorMutable -> VU.Vector (Int,Double) -> IO ()+        updateSizes msizes updates =+            VU.forM_ updates $ \(ix,val) -> do+                cur <- RSV.retrieveSizeIO msizes ix+                RSV.writeSizeIO msizes ix (cur + val)++        indexUpdates :: GeneMapAnnotation -> (Int, ByteLine) -> NGLess [(Int, Double)]+        indexUpdates gmap line = do+            RSV.RefSeqInfo seqid val <- seqNameSize line+            let ixs = fromMaybe [] $ M.lookup seqid gmap+            return [(ix,val) | ix <- ixs]+        seqNameSize :: (Int, ByteLine) -> NGLess RSV.RefSeqInfo+        seqNameSize (n, ByteLine h) = case B8.split '\t' h of+                [_,seqname,sizestr] -> case B8.readInt (B.drop 3 sizestr) of+                    Just (size, _) -> return $! RSV.RefSeqInfo (B.drop 3 seqname) (convert size)+                    Nothing -> throwDataError ("Could not parse sequence length in header (line: " ++ show n ++ ")")+                _ -> throwDataError ("SAM file does not contain the right number of tokens (line: " ++ show n ++ ")")+++listNub :: (Ord a) => [a] -> [a]+listNub [] = []+listNub x@[_] = x+listNub x@[a,b]+    | a == b = [a]+    | otherwise = x+listNub other = S.toList . S.fromList $ other+++-- Takes a vector of [Int] and splits into singletons (which can be represented+-- as `VU.Vector Int` and the rest (represented as `IG.IntGroups`)+splitSingletons :: MMMethod -> V.Vector [Int] -> (VU.Vector Int, IG.IntGroups)+splitSingletons method values = (singles, mms)+    where+        singles = VU.create $ do+            v <- VU.unsafeThaw $ VU.unfoldr getsingle1 0+            -- We want to maximize the work performed in this function as it is+            -- being done in a worker thread:+            -- sorting is completely unnecessary for correctness, but improves+            -- cache performance as close-by indices will be accessed together+            -- when this data is processed in the main thread.+            VA.sort v++            return v+        getsingle1 :: Int -> Maybe (Int, Int)+        getsingle1 ix = do+            vs <- values V.!? ix+            case vs of+                [v] -> return (v, ix + 1)+                _ -> getsingle1 (ix + 1)+        mms -- if we are only using unique hits, then we do not need to care about non-singletons+            | method == MMUniqueOnly = IG.empty+            | otherwise = IG.fromList (filter larger1 (V.toList values))+        larger1 []  = False+        larger1 [_] = False+        larger1 _   = True+++performCount :: FileOrStream -> T.Text -> [Annotator] -> CountOpts -> NGLessIO FilePath+performCount istream gname annotators0 opts = do+    outputListLno' TraceOutput ["Starting count..."]+    numCapabilities <- liftIO getNumCapabilities+    let mapthreads = max 1 (numCapabilities - 1)+        method = optMMMethod opts+        delim = optDelim opts+        (samfp, samStream) = asSamStream istream+    (toDistribute, mcounts, annotators) <- C.runConduit $+        samStream+            .| do+                annotators <-+                    CC.takeWhileE (isSamHeaderString . unwrapByteLine)+                        .| CC.concat+                        .| annSamHeaderParser mapthreads annotators0 opts+                lift $ outputListLno' TraceOutput ["Loaded headers. Starting parsing/distribution."]+                mcounts <- forM annotators $ \ann -> do+                    let n_entries = annSize ann+                    liftIO $ VUM.replicate n_entries (0.0 :: Double)+                toDistribute <-+                    readSamGroupsC' mapthreads True+                        .| CAlg.asyncMapEitherC mapthreads (\samgroup -> forM annotators $ \ann -> do+                                                                    annotated <- V.mapM (annotateReadGroup opts ann) samgroup+                                                                    return $ splitSingletons method annotated)+                        .| sequenceSinks [CL.map (!! i) .| performCount1Pass method mc | (i,mc) <- zip [0..] mcounts]+                return (toDistribute, mcounts, annotators)++    results <- distributeScaleCounts (optNormMode opts) (optMMMethod opts) annotators mcounts toDistribute+    makeNGLTempFile samfp "counts." "txt" $ \hout -> liftIO $ do+        BL.hPut hout (BL.fromChunks [delim, T.encodeUtf8 gname, "\n"])+        let maybeSkipM1+                | optIncludeMinus1 opts = id+                | otherwise = tail+        forM_ (zip annotators results) $ \(ann,result) ->+            forM_ (maybeSkipM1 $ annEnumerate ann) $ \(h,i) -> do+                let nlB :: BB.Builder+                    nlB = BB.word8 10+                    tabB :: BB.Builder+                    tabB = BB.word8 9+                    v = (VU.!) result i+                when (v >= optMinCount opts) $+                    BB.hPutBuilder hout $ mconcat [BB.byteString h, tabB, BB.byteString (toShortest v), nlB]+++distributeScaleCounts :: NMode -> MMMethod -> [Annotator] -> [VUM.IOVector Double] -> [[IG.IntGroups]] -> NGLessIO [VU.Vector Double]+distributeScaleCounts NMRaw mmmethod _ counts _+    | mmmethod /= MMDist1 = liftIO $ mapM VU.unsafeFreeze counts+distributeScaleCounts norm mmmethod annotators mcountss toDistribute =+    forM (zip3 annotators mcountss toDistribute) $ \(ann, mcounts, indices) -> do+        let n_entries = annSize ann+        sizes <- liftIO $ VUM.new n_entries+        forM_ [0 .. n_entries - 1] $ \i -> do+            s <- runNGLess $ annSizeAt ann i+            liftIO $ VUM.write sizes i s+        redistribute mmmethod mcounts sizes indices+        normalizeCounts norm mcounts sizes+        liftIO $ VU.unsafeFreeze mcounts+++-- redistributes the multiple mappers+redistribute :: MMMethod -> VUM.IOVector Double -> VUM.IOVector Double -> [IG.IntGroups] -> NGLessIO ()+redistribute MMDist1 ocounts sizes indices = do+    outputListLno' TraceOutput ["Counts (second pass)..."]+    fractCounts' <- liftIO $ VUM.clone ocounts+    normalizeCounts NMNormed fractCounts' sizes+    fractCounts <- liftIO $ VU.unsafeFreeze fractCounts'+    forM_ indices $ \vss -> IG.forM_ vss $ \vs -> do+        let cs = VU.map (VU.unsafeIndex fractCounts) vs+            cs_sum = sum (VU.toList cs)+            n_cs = convert (VU.length cs)+            adjust :: Double -> Double+            adjust = if cs_sum > 0.0+                        then (/ cs_sum)+                        else const  (1.0 / n_cs)+        forM_ (zip (VU.toList vs) (VU.toList cs)) $ \(v,c) ->+            liftIO $ unsafeIncrement' ocounts v (adjust c)+redistribute _ _ _ _ = return ()++incrementAll :: VUM.IOVector Double -> VU.Vector Int -> IO ()+incrementAll counts vis = VU.forM_ vis $ \vi -> unsafeIncrement counts vi++incrementAllV :: VUM.IOVector Double -> VU.Vector Int -> IO ()+incrementAllV counts vis = VU.forM_ vis $ \vi -> unsafeIncrement counts vi++increment1OverN :: VUM.IOVector Double -> VU.Vector Int -> IO ()+increment1OverN counts vis = VU.forM_ vis $ \vi -> unsafeIncrement' counts vi oneOverN+    where+        oneOverN :: Double+        oneOverN = 1.0 / convert (VU.length vis)++normalizeCounts :: NMode -> VUM.IOVector Double -> VUM.IOVector Double -> NGLessIO ()+normalizeCounts NMRaw _ _ = return ()+normalizeCounts NMNormed counts sizes = do+        let n = VUM.length counts+            n' = VUM.length sizes+        unless (n == n') $+            throwShouldNotOccur ("Counts vector is of size " ++ show n ++ ", but sizes is of size " ++ show n')+        liftIO $ forM_ [0 .. n - 1] $ \i -> do+            s <- VUM.read sizes i+            when (s > 0) $+                VUM.unsafeModify counts (/ s) i+normalizeCounts nmethod counts sizes+    | nmethod `elem` [NMScaled, NMFpkm] = do+        -- count vectors always include a -1 at this point (it is+        -- ignored in output if the user does not request it, but is+        -- always computed). Thus, we compute the sum without it and do+        -- not normalize it later:+        let totalCounts v = withVector v (VU.sum . VU.tail)+        initial <- totalCounts counts+        normalizeCounts NMNormed counts sizes+        afternorm <- totalCounts counts+        let factor+                | nmethod == NMScaled = initial / afternorm+                | otherwise = 1.0e9 / initial --- 1e6 [million fragments] * 1e3 [kilo basepairs] = 1e9+        liftIO $ forM_ [1.. VUM.length counts - 1] (VUM.unsafeModify counts (* factor))+    | otherwise = error "This should be unreachable code [normalizeCounts]"++++-- lastCommentOrHeader :: Monad m => C.ConduitT (Int, ByteLine) () m (Maybe (Int, ByteLine))+lastCommentOrHeader fname newAPI = C.await >>= \case+                    Nothing -> return Nothing+                    Just f@(_,ByteLine line) ->+                        if isComment line+                            then lastCommentOrHeader' (Just f)+                            else return (Just f)+    where+        lastCommentOrHeader' prev = C.await >>= \case+                        Nothing -> return prev+                        Just f@(_, ByteLine line)+                            | isComment line ->+                                if newAPI+                                    then lastCommentOrHeader' (Just f)+                                    else do+                                        lift $ outputListLno' WarningOutput versionChangeWarning+                                        C.leftover f+                                        return (Just f)+                            | otherwise -> do+                                C.leftover f+                                return prev+        isComment line+            | B.null line = True+            | otherwise = B8.head line == '#'+        versionChangeWarning =+            ["Loading '", fname, "': found several lines at the top starting with '#'.\n",+             "The interpretation of these changed in NGLess 1.1 (they are now considered comment lines).\n",+             "Using the older version for backwards compatibility.\n"]++{- This object keeps the state for iterating over the lines in the annotation+ - file.+ -}+data LoadFunctionalMapState = LoadFunctionalMapState+                                        !Int -- ^ next free index+                                        !(M.Map B.ByteString [Int]) -- ^ gene -> [feature-ID]+                                        !(M.Map B.ByteString Int) -- ^ feature -> feature-ID++-- Loads MOCAT-style TSV files+loadFunctionalMap :: FilePath -> [B.ByteString] -> NGLessIO [Annotator]+loadFunctionalMap fname [] = throwScriptError ("Loading annotation file '"++fname++"' but no features requested. This is probably a bug.")+loadFunctionalMap fname columns = do+        -- There are some complications related to sorting the columns indices.+        -- The returned annotators (if more than one) must be ordered by tag so+        -- that we can output correctly sorted TSV files. While loading the+        -- data, however, the code uses the column order in the file for+        -- extracting the columns,+        outputListLno' InfoOutput ["Loading map file ", fname]+        numCapabilities <- liftIO getNumCapabilities+        let mapthreads = max 1 (numCapabilities - 1)+        v <- ngleVersion <$> nglEnvironment+        anns <- C.runConduit $+                    conduitPossiblyCompressedFile fname+                    .| linesC+                    .| CAlg.enumerateC+                    .| (do+                        hline <- lastCommentOrHeader fname (v >= NGLVersion 1 1)+                        (cis,tags) <- case hline of+                            Nothing -> throwDataError ("Empty map file: "++fname)+                            Just (!line_nr, ByteLine header) -> let headers = B8.split '\t' header+                                                    in runNGLess $ lookUpColumns line_nr headers+                        CC.conduitVector 8192+                            .| CAlg.asyncMapEitherC mapthreads (V.mapM (selectColumns cis)) -- after this we have vectors of (<gene name>, [<feature-name>])+                            .| sequenceSinks+                                [finishFunctionalMap (getTag tags c) <$> CL.fold (V.foldl' (inserts1 c)) (LoadFunctionalMapState 0 M.empty M.empty)+                                        | c <- [0 .. length cis - 1]])+        outputListLno' TraceOutput ["Loading of map file '", fname, "' complete"]+        return $! sortOn (\(GeneMapAnnotator tag _ _) -> tag) anns+    where++        finishFunctionalMap :: B.ByteString -> LoadFunctionalMapState -> Annotator+        finishFunctionalMap tag (LoadFunctionalMapState _ gmap namemap) = GeneMapAnnotator+                                                                            tag+                                                                            (reindex gmap namemap)+                                                                            (RSV.fromList [RSV.RefSeqInfo n 0.0 | n <- M.keys namemap])+        reindex :: M.Map B.ByteString [Int] -> M.Map B.ByteString Int -> M.Map B.ByteString [Int]+        reindex gmap namemap = M.map (map (ix2ix VU.!)) gmap+            where+                ix2ix = revnamemap namemap+        inserts1 :: Int -> LoadFunctionalMapState -> (B.ByteString, [[B.ByteString]]) -> LoadFunctionalMapState+        inserts1 c (LoadFunctionalMapState first gmap namemap) (name, ids) = LoadFunctionalMapState first' gmap' namemap'+            where+                (first', namemap', ids') = foldl' insertname (first,namemap,[]) (ids !! c)+                gmap' = M.insert name ids' gmap++                insertname :: (Int, M.Map B.ByteString Int, [Int]) -> B.ByteString -> (Int, M.Map B.ByteString Int, [Int])+                insertname (!next, !curmap, ns') n = case M.lookup n curmap of+                    Just ix -> (next, curmap, ix:ns')+                    Nothing -> (next + 1, M.insert n next curmap, next:ns')+++        lookUpColumns :: Int -> [B.ByteString] -> NGLess ([Int], [B.ByteString])+        lookUpColumns line_nr [] = throwDataError ("Loading functional map file '" ++ fname ++ "' (line " ++ show line_nr ++ "): Header line missing!")+        lookUpColumns _ headers = do+            cis <- mapM (lookUpColumns' $ M.fromList (zip (tail headers) [0..])) columns+            return $ unzip $ sort $ zip cis columns++        lookUpColumns' :: M.Map B.ByteString Int -> B.ByteString -> NGLess Int+        lookUpColumns' colmap col = note notfounderror $ M.lookup col colmap+            where+                notfounderror = NGError DataError errormsg+                errormsg = concat (["Could not find column '", B8.unpack col, "'."]+                                ++ case findSuggestion (T.pack $ B8.unpack col) (map (T.pack . B8.unpack) $ M.keys colmap) of+                                        Just (Suggestion valid reason) -> [" Did you mean '", T.unpack valid, "' (", T.unpack reason, ")?"]+                                        Nothing -> []+                                ++ ["\nAvailable columns are:\n"]+                                ++ ["\t- '"++B8.unpack c ++ "'\n" | c <- M.keys colmap]+                                )+        selectColumns :: [Int] -> (Int, ByteLine) -> NGLess (B.ByteString, [[B.ByteString]])+        selectColumns cols (line_nr, ByteLine line) = case B8.split '\t' line of+                    (gene:mapped) -> (gene,) . splitLines <$> selectIds line_nr cols (zip [0..] mapped)+                    [] -> throwDataError ("Loading functional map file '" ++ fname ++ "' [line " ++ show (line_nr + 1)++ "]: empty line.")++        getTag :: [B.ByteString] -> Int -> B.ByteString+        getTag [_] _ = B.empty+        getTag bs ix = bs !! ix++        splitLines vss = [B8.splitWith (\c -> c ==',' || c == '|') vs | vs <- vss]++        selectIds :: Int -> [Int] -> [(Int, B.ByteString)] -> NGLess [B.ByteString]+        selectIds _ [] _ = return []+        selectIds line_nr fs@(fi:rest) ((ci,v):vs)+            | fi == ci = (v:) <$> selectIds line_nr rest vs+            | otherwise = selectIds line_nr fs vs+        selectIds line_nr _ _ = throwDataError ("Loading functional map file '" ++ fname ++ "' [line " ++ show (line_nr + 1)++ "]: wrong number of columns") -- humans count lines in 1-based systems+++revnamemap :: Ord a => M.Map a Int -> VU.Vector Int+revnamemap namemap = VU.create $ do+                r <- VUM.new (M.size namemap)+                forM_ (zip (M.elems namemap) [0..]) $ uncurry (VUM.write r)+                return r++data IntDoublePair = IntDoublePair {-# UNPACK #-} !Int {-# UNPACK #-} !Double+data GffLoadingState = GffLoadingState+                        !GFFAnnotationMapAcc+                        --  ^ gmap: current annotation map+                        !(M.Map BS.ShortByteString IntDoublePair)+                        --  ^ metamap: str -> int name to ID/feature-size++loadGFF :: FilePath -> CountOpts -> NGLessIO [Annotator]+loadGFF gffFp opts = do+        v <- ngleVersion <$> nglEnvironment+        when (not singleFeature && v <= NGLVersion 0 11) $+            throwScriptError (+                "The handling of multiple features/subfeatures has changed in version 1.0\n" +++                "and we can no longer reproduce the behaviour of NGLess 0.11 and previous\n" +++                "versions.\n\n"+++                "Please update the version declaration at the top of the NGLess script to\n" +++                "get the new output format which uses colons (:) to separate the feature\n" +++                "names (while the old format was a multi-column format).\n\n" +++                "The old format created problems when mixed with collect() and other\n" +++                "functions.")+        outputListLno' TraceOutput ["Loading GFF file '", gffFp, "'..."]+        numCapabilities <- liftIO getNumCapabilities+        let mapthreads = max 1 (numCapabilities - 1)+        partials <- C.runConduit $+                conduitPossiblyCompressedFile gffFp+                    .| linesVC 8192+                    .| CAlg.asyncMapEitherC mapthreads (V.mapM (readGffLine . unwrapByteLine) . V.filter (not . isComment))+                    .| sequenceSinks+                        [CL.foldM (insertgV f sf) (GffLoadingState M.empty M.empty)+                                    |  f <- optFeatures    opts+                                    , sf <- case optSubFeatures opts of+                                                Nothing -> [Nothing]+                                                Just fs -> Just <$> fs]++        outputListLno' TraceOutput ["Loading GFF file '", gffFp, "' complete."]+        mapM finishGffAnnotator partials+    where+        singleFeature+            | length (optFeatures opts) > 1 = False+            | otherwise = case optSubFeatures opts of+                Nothing -> True+                Just [_] -> True+                _ -> False++        isComment (ByteLine line)+            | B.null line = True+            | otherwise = B8.head line == '#'++        insertgV f sf p vs = liftIO $ V.foldM (insertg f sf) p (V.filter ((==f) . gffType) vs)++        -- update GffLoadingState+        insertgV :: B.ByteString -- ^ feature+                        -> Maybe B.ByteString -- ^ subfeature+                        -> GffLoadingState+                        -> V.Vector GffLine+                        -> NGLessIO GffLoadingState+        insertg f sf (GffLoadingState gmap metamap0) gline = do+                    let seqid = BS.toShort $ gffSeqId gline+                    -- We can do it all with a single call to M.alterF, but the+                    -- expectation is that most of the lookups will return+                    -- something and we can avoid allocations+                    (gmap', immap) <- case M.lookup seqid gmap of+                        Just im -> return (gmap, im)+                        Nothing -> do+                            im <- IM.new+                            return (M.insert seqid im gmap, im)+                    let i = IM.Interval (gffStart gline) (gffEnd gline + 1) -- [closed, open) intervals+                    metamap' <- foldM (subfeatureInsert immap i) metamap0 $ lookupSubFeature sf+                    return $! GffLoadingState gmap' metamap'+            where+                subfeatureInsert :: GffIMMapAcc -> IM.Interval -> M.Map BS.ShortByteString IntDoublePair -> B.ByteString -> IO (M.Map BS.ShortByteString IntDoublePair)+                subfeatureInsert !immap !i !metamap sfVal = let+                            header = BS.toShort $ if singleFeature+                                                    then sfVal+                                                    else B.concat $ [f, ":"] ++(case sf of { Nothing -> []; Just s -> [s,":"]}) ++ [sfVal]+                            featureSize :: Double+                            featureSize = convert $ gffSize gline+                            (!metamap', active) = let+                                    combine _key _nv (IntDoublePair p oldSize) = (IntDoublePair p $ oldSize + featureSize)+                                    (oldVal, m) = M.insertLookupWithKey combine header (IntDoublePair (M.size metamap) featureSize) metamap+                                in (m, case oldVal of+                                    Just (IntDoublePair ix _) -> ix+                                    Nothing -> M.size m - 1)+                        in do+                            IM.insert i (AnnotationInfo (gffStrand gline) active) immap+                            return metamap'++                lookupSubFeature :: Maybe B.ByteString -> [B.ByteString]+                lookupSubFeature Nothing = filterSubFeatures "ID" (gffAttrs gline) <|> filterSubFeatures "gene_id" (gffAttrs gline)+                lookupSubFeature (Just s) = filterSubFeatures s (gffAttrs gline)++                filterSubFeatures s sf' = map snd $ filter ((s ==) . fst) sf'++        finishGffAnnotator ::  GffLoadingState -> NGLessIO Annotator+        finishGffAnnotator (GffLoadingState amap metamap) = do+                amap' :!: headers <- reindexGffAnn amap metamap+                let szmap' = VU.fromList $ map (\(IntDoublePair _ v) -> v) $ M.elems metamap+                return $! GFFAnnotator amap' headers szmap'++        -- First integer IDs are assigned "first come, first served"+        -- `reindexGffAnn` makes them alphabetical+        reindexGffAnn :: GFFAnnotationMapAcc -> M.Map BS.ShortByteString IntDoublePair -> NGLessIO (Pair GFFAnnotationMap (V.Vector BS.ShortByteString))+        reindexGffAnn amap metamap = do+            outputListLno' TraceOutput ["Re-index GFF"]+            let headers = V.fromList $ M.keys metamap -- these are sorted+                ix2ix :: VU.Vector Int+                ix2ix = VU.create $ do+                                r <- VUM.new (M.size metamap)+                                forM_ (zip (M.elems metamap) [0..]) $ \(IntDoublePair i _, p) -> VUM.write r i p+                                return r+                reindexAI :: AnnotationInfo -> AnnotationInfo+                reindexAI (AnnotationInfo s v) = AnnotationInfo s (ix2ix VU.! v)+            amap' <- forM amap $ \im -> do+                im' <- IM.unsafeFreeze im+                return $ IM.map reindexAI im'+            return $! amap' :!: headers+        gffSize :: GffLine -> Int+        gffSize g = (gffEnd g - gffStart g) + 1 -- gff format is inclusive at both ends!++++-- annotateSamLineGFF: Annotate a SamLine with the annotation map taking into+-- account the relevant options:+--    - the intersection rules+--    - the strandness rules+annotateSamLineGFF :: CountOpts -> GFFAnnotationMap -> SamLine -> [Int]+annotateSamLineGFF opts amap samline = case M.lookup (BS.toShort rname) amap of+        Nothing -> []+        Just im ->  selectIx $ (optIntersectMode opts) im lineStrand (IM.Interval sStart sEnd)+    where+        selectIx = map (\(AnnotationInfo _ ix) -> ix)+        rname = samRName samline+        sStart = samPos samline+        sEnd   = sStart + samLength samline+        -- GffUnStranded matches everything (see 'filterStrand')+        lineStrand :: GffStrand+        lineStrand = case optStrandMode opts of+                            SMBoth -> GffUnStranded+                            SMSense+                                | isPositive samline -> GffPosStrand+                                | otherwise -> GffNegStrand+                            SMAntisense -- reverse strandness+                                | isPositive samline -> GffNegStrand+                                | otherwise -> GffPosStrand++matchStrand GffUnStranded _ = True+matchStrand s (AnnotationInfo s' _) = s == s'++union :: AnnotationRule+union im strand i =  filter (matchStrand strand) . IM.overlaps i $ im++intersection_strict :: AnnotationRule+intersection_strict im strand i = let+        candidates = IM.overlapsWithKeys i  im+        strandFiltered = filter (matchStrand strand . snd) candidates+        intersecting = filter (contained i . fst) strandFiltered+        contained (IM.Interval s0 e0) (IM.Interval s1 e1) = s0 >= s1 && e0 <= e1+    in noDupAIs (fmap snd intersecting)++noDupAIs :: [AnnotationInfo] -> [AnnotationInfo]+noDupAIs = noDupAIs' []+    where+        noDupAIs' _ [] = []+        noDupAIs' prev (x@(AnnotationInfo _ ix):xs)+            | ix `elem` prev = noDupAIs' prev xs+            | otherwise = x:noDupAIs' (ix:prev) xs++intersection_non_empty :: AnnotationRule+intersection_non_empty im strand i@(IM.Interval sS sE)+    | sE <= sS = []+    | otherwise = let+        candidates = IM.overlapsWithKeys i  im+        strandFiltered = filter (matchStrand strand . snd) candidates+        subim = IM.fromList strandFiltered+        hits = filter (not . null) . map (flip IM.lookup subim) $ [sS..(sE-1)]+    in noDupAIs . intersection $ hits+++-- This is a pretty terrible implementation, but the expectation is that its+-- arguments will be very small lists (1-5 elements)+intersection :: Eq a => [[a]] -> [a]+intersection [] = []+intersection [x] = x+intersection (x:xs) = intersection' x xs+    where+        -- early bail-out (which is why this is not strictly an instance of foldl1)+        intersection' [] _ = []+        intersection' y [] = y+        intersection' y (z:zs) = intersection' (common y z) zs+        common :: Eq a => [a] -> [a] -> [a]+        common [] _ = []+        common (y:ys) zs+            | y `elem` zs = y:common ys zs+            | otherwise = common ys zs+++lookupFilePath context name args = case lookup name args of+    Nothing -> return Nothing+    Just a -> stringOrTypeError context a >>= (expandPath . T.unpack)+
+ NGLess/Interpretation/Count/RefSeqInfoVector.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}++module Interpretation.Count.RefSeqInfoVector+    ( RefSeqInfo(..)+    , RefSeqInfoVectorMutable+    , RefSeqInfoVector+    , fromList+    , newRefSeqInfoVector+    , insert+    , sort+    , unsafeFreeze+    , unsafeThaw+    , lookup+    , retrieveSize+    , retrieveSizeIO+    , retrieveName+    , length+    , writeSizeIO+    ) where++import           Prelude hiding (length, lookup)+import           Foreign.C.Types+import           Control.DeepSeq (NFData(..))+import           Control.Monad (forM_)+import qualified Data.ByteString as B+++import           Foreign.Ptr+import           Foreign.ForeignPtr+import           System.IO.Unsafe (unsafeDupablePerformIO)+import qualified Language.C.Inline.Context as C+import qualified Language.C.Inline.Unsafe as CU+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exception as C+++foreign import ccall "&rsiv_free" c_rsiv_free :: FunPtr (Ptr () -> IO ())++C.context (C.baseCtx <> C.bsCtx <> C.fptrCtx <> C.cppCtx)+C.include "RefSeqInfoVector.h"++data RefSeqInfo = RefSeqInfo+                        { rsiName :: {-# UNPACK #-} !B.ByteString+                        , rsiSize :: {-# UNPACK #-} !Double+                        } deriving (Eq, Show)+instance NFData RefSeqInfo where+    rnf !_ = ()++instance Ord RefSeqInfo where+    compare RefSeqInfo{ rsiName = n0 } RefSeqInfo{ rsiName = n1 } = compare n0 n1+++newtype RefSeqInfoVectorMutable = RefSeqInfoVectorMutable (ForeignPtr ())+newtype RefSeqInfoVector = RefSeqInfoVector (ForeignPtr ())++instance NFData RefSeqInfoVector where+    rnf (RefSeqInfoVector !_) = ()++newRefSeqInfoVector :: IO RefSeqInfoVectorMutable+newRefSeqInfoVector = do+    p <- C.withPtr_ $ \r ->+        [C.catchBlock| { *( $(void** r) ) = new RefSeqInfoVector; }|]+    RefSeqInfoVectorMutable <$> newForeignPtr c_rsiv_free (p :: Ptr ())++insert :: RefSeqInfoVectorMutable -> B.ByteString -> Double -> IO ()+insert (RefSeqInfoVectorMutable p) bs val = do+        let val' :: CDouble+            val' = CDouble val+        [C.catchBlock| { static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p))->insert(std::string($bs-ptr:bs, $bs-len:bs), $(double val')); } |]++sort :: RefSeqInfoVectorMutable -> IO ()+sort (RefSeqInfoVectorMutable p) = [CU.block| void {+            RefSeqInfoVector* vec = static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p));+            vec->sort();+    }|]++unsafeFreeze :: RefSeqInfoVectorMutable -> IO RefSeqInfoVector+unsafeFreeze (RefSeqInfoVectorMutable v) = return $ RefSeqInfoVector v++unsafeThaw :: RefSeqInfoVector -> IO RefSeqInfoVectorMutable+unsafeThaw (RefSeqInfoVector v) = return $ RefSeqInfoVectorMutable v++lookup :: RefSeqInfoVector -> B.ByteString -> Maybe Int+lookup (RefSeqInfoVector p) key = let+    CInt ix = [CU.pure| int { static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p))->find(std::string($bs-ptr:key, $bs-len:key).c_str()) } |]+    in if ix == -1+        then Nothing+        else Just (fromEnum ix)++retrieveSize :: RefSeqInfoVector -> Int -> Double+retrieveSize (RefSeqInfoVector r) ix = unsafeDupablePerformIO (retrieveSizeIO (RefSeqInfoVectorMutable r) ix)++retrieveSizeIO :: RefSeqInfoVectorMutable -> Int -> IO Double+retrieveSizeIO (RefSeqInfoVectorMutable p) ix = do+    let ix' = toEnum ix+    CDouble val <- [CU.exp| double { static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p))->at($(int ix')).val } |]+    return val++writeSizeIO :: RefSeqInfoVectorMutable -> Int -> Double -> IO ()+writeSizeIO (RefSeqInfoVectorMutable p) ix val = do+    let val' = CDouble val+        ix' = toEnum ix+    [C.catchBlock| { static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p))->at($(int ix')).val = $(double val'); } |]++length :: RefSeqInfoVector -> Int+length (RefSeqInfoVector p) =+    fromEnum [CU.pure| unsigned int { static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p))->size() } |]++retrieveName :: RefSeqInfoVector -> Int -> B.ByteString+retrieveName (RefSeqInfoVector p) ix = unsafeDupablePerformIO $ do+    let ix' = toEnum ix+    [CU.exp| const char* {static_cast<RefSeqInfoVector*>($fptr-ptr:(void* p))->at($(int ix')).str } |] >>= B.packCString++fromList :: [RefSeqInfo] -> RefSeqInfoVector+fromList entries = unsafeDupablePerformIO $ do+    r <- newRefSeqInfoVector+    forM_ entries $ \(RefSeqInfo n v) -> insert r n v+    sort r+    unsafeFreeze r
+ NGLess/Interpretation/CountFile.hs view
@@ -0,0 +1,77 @@+{- Copyright 2019 NGLess Authors+ - License: MIT+ -}++module Interpretation.CountFile+    ( executeCountFile+    ) where++import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8++import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import           Data.Conduit.Algorithms.Async (withPossiblyCompressedFile)+import           Data.Conduit ((.|))+import           Data.List (sortOn)++import Language++import NGLess+import Output+import NGLess.NGLEnvironment (NGLVersion(..), NGLEnvironment(..), nglEnvironment)+import FileOrStream (FileOrStream(..))+import FileManagement (makeNGLTempFile)+import Utils.Conduit (ByteLine(..), linesC, byteLineSinkHandle)++executeCountFile :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeCountFile (NGOString st) _ = do+    let fname = T.unpack st+    ok <- checkCountFile fname+    (NGOCounts . File) <$> if ok+        then return fname+        else maybeNormalizeCountFile fname+executeCountFile other _ = throwScriptError ("Unexpected argument to countfile(): expected str, got " ++ show other)++checkCountFile :: FilePath -> NGLessIO Bool+checkCountFile fname = withPossiblyCompressedFile fname $ \src ->+        C.runConduit (src .| linesC .| isOrdered0)+    where+        isOrdered0 = C.await >>= \case+                            Nothing -> return True+                            Just p -> isOrdered p++        isOrdered prev = C.await >>= \case+                            Nothing -> return True+                            Just next+                                | prev `tagCompare` next -> isOrdered next+                                | otherwise -> return False++maybeNormalizeCountFile :: FilePath -> NGLessIO FilePath+maybeNormalizeCountFile fname = do+    ver@(NGLVersion majV minV) <- ngleVersion <$> nglEnvironment+    if ver < NGLVersion 1 1+        then do+            outputListLno' WarningOutput ["countfile(): file `", fname, "` is not in the right order.\nIn newer versions of NGLess (1.1 and above), the file is normalized (reordered) to avoid errors later. As NGLess is running in compatibility mode for an earlier version (v", show majV, ".", show minV, "), this normalization will be skipped."]+            return fname+        else normalizeCountFile fname++normalizeCountFile :: FilePath -> NGLessIO FilePath+normalizeCountFile fname = makeNGLTempFile "normalized" fname ".tsv" $ \hout ->+    withPossiblyCompressedFile fname $ \src -> do+        C.runConduit (src .| linesC .| sortContent .| byteLineSinkHandle hout)++sortContent = do+    CC.takeWhile (\(ByteLine line) -> B.null line || B8.head line == '#')+    CC.take 1+    content <- CL.consume+    CL.sourceList (sortOn tag content)++tagCompare :: ByteLine -> ByteLine -> Bool+tagCompare line0 line1 = tag line0 < tag line1++tag :: ByteLine -> B.ByteString+tag = fst . B.break (== 9) . unwrapByteLine -- 9 is TAB+
+ NGLess/Interpretation/FastQ.hs view
@@ -0,0 +1,294 @@+{- Copyright 2013-2020 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts, MultiWayIf, CPP #-}++module Interpretation.FastQ+    ( executeFastq+    , executePaired+    , executeGroup+    , executeShortReadsMethod++    , encodingFor+#ifdef IS_BUILDING_TEST+    , compatibleHeader+#endif+    ) where++import System.IO+import qualified Data.Text as T+import qualified Data.Vector.Storable as VS+import qualified Data.Conduit.Combinators as C+import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Control.Concurrent.Async as A+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Utils (awaitJust)+import qualified Data.Conduit.Algorithms.Async as CAlg+import           Data.Conduit.Algorithms.Async (withPossiblyCompressedFile)+import qualified Data.Conduit.Algorithms.Utils as CAlg+import           Control.Monad.Trans.Resource (runResourceT)+import Control.Exception (try)+import Control.Monad.Except+import Data.Maybe+import Data.Word++import FileManagement+import Data.FastQ+import Configuration+import Language+import Output+import Utils.Conduit (ByteLine(..), linesC)+import NGLess+import NGLess.NGLEnvironment++++-- | Guess the encoding of a file+encodingFor :: FilePath -> NGLessIO FastQEncoding+encodingFor fp = do+    let update :: Word8 -> Word8 -> B.ByteString -> (Word8, Word8)+        update minv maxv qs = (min minv $ B.minimum qs, max maxv $ B.maximum qs)+        encodingC minv maxv =+                C.await >>= \case+                    Nothing+                        | minv == 255 -> do+                            lift $ outputListLno' WarningOutput ["Input file ", fp, " is empty."]+                            return SangerEncoding -- It does not matter+                        | otherwise -> do+                            lift $ outputListLno' WarningOutput ["Heuristic for FastQ encoding determination for file ", show fp, " cannot be 100% confident. Guessing 33 offset (Sanger encoding, used by newer Illumina machines)."]+                            return SangerEncoding+                    Just [_, _, _, ByteLine qs] -> case update minv maxv qs of+                            (minv', maxv')+                                | minv' < 33 -> throwDataError ("No known encodings with chars < 33 (Yours was "++ show minv ++ ") for file '" ++ show fp ++ "'.")+                                | minv' < 58 -> return SangerEncoding+                                -- 33 + 45 should never happen with SangerEncoding, but it's quality 14 in SolexaEncoding, so should be common+                                | maxv' >= (33+45) -> return SolexaEncoding+                                | otherwise -> encodingC minv' maxv'+                    _ -> throwDataError ("Malformed file '" ++ fp ++ "': number of lines is not a multiple of 4.")+++    withPossiblyCompressedFile fp $ \src ->+        C.runConduit $+            src+            .| linesC+            .| CL.chunksOf 4+            .| encodingC 255 0++-- | Checks if file has no content+--+-- Note that this is more than checking if the file is empty: a compressed file+-- with no content will not be empty.+checkNoContent :: FilePath -> NGLessIO Bool+checkNoContent fp = runResourceT $ withPossiblyCompressedFile fp $ \src ->+    C.runConduit $+        src+        .| linesC+        .| CL.isolate 1+        .| CL.fold (\_ _ -> False) True+++-- | Drop 90% of FastQ entries (keep only the first of every 10)+drop90 = loop (0 :: Int)+    where+        loop 40 = loop 0+        loop !n = awaitJust $ \line -> do+                when (n < 4) (C.yield line)+                loop (n+1)+++performSubsample :: FilePath -> Handle -> IO ()+performSubsample f h = do+    runResourceT $ withPossiblyCompressedFile f $ \src ->+        C.runConduit $+            src+            .| CB.lines+            .| drop90+            .| C.take 100000+            .| C.unlinesAscii+            .| CAlg.asyncGzipTo h+    hClose h++optionalSubsample :: FilePath -> NGLessIO FilePath+optionalSubsample f = do+    subsampleActive <- nConfSubsample <$> nglConfiguration+    if subsampleActive+        then do+            outputListLno' TraceOutput ["Subsampling file ", f]+            (newfp,h) <- openNGLTempFile f "" "fq.gz"+            liftIO $ performSubsample f h+            outputListLno' TraceOutput ["Finished subsampling (temp sampled file is ", newfp, ")"]+            return newfp+        else return f+++executeGroup :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeGroup (NGOList rs) args = do+        name <- lookupStringOrScriptError "group call" "name" args+        case rs of+            [r] -> addName name r+            _ -> do+                rs' <- getRSOrError `mapM` rs+                grouped <- runNGLess $ groupFiles name rs'+                return (NGOReadSet name grouped)+    where+        getRSOrError (NGOReadSet _ r) = return r+        getRSOrError other = throwShouldNotOccur . concat $ ["In group call, all arguments should have been NGOReadSet! Got ", show other]+        addName name (NGOReadSet _ r) = return $! NGOReadSet name r+        addName _  other = throwScriptError . concat $ ["In group call, all arguments should have been NGOReadSet, got ", show other]+executeGroup other _ = throwScriptError ("Illegal argument to group(): " ++ show other)++groupFiles :: T.Text -> [ReadSet] -> NGLess ReadSet+groupFiles context [] =+    throwDataError ("Attempted to group sample '" ++ T.unpack context ++ "' but sample is empty (no read files).")+groupFiles _ rs = return $! ReadSet (concatMap pairedSamples rs) (concatMap singleSamples rs)++compatibleHeader :: B.ByteString -> B.ByteString -> Bool+compatibleHeader h1 h2+    | h1 == h2 = True+    | B.length h1 /= B.length h2 = False+    | otherwise = fromMaybe False $ do+        h1' <- B8.stripSuffix "/1" h1+        h2' <- B8.stripSuffix "/2" h2+        return (h1' == h2')++uninterleave :: Maybe FastQEncoding -> FilePath -> NGLessIO ReadSet+uninterleave enc fname = do+    enc' <- fromMaybe (encodingFor fname) (return <$> enc)+    outputListLno' TraceOutput ["Un-interleaving file ", fname]+    (fp1,h1) <- openNGLTempFile fname "" "pair.1.fq.zst"+    (fp2,h2) <- openNGLTempFile fname "" "pair.2.fq.zst"+    (fp3,h3) <- openNGLTempFile fname "" "singles.fq.zst"+    subsampleActive <- nConfSubsample <$> nglConfiguration+    let doSubsampleC !n+            | n >= 25000 = return ()+            | otherwise = awaitJust $ \x -> do+                            when (n `mod` 10 == 0) $+                                C.yield x+                            doSubsampleC (n + 1)+        subsampleC w+            | subsampleActive  = doSubsampleC (0 :: Int) .| w+            | otherwise = w+        uninterleaveC = awaitJust uninterleaveC'+        uninterleaveC' prev = C.await >>= \case+            Nothing -> C.yield $! (2, fqEncode enc' prev)+            Just next+                | compatibleHeader (srHeader prev) (srHeader next) -> do+                        C.yield (0, fqEncode enc' prev)+                        C.yield (1, fqEncode enc' next)+                        uninterleaveC+                | otherwise -> do+                        C.yield $! (2, fqEncode enc' prev)+                        uninterleaveC' next+    void $ withPossiblyCompressedFile fname $ \src ->+        C.runConduit $+            src+            .| linesC+            .| fqDecodeC fname enc'+            .| C.passthroughSink fqStatsC (\stats -> outputFQStatistics fname stats enc')+            .| uninterleaveC+            .| subsampleC (CAlg.dispatchC+                        [CAlg.asyncZstdTo 3 h1+                        ,CAlg.asyncZstdTo 3 h2+                        ,CAlg.asyncZstdTo 3 h3])+    forM_ [h1,h2,h3] (liftIO . hClose)+    return $! ReadSet [(FastQFilePath enc' fp1, FastQFilePath enc' fp2)] [FastQFilePath enc' fp3]++executeFastq :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeFastq expr args = do+    enc <- getEncArgument "fastq" args+    qcNeeded <- lookupBoolOrScriptErrorDef (return True) "fastq hidden QC argument" "__perform_qc" args+    interleaved <- lookupBoolOrScriptErrorDef (return False) "fastq interleaved" "interleaved" args+    case expr of+        (NGOString fname)+            | interleaved -> NGOReadSet fname <$> uninterleave enc (T.unpack fname)+            | otherwise -> do+                fname' <- optionalSubsample (T.unpack fname)+                fq <- asFQFilePathMayQC qcNeeded enc fname'+                return $ NGOReadSet fname (ReadSet [] [fq])+        (NGOList fps) -> NGOList <$> sequence [NGOReadSet fname . ReadSet [] . (:[]) <$> asFQFilePathMayQC True enc (T.unpack fname) | NGOString fname <- fps]+        v -> throwScriptError ("fastq function: unexpected first argument: " ++ show v)+++asFQFilePathMayQC :: Bool -- ^ whether to perform QC+                -> Maybe FastQEncoding -- ^ encoding to use (or autodetect)+                -> FilePath         -- ^ FastQ file+                -> NGLessIO FastQFilePath+asFQFilePathMayQC qc enc fp =  do+    enc' <- maybe (encodingFor fp) return enc+    when qc $ do+        s <- statsFromFastQ fp enc'+        outputFQStatistics fp s enc'+    return $! FastQFilePath enc' fp++executePaired :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executePaired (NGOString mate1) args = NGOReadSet mate1 <$> do+    enc <- getEncArgument "paired" args+    mate2 <- lookupStringOrScriptError "automatic argument" "second" args+    mate3 <- lookupStringOrScriptErrorDef (return "") "paired" "singles" args+    outputListLno' TraceOutput ["Executing paired on ", show mate1, show mate2, show mate3]+    qcNeeded <- lookupBoolOrScriptErrorDef (return True) "fastq hidden QC argument" "__perform_qc" args++    subsampleActive <- nConfSubsample <$> nglConfiguration+    (fp1', fp2') <- if subsampleActive+        then do+            (fp1',h1') <- openNGLTempFile (T.unpack mate1) "subsampled" "1.fq.gz"+            (fp2',h2') <- openNGLTempFile (T.unpack mate2) "subsampled" "2.fq.gz"+            outputListLno' TraceOutput ["Subsampling paired files ", T.unpack mate1, " and ", T.unpack mate2, " (parallel processing)"]+            liftIO $ A.concurrently_+                (performSubsample (T.unpack mate1) h1')+                (performSubsample (T.unpack mate2) h2')+            return (fp1', fp2')+        else return (T.unpack mate1, T.unpack mate2)+    pair@(FastQFilePath enc1 fp1, FastQFilePath enc2 fp2) <-+        if not qcNeeded+            then (,)+                 <$> asFQFilePathMayQC qcNeeded enc fp1'+                 <*> asFQFilePathMayQC qcNeeded enc fp2'+            else do+                enc1 <- fromMaybe (encodingFor fp1') (return <$> enc)+                enc2 <- fromMaybe (encodingFor fp2') (return <$> enc)+                (es1,es2) <- liftIO $ A.concurrently+                            (try $ testNGLessIO $ statsFromFastQ fp1' enc1)+                            (try $ testNGLessIO $ statsFromFastQ fp2' enc2)+                s1 <- runNGLess es1+                s2 <- runNGLess es2+                outputFQStatistics fp1' s1 enc1+                outputFQStatistics fp2' s2 enc2+                return (FastQFilePath enc1 fp1', FastQFilePath enc2 fp2')+    when (enc1 /= enc2) $+        throwDataError ("Mates do not seem to have the same quality encoding! (first mate [" ++ fp1 ++ "] had " ++ show enc1 ++ ", second one [" ++ fp2 ++ "] " ++ show enc2 ++ ").")+    case mate3 of+        "" -> return $! ReadSet [pair] []+        f3 -> do+            single@(FastQFilePath enc3 fp3) <- optionalSubsample (T.unpack f3) >>= asFQFilePathMayQC qcNeeded enc+            if (enc1 /= enc3)+                then do+                    is3empty <- checkNoContent fp3 -- this is a special case, but seen in the wild+                    unless is3empty $+                        throwDataError ("Mates do not seem to have the same quality encoding! (paired mates [" ++ fp1 ++ " had " ++ show enc1 ++ ", single one [" ++ fp3 ++ "] " ++ show enc3 ++ ").")+                    return $! ReadSet [pair] []+            else return $! ReadSet [pair] [single]+executePaired expr _ = throwScriptError ("Function paired expects a string, got: " ++ show expr)++getEncArgument :: String -> KwArgsValues -> NGLessIO (Maybe FastQEncoding)+getEncArgument fname args =+    lookupSymbolOrScriptErrorDef (return "auto") fname "encoding" args+        >>= \case+            "auto" -> return Nothing+            "33" -> return $ Just SangerEncoding+            "sanger" -> return $ Just SangerEncoding+            "64" -> return $ Just SolexaEncoding+            "solexa" -> return $ Just SolexaEncoding+            other -> throwScriptError ("Unkown encoding for fastq " ++ T.unpack other)++executeShortReadsMethod (MethodName "avg_quality") (ShortRead _ _ rQ) Nothing _ = return $! NGODouble $ fromIntegral (VS.foldl' (\acc n -> acc + toInteger n) (0 :: Integer) rQ) / fromIntegral (VS.length rQ)+executeShortReadsMethod (MethodName "fraction_at_least") (ShortRead _ _ rQ) (Just (NGOInteger minq)) _ = return $! NGODouble $ fromIntegral (VS.foldl' (\acc q -> acc + fromEnum (q >= fromInteger minq)) (0 :: Int) rQ) / fromIntegral (VS.length rQ)+executeShortReadsMethod (MethodName "n_to_zero_quality") (ShortRead h sq rQ) Nothing _ = return . NGOShortRead . ShortRead h sq $ VS.generate (VS.length rQ) (\ix ->+                                                                                                                            if B8.index sq ix == 'N' || B8.index sq ix == 'n'+                                                                                                                                then 0+                                                                                                                                else rQ VS.! ix)+executeShortReadsMethod (MethodName other) _ _ _ = throwShouldNotOccur ("Unknown short read method: " ++ show other)
+ NGLess/Interpretation/Map.hs view
@@ -0,0 +1,366 @@+{- Copyright 2013-2019 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Interpretation.Map+    ( executeMap+    , executeMapStats+    , executeMergeSams+    ) where++import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Builder as BB+import           Control.Monad+import           Control.Monad.Except++import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit as C+import qualified Data.Conduit.Algorithms.Async as CAlg+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Utils (awaitJust)+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import           Control.Monad.Extra (unlessM)+import           Data.List (sort)+++import           System.IO (hClose, hPutStr, hPutStrLn)+import           System.IO.Error (catchIOError, isAlreadyExistsError)+import           System.FilePath.Glob (namesMatching)+import qualified System.Directory as SD+import           System.FilePath ((</>), (<.>))+import qualified System.FilePath as FilePath+import           System.PosixCompat.Files (createSymbolicLink)+import           Data.Maybe (fromMaybe)++import Language+import FileManagement+import ReferenceDatabases+import Output+import NGLess+import NGLess.NGLEnvironment++import qualified StandardModules.Mappers.Bwa as Bwa+import qualified StandardModules.Mappers.Soap as Soap+import qualified StandardModules.Mappers.Minimap2 as Minimap2++import Data.Sam+import Data.Fasta+import FileOrStream+import Utils.Utils+import Utils.Conduit+import Configuration+import Utils.LockFile++fromRight d (Left _) = d+fromRight _ (Right v) = v+-- | internal type+data ReferenceInfo = PackagedReference T.Text | FaFile FilePath++data MergeStrategy = MSBestOnly++-- | An object which represents a mapper+data Mapper = Mapper+    { createIndex :: FilePath -> NGLessIO ()+    , hasValidIndex :: FilePath -> NGLessIO Bool+    , callMapper :: forall a. FilePath -> ReadSet -> [String] -> C.ConduitT B.ByteString C.Void NGLessIO a -> NGLessIO a+    }++bwa = Mapper Bwa.createIndex Bwa.hasValidIndex Bwa.callMapper+soap = Mapper Soap.createIndex Soap.hasValidIndex Soap.callMapper+minimap2 = Mapper Minimap2.createIndex Minimap2.hasValidIndex Minimap2.callMapper++getMapper :: T.Text -> NGLessIO Mapper+getMapper request = do+        mappers <- ngleMappersActive <$> nglEnvironment+        if request `elem` mappers+            then return $! case request of+                "minimap2" -> minimap2+                "soap" -> soap+                "bwa" -> bwa+                _ -> error "should not be possible map:getMapper"+            else throwScriptError ("Requested mapper '"++T.unpack request ++"' is not active.")+++isSubPath path base = let+                        path' = FilePath.splitPath path+                        base' = FilePath.splitPath base+                        isSubPath' _ [] = True+                        isSubPath' [] _ = False+                        isSubPath' (p:ps) (b:bs) = p == b && isSubPath' ps bs+                    in isSubPath' path' base'+++getIndexOutput createLink fafile = do+    indexDir <- nConfIndexStorePath <$> nglConfiguration+    case indexDir of+        Just d+            | not (fafile `isSubPath` d) -> liftIO $ do+                let dropSlash "" = ""+                    dropSlash ('/':r) = dropSlash r+                    dropSlash p = p+                afafile <- SD.makeAbsolute fafile+                let fafile' = d </> dropSlash afafile+                SD.createDirectoryIfMissing True (FilePath.takeDirectory fafile')+                when createLink $+                    createSymbolicLink afafile fafile'+                        `catchIOError` (\e -> unless (isAlreadyExistsError e) (ioError e))+                return fafile'+        _ -> return fafile++-- | lazy index creation+ensureIndexExists :: Int -> Mapper -> FilePath -> NGLessIO [FilePath]+ensureIndexExists 0 mapper fafile = do+    hasIndex <- hasValidIndex mapper fafile+    if hasIndex+        then do+            outputListLno' DebugOutput ["Index for ", fafile, " already exists."]+            return [fafile]+        else do+            fafile' <- getIndexOutput True fafile+            withLockFile LockParameters+                            { lockFname = fafile' ++ ".ngless-index.lock"+                            , maxAge = hoursToDiffTime 36+                            , whenExistsStrategy = IfLockedRetry { nrLockRetries = 37*60, timeBetweenRetries = 60 }+                            , mtimeUpdate = True+                            } $+                -- recheck if index exists with the lock in place+                -- it may have been created in the meanwhile (especially if we slept waiting for the lock)+                unlessM (hasValidIndex mapper fafile') $+                    createIndex mapper fafile'+            return [fafile']+  where+    hoursToDiffTime h = fromInteger (h * 3600)++ensureIndexExists blockSize mapper fafile = do+    blocks <- ensureSplitsExist blockSize fafile+    forM_ blocks (ensureIndexExists 0 mapper)+    return blocks++ensureSplitsExist blockSize fafile = do+    fafile' <- getIndexOutput False fafile+    let ofafile = FilePath.takeDirectory fafile' </> FilePath.takeBaseName fafile <.> "splits_" ++ show blockSize ++ "m"+        receipt = ofafile <.> "done"+    done <- liftIO $ SD.doesFileExist receipt+    if done+        then do+            outputListLno' TraceOutput ["Splits for FASTA file '", fafile, "' found"]+            liftIO $ sort <$> namesMatching (ofafile ++ ".*.fna")+        else do+            outputListLno' DebugOutput ["Splitting FASTA file '", fafile, "'"]+            splits <- splitFASTA blockSize fafile ofafile+            liftIO $ withOutputFile receipt $ \hout ->+                hPutStrLn hout ("FASTA file '" ++ fafile ++ "' split into blocks of " ++ show blockSize ++ " megabases.")+            outputListLno' InfoOutput ["Split FASTA file '", fafile, "' into ", show (length splits), " chunks."]+            return splits+++-- | parse map() args to return a reference+lookupReference :: KwArgsValues -> NGLessIO ReferenceInfo+lookupReference args = do+    let reference = lookup "reference" args+        fafile = lookup "fafile" args+    case (reference, fafile) of+        (Nothing, Nothing) -> throwScriptError "Either reference or fafile must be passed"+        (Just _, Just _) -> throwScriptError "Reference and fafile cannot be used simmultaneously"+        (Just r, Nothing) -> PackagedReference <$> stringOrTypeError "reference in map argument" r+        (Nothing, Just fa) -> (FaFile . T.unpack) <$> stringOrTypeError "fafile in map argument" fa+++mapToReference :: Mapper -> FilePath -> ReadSet -> [String] -> NGLessIO (FilePath, (Int, Int, Int))+mapToReference mapper refIndex rs extraArgs = do+    (newfp, hout) <- openNGLTempFile refIndex "mapped_" "sam.zstd"+    statsp <- callMapper mapper refIndex rs extraArgs (zipToStats $ CAlg.asyncZstdTo 3 hout)+    liftIO $ hClose hout+    return (newfp, statsp)++zipToStats :: C.ConduitT B.ByteString C.Void NGLessIO () -> C.ConduitT B.ByteString C.Void NGLessIO (Int, Int, Int)+zipToStats out = snd <$> C.toConsumer (zipSink2 out (linesVC 4096 .| readSamGroupsC' 1 True .| samStatsC'))++splitFASTA :: Int -> FilePath -> FilePath -> NGLessIO [FilePath]+splitFASTA megaBPS ifile ofileBase =+        withLockFile LockParameters+                { lockFname = ifile ++ "." ++ show megaBPS ++ "m.split.lock"+                , maxAge = 36 * 3000+                , whenExistsStrategy = IfLockedRetry { nrLockRetries = 120, timeBetweenRetries = 60 }+                , mtimeUpdate = True+                } $ C.runConduit $+            conduitPossiblyCompressedFile ifile+                .| faConduit+                .| splitWriter+    where+        maxBPS = 1000 * 1000 * megaBPS+        splitWriter = splitWriter' [] (0 :: Int)+        splitWriter' fs n = do+            let f = ofileBase ++ "." ++ show n ++ ".fna"+            getNbps+                .| faWriteC+                .| CB.sinkFileCautious f+            finished <- CC.null+            if finished+                then return $ reverse (f:fs) -- reversing is done just so that chunks are indexed "in order"+                else splitWriter' (f:fs) (n + 1)+        getNbps = awaitJust $ \fa -> do+                        C.yield fa+                        if faseqLength fa > maxBPS+                            then do+                                lift $ outputListLno' WarningOutput+                                            ["While splitting file '", ifile, ": Sequence ", B8.unpack (seqheader fa), " is ", show (faseqLength fa)+                                            ," bases long (which is longer than the block size). Note that NGLess does not split sequences."]+                                return ()+                            else getNbps' (faseqLength fa)++        getNbps' sofar = awaitJust $ \fa ->+                            if faseqLength fa + sofar > maxBPS+                                then C.leftover fa+                                else do+                                    C.yield fa+                                    getNbps' (faseqLength fa + sofar)+++performMap :: Mapper -> Int -> ReferenceInfo -> T.Text -> ReadSet -> [String] -> NGLessIO NGLessObject+performMap mapper blockSize ref name rs extraArgs = do+    (ref', mappedRef) <- indexReference ref+    case ref' of+        [single] -> do+            (samPath', (total, aligned, unique)) <- mapToReference mapper single rs extraArgs+            outputMappedSetStatistics (MappingInfo undefined samPath' single total aligned unique)+            return $ NGOMappedReadSet name (File samPath') mappedRef+        blocks -> do+            (sam, hout) <- openNGLTempFile "merging" "merged_" "sam.zstd"+            partials <- forM blocks (\block -> fst <$> mapToReference mapper block rs extraArgs)+            ((total, aligned, unique), ()) <- C.runConduit $+                mergeSamFiles partials+                .| zipSink2 (CC.conduitVector 4096 .| samStatsC')+                    (CL.concat+                        .| CL.map ((`mappend` BB.char7 '\n') . encodeSamLine)+                        .| CC.builderToByteString+                        .| CAlg.asyncZstdTo 3 hout)+            liftIO $ hClose hout+            let refname = case ref of+                    FaFile fa -> fa+                    PackagedReference r -> T.unpack r+            outputMappedSetStatistics (MappingInfo undefined sam refname total aligned unique)+            return $! NGOMappedReadSet name (File sam) mappedRef+++    where+        indexReference :: ReferenceInfo -> NGLessIO ([FilePath], Maybe T.Text)+        indexReference (FaFile fa) =+            expandPath fa >>= \case+                Just fa' -> (,Nothing) <$> ensureIndexExists blockSize mapper fa'+                Nothing -> throwDataError ("Could not find FASTA file: "++fa)+        indexReference (PackagedReference r) = do+            ReferenceFilePaths fafile _ _ <- ensureDataPresent r+            case fafile of+                Just fp -> (, Just r) <$> ensureIndexExists blockSize mapper fp+                Nothing -> throwScriptError ("Could not find reference '" ++ T.unpack r ++ "'.")++executeMap :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeMap fqs args = do+    ref <- lookupReference args+    oAll <- lookupBoolOrScriptErrorDef (return False) "map() call" "mode_all" args+    extraArgs <- map T.unpack <$> lookupStringListOrScriptErrorDef (return []) "extra mapper arguments" "__extra_args" args+    mapperName <- lookupStringOrScriptErrorDef (return "bwa") "map() call" "mapper" args+    blockSize <- lookupIntegerOrScriptErrorDef (return 0) "map() call" "block_size_megabases" args+    mapper <- getMapper mapperName+    let bwaArgs = extraArgs ++ ["-a" | oAll]+        executeMap' r (NGOList es)            = NGOList <$> forM es (executeMap' r)+        executeMap' r (NGOReadSet name rs)    = performMap mapper (fromInteger blockSize) r name rs bwaArgs+        executeMap' _ v = throwShouldNotOccur ("map expects ReadSet, got " ++ show v ++ "")+    executeMap' ref fqs++executeMapStats :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeMapStats (NGOMappedReadSet name sami _) _ = do+    outputListLno' TraceOutput ["Computing mapstats on ", show sami]+    let (samfp, stream) = asSamStream sami+    (t, al, u) <- C.runConduit (stream .| samStatsC) >>= runNGLess+    countfp <- makeNGLTempFile samfp "sam_stats_" "stats" $ \hout ->+        liftIO . hPutStr hout . concat $+            [     "\t",  T.unpack name, "\n"+            ,"total\t",   show  t, "\n"+            ,"aligned\t", show al, "\n"+            ,"unique\t",  show  u, "\n"+            ]+    return $! NGOCounts (File countfp)+executeMapStats other _ = throwScriptError ("Wrong argument for mapstats: "++show other)++executeMergeSams :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeMergeSams (NGOList ifnames) _ = do+    outputListLno' WarningOutput ["Calling internal function __merge_samfiles"]+    partials <- mapM (fmap T.unpack . stringOrTypeError "__merge_samfiles") ifnames+    (sam, hout) <- openNGLTempFile "merging" "merged_" "sam.zstd"+    ((total, aligned, unique), ()) <- C.runConduit $+        mergeSamFiles partials+        .| zipSink2 (CC.conduitVector 4096 .| samStatsC')+            (CL.concat+                .| CL.map ((`mappend` BB.char7 '\n') . encodeSamLine)+                .| CC.builderToByteString+                .| CAlg.asyncZstdTo 3 hout)+    outputMappedSetStatistics (MappingInfo undefined sam "no-ref" total aligned unique)+    liftIO $ hClose hout+    return $! NGOMappedReadSet "test" (File sam) Nothing+executeMergeSams _ _ = throwScriptError "Wrong argument for internal function __merge_samfiles"++++mergeSamFiles :: [FilePath] -> C.ConduitT () SamGroup NGLessIO ()+mergeSamFiles [] = lift $ throwShouldNotOccur "empty input to mergeSamFiles"+mergeSamFiles inputs = do+    lift $ outputListLno' TraceOutput ["Merging SAM files: ", show inputs]+    forM_ inputs $ \f ->+        CB.sourceFile f+            .| linesC+            .| readSamHeaders+    -- This is sub-optimal as we reparse the file.+    -- There are also obvious opportunities to make this code take advantage of parallelism+    C.sequenceSources+            [CB.sourceFile f+                .| linesVC 4096+                .| readSamGroupsC' 1 True+                .| CC.concat -- TODO: Remove this and adapt `mergeSAMGroups` to work directly on vectors+                        | f <- inputs]++        .| CL.mapM (mergeSAMGroups MSBestOnly)++readSamHeaders :: C.ConduitT ByteLine SamGroup NGLessIO ()+readSamHeaders =+    CC.takeWhile (\(ByteLine line) -> B.null line || B.head line == 64)+                .| CL.map (\(ByteLine line) -> [SamHeader line])++mergeSAMGroups :: MergeStrategy -> [SamGroup] -> NGLessIO SamGroup+mergeSAMGroups strategy groups+        | not (allSame . fmap samQName $ concat groups) = throwDataError "Merging unsynced SAM files (not implemented yet)"+        | otherwise = do+            useNewer <- do+                v <- ngleVersion <$> nglEnvironment+                if v < NGLVersion 1 1+                    then do+                        outputListLno' WarningOutput ["SAM merging changed behaviour (for the better) in ngless 1.1. Using the old method for backwards-compatibility."]+                        return False+                    else return True+            return $ group useNewer group1 ++ group useNewer group2 ++ group useNewer groupS+    where+        (group1, group2, groupS) = foldl (\(g1,g2,gS) s ->+                                                (if isFirstInPair s+                                                    then (s:g1, g2, gS)+                                                    else if isSecondInPair s+                                                        then (g1, s:g2, gS)+                                                        else (g1, g2, s:gS))) ([], [], []) $ concat groups+        group :: Bool -> [SamLine] -> [SamLine]+        group _ [] = []+        group useNewer gs = case filter isAligned gs of+            [] -> [head gs]+            gs' -> pick useNewer strategy gs'+        pick :: Bool -> MergeStrategy -> [SamLine] -> [SamLine]+        pick useNewer MSBestOnly gs =+            let matchValue :: SamLine -> Int+                matchValue samline = fromRight 0 (matchSize useNewer samline) - fromMaybe 0 (samIntTag samline "NM")+                bestMatch = maximum (map matchValue gs)+            in filter (\samline -> matchValue samline == bestMatch) gs+
+ NGLess/Interpretation/Select.hs view
@@ -0,0 +1,346 @@+{- Copyright 2015-2020 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-}++module Interpretation.Select+    ( executeSelect+    , executeMappedReadMethod+    , fixCigar+    , reinjectSequences+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Builder as BB+import qualified Data.Vector as V+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import           Data.Conduit ((.|))+import qualified Data.Conduit.List as CL+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import           Data.Bits (Bits(..))+import           Control.Monad.Except (throwError)+import           Data.Either.Combinators (fromRight)+import           Data.List (foldl')+import           Data.Either.Extra (eitherToMaybe)+import           Data.Tuple.Extra (fst3)+import           Data.Ratio (Ratio, (%))++import Data.Maybe++import Data.Sam+import FileManagement+import FileOrStream (asSamStream, FileOrStream(..))+import Language+import Output++import NGLess.NGLEnvironment+import NGLess++import Utils.Conduit++data SelectCondition = SelectMapped | SelectUnmapped | SelectUnique+    deriving (Eq, Show)++data MatchCondition = KeepIf [SelectCondition] | DropIf [SelectCondition]+    deriving (Eq, Show)++_parseConditions :: KwArgsValues -> NGLessIO MatchCondition+_parseConditions args = do+        keep_if <- lookupSymbolListOrScriptErrorDef (return []) "arguments to select" "keep_if" args+        drop_if <- lookupSymbolListOrScriptErrorDef (return []) "arguments to select" "drop_if" args+        keep_if' <- mapM asSC keep_if+        drop_if' <- mapM asSC drop_if+        case (keep_if', drop_if') of+            (cs, []) -> return $! KeepIf cs+            ([], cs) -> return $! DropIf cs+            (_, _) -> throwScriptError "To select, you cannot use both keep_if and drop_if"+    where+        asSC :: T.Text -> NGLessIO SelectCondition+        asSC "mapped" = return SelectMapped+        asSC "unmapped" = return SelectUnmapped+        asSC "unique" = return SelectUnique+        asSC c = throwShouldNotOccur ("Check failed.  Should not have seen this condition: '" ++ show c ++ "'")++-- Notes on "Sequence reinjection"+--+-- Here is the case where it is necessary:+--  1) the aligner includes the sequence in SamLine 1 (typically, the best hit, by its standards)+--  2) we filter out SamLine 1, but keep SamLine 2 (this is a rare case, a few in a million)+--  3) SamLine 2 does not have sequence information, so we need to reinject it+--+-- Here is why we need to rewrite the CIGAR string:+--  1) there are two forms of trimming in CIGAR: hard & soft. Hard means that+--  the bases were removed from the reads, whilst soft means that they are+--  kept. If one of the lines uses hard trimming and the other one uses soft+--  trimming, the read length may not match correctly+--  2) we want to keep the full sequence, so we want to use soft trimming (if+--  at all possible)+matchConditions :: Bool -> MatchCondition -> [(SamLine,B.ByteString)] -> NGLess [(SamLine, B.ByteString)]+matchConditions doReinject conds sg =+    let sg' = matchConditions' conds sg+        in if doReinject+            then reinjectSequencesIfNeeded sg sg'+            else pure sg'++toStrictBS :: BB.Builder -> B.ByteString+toStrictBS = BL.toStrict . BB.toLazyByteString+++reinjectSequencesIfNeeded :: [(SamLine,B.ByteString)] -> [(SamLine,B.ByteString)] -> NGLess [(SamLine,B.ByteString)]+reinjectSequencesIfNeeded _ filtered@((SamHeader{},_):_) = return filtered+reinjectSequencesIfNeeded orig filtered =+        if needsReinject (fmap fst filtered)+            then do+                filtered' <- reinjectSequences (fmap fst orig) (fmap fst filtered)+                return $ fmap (\s -> (s, toStrictBS $ encodeSamLine s)) filtered'+            else return filtered+    where+        needsReinject :: [SamLine] -> Bool+        needsReinject fs = let (fs1, fs2, fs0) = splitSamlines3 fs+                            in needsReinject' fs1 || needsReinject' fs2 || needsReinject' fs0+        needsReinject' :: [SamLine] -> Bool+        needsReinject' [] = False+        needsReinject' xs = not (any hasSequence xs)++-- See note above on "Sequence reinjection" about why this function is necessary+reinjectSequences :: [SamLine] -> [SamLine] -> NGLess [SamLine]+reinjectSequences original filtered = case (splitSamlines3 original, splitSamlines3 filtered) of+    ((o1, o2, os), (f1, f2, fs)) -> do+        r1 <- reinjectSequences' o1 f1+        r2 <- reinjectSequences' o2 f2+        ss <- reinjectSequences' os fs+        return (r1 ++ r2 ++ ss)+reinjectSequences' :: [SamLine] -> [SamLine] -> NGLess [SamLine]+reinjectSequences' original f@(s@SamLine{}:rs)+    | not (any hasSequence f) = let+                fixed = flip map (filter hasSequence original) $ \s' -> do+                    cigar <- fixCigar (samCigar s) (samLength s')+                    return (s { samSeq = samSeq s', samQual = samQual s', samCigar = cigar }:rs)+                asum' [] = return f+                asum' (x:xs) = case x of+                    Right{} -> x+                    Left{} -> asum' xs+            in asum' fixed+reinjectSequences' _ f = return f+-- See note above on "Sequence reinjection" about why this function is necessary+fixCigar :: B.ByteString -> Int -> NGLess B.ByteString+fixCigar prev n = do+    prevM <- matchSize' True True prev+    if prevM == n+        then return prev+        else do+            let prev' = B8.map (\c -> if c == 'H' then 'S' else c) prev+            prevM' <- matchSize' True True prev'+            if prevM' == n+                then return prev'+                else throwDataError ("Cannot fix CIGAR string \"" ++ B8.unpack prev ++ "\" to represent a sequence of length " ++ show n)++matchConditions' :: MatchCondition -> [(SamLine,B.ByteString)] -> [(SamLine, B.ByteString)]+matchConditions' _ r@[(SamHeader _,_)] = r+matchConditions' (DropIf []) slines = slines+matchConditions' (DropIf (c:cs)) slines = matchConditions' (DropIf cs) (drop1 c slines)++matchConditions' (KeepIf []) slines = slines+matchConditions' (KeepIf (c:cs)) slines = matchConditions' (KeepIf cs) (keep1 c slines)++drop1 SelectUnmapped g = filter (isAligned . fst) g+drop1 SelectMapped g = if any (isAligned . fst) g+                            then []+                            else g+drop1 SelectUnique g = if isGroupUnique (map fst g) then [] else g++keep1 SelectMapped g = filter (isAligned . fst) g+keep1 SelectUnmapped g = if any (isAligned . fst) g+                            then []+                            else g+keep1 SelectUnique g = if isGroupUnique (map fst g) then g else []++-- readSamGroupsAsConduit :: (MonadIO m, MonadResource m) => FileOrStream -> C.Producer m [(SamLine, B.ByteString)]+-- The reason we cannot just use readSamGroupsC is that we want to get the unparsed ByteString on the side+readSamGroupsAsConduit istream paired =+        istream+            .| CC.concat+            .| readSamLineOrDie+            .| CL.groupBy groupLine+    where+        readSamLineOrDie = C.awaitForever $ \(ByteLine line) ->+            case readSamLine line of+                Left err -> throwError err+                Right parsed -> C.yield (parsed,line)+        groupLine (SamHeader _,_) _ = False+        groupLine _ (SamHeader _,_) = False+        groupLine (s0,_) (s1,_)+            | paired = samQName s0 == samQName s1+            | otherwise = samQName s0 == samQName s1 && isFirstInPair s0 == isFirstInPair s1+++executeSelect :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeSelect (NGOMappedReadSet name istream ref) args = do+    paired <- lookupBoolOrScriptErrorDef (return True) "select" "paired" args+    conditions <- _parseConditions args+    Just lno <- ngleLno <$> nglEnvironment+    doReinject <- do+        v <- ngleVersion <$> nglEnvironment+        if v < NGLVersion 0 8+            then do+                outputListLno' WarningOutput ["Select changed behaviour (for the better) in ngless 0.8. If possible, upgrade your version statement."]+                return False+            else return True+    let (fpsam, istream') = asSamStream istream+        stream =+            readSamGroupsAsConduit istream' paired+                .| CL.mapM (runNGLess . matchConditions doReinject conditions)+                .| streamedSamStats lno ("select_"++T.unpack name) ("select.lno"++show lno)+                .| CL.map (V.fromList . map (ByteLine . snd))++        out = Stream [istream] ("selected_" ++ takeBaseNameNoExtensions fpsam ++ ".sam") stream+    return $! NGOMappedReadSet name out ref+executeSelect o _ = throwShouldNotOccur ("NGLESS type checking error (Select received " ++ show o ++ ")")++streamedSamStats lno ifile ref = C.passthroughSink (CL.map (V.singleton . map fst) .| samStatsC') $ \(total, aligned, unique) ->+    outputMappedSetStatistics (MappingInfo lno ifile ref total aligned unique)+++splitSamlines3 = reverse3 . foldl' add1 ([],[],[])+    where+        reverse3 (g1, g2, gs) = (reverse g1, reverse g2, reverse gs)+        add1 (g1,g2,gs) s+            | isFirstInPair s = (s:g1,g2,gs)+            | isSecondInPair s = (g1, s:g2, gs)+            | otherwise = (g1, g2, s:gs)++data FilterAction = FADrop | FAUnmatch+    deriving (Eq)++data SelectGroupOptions = SelectGroupOptions+    !Double -- ^ min id+    !Int -- ^ minMatchSize+    !Int -- ^ maxTrim+    !Bool -- ^ reverse+    !FilterAction++applySelect :: Bool -> SelectGroupOptions -> SamGroup -> SamGroup+applySelect useNewer (SelectGroupOptions minID minMatchSize (-1) rev act) =+                    case act of+                        FADrop -> filter passTest+                        FAUnmatch -> map (unmatchUnless passTest)+    where+        okID+            | minID < 0.0 = const True+            | otherwise = \s -> fromRight 0.0 (matchIdentity useNewer s) >= minID+        okSize :: SamLine -> Bool+        okSize+            | minMatchSize == -1 = const True+            | otherwise = \s -> fromRight 0 (matchSize useNewer s) >= minMatchSize+        rawTest s = okID s && okSize s+        passTest+            | rev = not . rawTest+            | otherwise = rawTest+applySelect useNewer (SelectGroupOptions minID minMatch maxTrim rev act) = \samlines ->+                    let samlines' = applySelect useNewer (SelectGroupOptions minID minMatch (-1) rev act) samlines+                        (g1,g2,gs) = splitSamlines3 samlines'+                        (s1,s2,ss) = (seqSize g1, seqSize g2, seqSize gs)+                        okTrim :: Int -> SamLine -> Bool+                        okTrim seqlen = \s -> (seqlen - fromRight 0 (matchSize useNewer s) <= maxTrim)+                        in case act of+                            FADrop -> filter (okTrim s1) g1 ++ filter (okTrim s2) g2 ++ filter (okTrim ss) gs+                            FAUnmatch -> map (unmatchUnless $ okTrim s1) g1 ++ map (unmatchUnless $ okTrim s2) g2 ++ map (unmatchUnless $ okTrim ss) gs++unmatchUnless c s+    | not (c s) = unmatch s+    | otherwise = s+unmatch samline = samline { samFlag = (samFlag samline .|. 4) `clearBit` 1, samRName = "*", samCigar = "*" }+seqSize :: SamGroup -> Int+seqSize = maximum . map (B.length . samSeq)++executeMappedReadMethod :: MethodName -> [SamLine] -> Maybe NGLessObject -> KwArgsValues -> NGLess NGLessObject+executeMappedReadMethod (MethodName "flag") samlines (Just (NGOSymbol flag)) [] = do+        f <- getFlag flag+        return (NGOBool $ f samlines)+    where+        getFlag :: T.Text -> NGLess ([SamLine] -> Bool)+        getFlag "mapped" = return (any isAligned)+        getFlag "unmapped" = return (not . any isAligned)+        getFlag ferror = throwScriptError ("Flag " ++ show ferror ++ " is unknown for method flag")+executeMappedReadMethod (MethodName "some_match") samlines (Just (NGOString target)) [] = return . NGOBool $ any ismatch samlines+    where+        ismatch :: SamLine -> Bool+        ismatch = (==target') . samRName+        target' = TE.encodeUtf8 target+executeMappedReadMethod (MethodName "pe_filter") samlines Nothing [] = return . NGOMappedRead . filterPE $ samlines+executeMappedReadMethod (MethodName "filter") samlines Nothing kwargs = do+    minID <- lookupIntegerOrScriptErrorDef (return (-1)) "filter method" "min_identity_pc" kwargs+    minMatchSize <- fromInteger <$> lookupIntegerOrScriptErrorDef (return (-1)) "filter method" "min_match_size" kwargs+    maxTrim <- fromInteger <$> lookupIntegerOrScriptErrorDef (return (-1)) "filter method" "max_trim" kwargs+    reverseTest <- lookupBoolOrScriptErrorDef (return False) "filter method" "reverse" kwargs+    useNewer <- lookupBoolOrScriptErrorDef (return False) "filter method" "__version11_or_higher" kwargs+    action <- lookupSymbolOrScriptErrorDef (return "drop") "filter method" "action" kwargs >>= \case+        "drop" -> return FADrop+        "unmatch" -> return FAUnmatch+        other -> throwScriptError ("unknown action in filter(): `" ++ T.unpack other ++"`.\nAllowed values are:\n\tdrop\n\tunmatch\n\tkeep\n")+    let samlines' = applySelect useNewer (SelectGroupOptions (fromInteger minID / 100.0) minMatchSize maxTrim reverseTest action) samlines+    return (NGOMappedRead samlines')+executeMappedReadMethod (MethodName "unique") samlines Nothing [] = return . NGOMappedRead . mUnique $ samlines+executeMappedReadMethod (MethodName "allbest") samlines Nothing kwargs = do+    useNewer <- lookupBoolOrScriptErrorDef (return False) "filter method" "__version11_or_higher" kwargs+    return . NGOMappedRead . mBesthit useNewer $ samlines+executeMappedReadMethod m self arg kwargs = throwShouldNotOccur ("Method " ++ show m ++ " with self="++show self ++ " arg="++ show arg ++ " kwargs="++show kwargs ++ " is not implemented")++filterPE :: [SamLine] -> [SamLine]+filterPE slines = (filterPE' . filter isAligned) slines+    where+        filterPE' [] = []+        filterPE' (sl:sls)+            | isPositive sl = case findMatch sl slines of+                    Just sl2 -> sl:sl2:filterPE' sls+                    Nothing -> filterPE' sls+            | otherwise = filterPE' sls+        findMatch target = listToMaybe . filter (isMatch target)+        isMatch target other = isNegative other && samRName target == samRName other++mUnique :: [SamLine] -> [SamLine]+mUnique slines+    | isGroupUnique slines = slines+    | otherwise = []++mBesthit :: Bool -> [SamLine] -> [SamLine]+mBesthit _ [] = []+mBesthit _ sl@[_] = sl+mBesthit useNewer slines = let (g1,g2,gs) = splitSamlines3 slines+                    in mBesthit' useNewer g1 ++ mBesthit' useNewer g2 ++ mBesthit' useNewer gs++mBesthit' :: Bool -> [SamLine] -> [SamLine]+mBesthit' _ [] = []+mBesthit' _ sl@[_] = sl+mBesthit' useNewer samlines = case mapMaybe extract samlines of+        [] -> samlines+        extracted ->+            let+                ms = maximum (fst3 <$> extracted)+                -- fractional distance+                ds :: Ratio Int+                ds = minimum ((\(_, e, _) -> e % ms) <$> extracted)+            in mapMaybe (\(_, e, sl) ->+                        if e % ms <= ds+                            then Just sl+                            else Nothing) extracted++    where+        extract :: SamLine -> Maybe (Int, Int, SamLine)+        extract sl = do+            dist <- samIntTag sl "NM"+            size <- eitherToMaybe (matchSize useNewer sl)+            return (size, dist, sl)++isGroupUnique :: [SamLine] -> Bool+isGroupUnique [] = True+isGroupUnique [_] = True+isGroupUnique [f,s] = (isFirstInPair f /= isFirstInPair s) &&+                            (not (isAligned f && isAligned s) || (samRName f == samRName s))+isGroupUnique _ = False+
+ NGLess/Interpretation/Substrim.hs view
@@ -0,0 +1,105 @@+{- Copyright 2013-2018 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE OverloadedStrings #-}++module Interpretation.Substrim+    ( substrim+    , endstrim+    , smoothtrim+    , EndstrimEnds(..)+    , subtrimPos+    , endstrimPos+    , smoothtrimPos+    ) where++import qualified Data.Vector.Storable as VS++import Data.Maybe+import Data.Int++import Data.FastQ++data EndstrimEnds = EndstrimBoth | Endstrim3 | Endstrim5+    deriving (Show, Enum, Eq)++substrim :: Int -> ShortRead -> ShortRead+substrim cutoff sr@(ShortRead _ _ rQ) = srSlice s n sr+    where (s,n) = subtrimPos rQ (toEnum cutoff)++endstrim :: EndstrimEnds -> Int -> ShortRead -> ShortRead+endstrim ends cutoff sr@(ShortRead _ _ rQ) = srSlice s n sr+    where (s,n) = endstrimPos ends rQ (toEnum cutoff)++-- |Run a sliding window across the read and cut when average quality in given window+--  drops below the requested value.+smoothtrim :: Int -> Int -> ShortRead -> ShortRead+smoothtrim window cutoff sr@(ShortRead _ _ rQ) = srSlice start numbases sr+    where (start,numbases) = smoothtrimPos window rQ (toEnum cutoff)++data S4 = S4 {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int+-- Receives a Quality array and returns a pair with the index and size of the subsequence which has the most consecutive bps respecting the cutoff.+subtrimPos :: VS.Vector Int8 -> Int8 -> (Int,Int)+subtrimPos quality cutoff = case VS.foldl' calcSubStrim' (S4 0 0 0 0) quality of+                              S4 i s _ _ -> (i, s)+    where+        calcSubStrim' :: S4 -> Int8 -> S4+        calcSubStrim' (S4 i s n_i n_s) q+          | q < cutoff = S4 i s (n_s + n_i + 1) 0 --new start index n_s + n_i + 1+          | n_s + 1 > s = S4 n_i (n_s + 1) n_i (n_s + 1)+          | otherwise = S4 i s n_i (n_s + 1)++endstrimPos :: EndstrimEnds -> VS.Vector Int8 -> Int8 -> (Int, Int)+endstrimPos method quality cutoff = (start, trim3p $ VS.drop start quality)+    where+        start+            | do5 = fromMaybe len $ VS.findIndex (>= cutoff) quality+            | otherwise = 0+        do5 = method `elem` [Endstrim5, EndstrimBoth]+        do3 = method `elem` [Endstrim3, EndstrimBoth]+        len = VS.length quality+        trim3p qs+            | do3 = trim3p' (VS.length qs) qs+            | otherwise = VS.length qs+        trim3p' :: Int -> VS.Vector Int8 -> Int+        trim3p' 0 _ = 0+        trim3p' n qs+            | qs VS.! (n - 1) >= cutoff = n+            | otherwise = trim3p' (n - 1) qs+++smoothtrimPos :: Int -> VS.Vector Int8 -> Int8 -> (Int, Int)+smoothtrimPos window quality cutoff = if VS.null quality+                                         then (0, 0)+                                         else subtrimPos smoothedQuality cutoff+    where+        qHead = VS.head quality+        qLast = VS.last quality++        -- We pad the original quality values left and right by repeating+        -- the last value on each edge. this allows averaging the quality+        -- of each position taking into account values of surrounding+        -- bases given the specified window++        -- For a window of size n we need to pad n-1 bases divided between+        -- both ends of the read+        -- With even numbers the left pad is 1 unit smaller than the right+        pad = window - 1+        left_pad = pad `div` 2+        right_pad = pad - left_pad++        quals = VS.replicate left_pad qHead VS.++ quality VS.++ VS.replicate right_pad qLast++        -- |Computes mean of a sliding window from starting position to user-specified window size+        meanSlideWindow :: Int -> Int8+        meanSlideWindow start = intRoundMean (VS.slice start window quals) window++        -- If we compute the mean of the window with Int8 we will overflow easily+        -- and to avoid integer division that always floors we work with doubles+        -- and round back to Int8 afterwards+        intRoundMean :: VS.Vector Int8 -> Int -> Int8+        intRoundMean q w = round $ (fromIntegral $ VS.sum $ VS.map fromEnum q) / (fromIntegral w :: Double)++        -- Finally we smooth the quality values on each window and create a new+        -- quality vector that will be passed to subtrimPos+        smoothedQuality = VS.unfoldrN (VS.length quality) (\n -> Just (meanSlideWindow n, n+1)) 0
+ NGLess/Interpretation/Unique.hs view
@@ -0,0 +1,102 @@+{- Copyright 2013-2019 NGLess Authors+ - License: MIT+ -}++module Interpretation.Unique+    ( executeUnique+    , performUnique+    ) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)++import System.IO+import Data.Hashable+import System.FilePath+import System.Directory+import Data.Maybe (fromMaybe)+import qualified Data.Vector as V++import qualified Data.ByteString as B+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Utils (awaitJust)+import qualified Data.Conduit.Algorithms.Async as CAlg+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)++import FileManagement (createTempDir, makeNGLTempFile)+import Data.FastQ+import NGLess+import Language+import Utils.Conduit (linesC)+import Output++import qualified Data.HashTable.IO as H++maxTempFileSize :: Double+maxTempFileSize = 512*1000*1000 -- 512MB++executeUnique :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeUnique (NGOList e) args = NGOList <$> mapM (`executeUnique` args) e+executeUnique (NGOReadSet name (ReadSet [] [FastQFilePath enc fname])) args = do+    mc <- fromInteger <$> lookupIntegerOrScriptErrorDef (return 1) "unique argument" "max_copies" args+    newfp <- performUnique fname enc mc+    return (NGOReadSet name $ ReadSet [] [FastQFilePath enc newfp])+executeUnique expr _ = throwShouldNotOccur ("executeUnique: Cannot handle argument " ++ show expr)++performUnique :: FilePath -> FastQEncoding -> Int -> NGLessIO FilePath+performUnique fname enc mc = do+        (_,dest) <- createTempDir fname+        k <- liftIO $ do+                fsize <- withFile fname ReadMode hFileSize+                return . ceiling $! (fromInteger fsize / maxTempFileSize)+        fhs  <- liftIO $ V.generateM k $ \n ->+                            openFile (dest </> show n) AppendMode+        C.runConduitRes $+            conduitPossiblyCompressedFile fname+                .| linesC+                .| fqDecodeC fname enc+                .| CL.mapM_ (multiplex k fhs)+        V.mapM_ (liftIO . hClose) fhs+        outputListLno' DebugOutput ["Wrote N Files to: ", dest]+        makeNGLTempFile fname "" "fq.gz" $ \h ->+            C.runConduit $+                readNFiles enc mc dest+                    .| fqEncodeC enc+                    .| CAlg.asyncGzipTo h+    where+        multiplex k fhs r = liftIO $+                B.hPutStr (fhs V.! hashRead k r) (fqEncode enc r)++hashRead :: Int -> ShortRead -> Int+hashRead k (ShortRead _ r _) = mod (hash r) k+++readNFiles :: FastQEncoding -> Int -> FilePath -> C.ConduitT () ShortRead NGLessIO ()+readNFiles enc k d = do+    fs <- liftIO $ getDirectoryContents d+    let fs' = map (d </>) (filter (`notElem` [".", ".."]) fs)+    mapM_ (readUniqueFile k enc) fs'+++readUniqueFile :: Int -> FastQEncoding -> FilePath -> C.ConduitT () ShortRead NGLessIO ()+readUniqueFile k enc fname =+    CC.sourceFile fname+        .| linesC+        .| fqDecodeC fname enc+        .| filterUniqueUpTo k+++filterUniqueUpTo :: Int -> C.ConduitT ShortRead ShortRead NGLessIO ()+filterUniqueUpTo k = liftIO H.new >>= filterUniqueUpTo'+    where+        filterUniqueUpTo' :: H.CuckooHashTable B.ByteString Int -> C.ConduitT ShortRead ShortRead NGLessIO ()+        filterUniqueUpTo' ht = awaitJust $ \sr -> do+            cur <- fromMaybe 0 <$> liftIO (H.lookup ht (srSequence sr))+            when (cur < k) $ do+                liftIO $ H.insert ht (srSequence sr) (cur + 1)+                C.yield sr+            filterUniqueUpTo' ht+
+ NGLess/Interpretation/Write.hs view
@@ -0,0 +1,269 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE FlexibleContexts, CPP #-}++module Interpretation.Write+    ( executeWrite+    , moveOrCopyCompress+#ifdef IS_BUILDING_TEST+    , _formatFQOname+#endif+    ) where++++import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.Combinators as C+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import qualified Data.Conduit.Algorithms.Async as CAsync+import           Data.Conduit ((.|))+import           System.Directory (copyFile)+import           Data.Maybe+import           Data.String.Utils (replace, endswith)+import           Control.Monad.IO.Unlift (MonadUnliftIO)+import           Control.Monad.Except+import           Control.Monad.Catch (MonadMask)+import           System.IO (Handle, stdout)+import           Data.List (isInfixOf)+import           Control.Concurrent.Async (concurrently_)++import Data.FastQ+import Language+import Configuration+import FileOrStream+import FileManagement (makeNGLTempFile, inferCompression, Compression(..))+import NGLess+import Output+import NGLess.NGLEnvironment+import Utils.Samtools (convertSamToBam, convertBamToSam)+import Utils.Conduit+import Utils.Utils (withOutputFile, fmapMaybeM, moveOrCopy)++{- A few notes:+    There is a transform pass which adds the argument __can_move to write() calls.+    If canMove is True, then we can move the input instead of copying as it+    will no longer be used in the script.++    Decisions on whether to use compression are based on the filenames.++    The filepath "/dev/stdout" is special cased to print to stdout+-}++data WriteOptions = WriteOptions+                { woOFile :: FilePath+                , woFormat :: Maybe T.Text+                , woFormatFlags :: Maybe T.Text+                , woCanMove :: Bool+                , woVerbose :: Bool+                , woComment :: Maybe T.Text+                , woAutoComment :: [AutoComment]+                , woHash :: T.Text+                } deriving (Eq)+++ostream fp = case inferCompression fp of+    NoCompression -> CB.sinkHandle+    GzipCompression -> CAsync.asyncGzipTo+    BZ2Compression -> CAsync.asyncBzip2To+    XZCompression -> CAsync.asyncXzTo+    ZStdCompression -> CAsync.asyncZstdTo 3 -- compression level++withOutputFile' :: (MonadUnliftIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a+withOutputFile' "/dev/stdout" = \inner -> inner stdout+withOutputFile' fname = withOutputFile fname++parseWriteOptions :: KwArgsValues -> NGLessIO WriteOptions+parseWriteOptions args = do+    sub <- nConfSubsample <$> nglConfiguration+    let subpostfix = if sub then ".subsampled" else ""+    ofile <- case lookup "ofile" args of+        Just (NGOFilename p) -> return (p ++ subpostfix)+        Just (NGOString p) -> return (T.unpack p ++ subpostfix)+        _ -> throwShouldNotOccur "getOFile cannot decode file path"+    format <- fmapMaybeM (symbolOrTypeError "format argument to write() function") (lookup "format" args)+    canMove <- lookupBoolOrScriptErrorDef (return False) "internal write arg" "__can_move" args+    verbose <- lookupBoolOrScriptErrorDef (return False) "write arg" "verbose" args+    comment <- fmapMaybeM (stringOrTypeError "comment argument to write() function") (lookup "comment" args)+    autoComments <- case lookup "auto_comments" args of+                        Nothing -> return []+                        Just (NGOList cs) -> mapM (\s -> do+                                                        let errmsg = "auto_comments argument in write() call"+                                                        symbolOrTypeError errmsg s >>=+                                                            decodeSymbolOrError errmsg+                                                                [("date", AutoDate)+                                                                ,("script", AutoScript)+                                                                ,("hash", AutoResultHash)]) cs+                        _ -> throwScriptError "auto_comments argument to write() call must be a list of symbols"+    hash <- lookupStringOrScriptError "hidden __hash argument to write() function" "__hash" args+    formatFlags <- case lookup "format_flags" args of+                        Nothing -> return Nothing+                        Just (NGOSymbol flag) -> return $ Just flag+                        Just other -> throwScriptError $ "format_flags argument to write(): illegal argument ("++show other++")"+    return $! WriteOptions+                { woOFile = ofile+                , woFormat = format+                , woFormatFlags = formatFlags+                , woCanMove = canMove+                , woVerbose = verbose+                , woComment = comment+                , woAutoComment = autoComments+                , woHash = hash+                }+++moveOrCopyCompress :: Bool -> FilePath -> FilePath -> NGLessIO ()+moveOrCopyCompress moveAllowed ifile ofile = liftIO =<< moveOrCopyCompress' moveAllowed ifile ofile++moveOrCopyCompress' :: Bool -> FilePath -> FilePath -> NGLessIO (IO ())+moveOrCopyCompress' _ ifile "/dev/stdout" = return (C.runConduitRes $ conduitPossiblyCompressedFile ifile .| C.stdout)+moveOrCopyCompress' moveAllowed ifile ofile+        | ifile == ofile = return (return ()) -- trivial case. Can happen.+#ifdef WINDOWS+        | ocompression == BZ2Compression = throwNotImplementedError "Compression of bzip2 files is not supported on Windows"+        | icompression == BZ2Compression = throwNotImplementedError "Decompression of bzip2 files is not supported on Windows"+#endif+        | icompression == ocompression = moveIfAllowed+        | otherwise = convertCompression+    where+        moveIfAllowed :: NGLessIO (IO ())+        moveIfAllowed = do+                createdFiles <- ngleTemporaryFilesCreated <$> nglEnvironment+                if moveAllowed && ifile `elem` createdFiles+                    then return (moveOrCopy ifile ofile)+                    else return (copyFile ifile ofile)++        icompression = inferCompression ifile+        ocompression = inferCompression ofile++        convertCompression = return $+            withOutputFile' ofile $ \hout ->+                C.runConduitRes (conduitPossiblyCompressedFile ifile .| ostream ofile hout)+++removeEnd :: String -> String -> String+removeEnd base suffix = take (length base - length suffix) base++_formatFQOname :: MonadError NGError m => FilePath -> FilePath -> m FilePath+_formatFQOname base insert+    | endswith ".subsampled" base = _formatFQOname (take (length base - length (".subsampled" :: String)) base) (insert ++ ".subsampled")+    | "{index}" `isInfixOf` base = return $ replace "{index}" insert base+    | endswith ".fq" base = return $ removeEnd base ".fq" ++ "." ++ insert ++ ".fq"+    | endswith ".fq.gz" base = return $ removeEnd base ".fq.gz" ++ "." ++ insert ++ ".fq.gz"+    | endswith ".fq.bz2" base = return $ removeEnd base ".fq.bz2" ++ "." ++ insert ++ ".fq.bz2"+    | otherwise = throwScriptError ("Cannot handle filename " ++ base ++ " (expected extension .fq/.fq.gz/.fq.bz2).")++++executeWrite :: NGLessObject -> [(T.Text, NGLessObject)] -> NGLessIO NGLessObject+executeWrite (NGOList el) args = do+    templateFP <- woOFile <$> parseWriteOptions args+    let args' = filter (\(a,_) -> (a /= "ofile")) args+        fps = map ((\fname -> replace "{index}" fname templateFP) . show) [1..length el]+    zipWithM_ (\e fp -> executeWrite e (("ofile", NGOFilename fp):args')) el fps+    return (NGOFilename templateFP)++executeWrite (NGOReadSet _ rs) args = do+    opts <- parseWriteOptions args+    let ofile = woOFile opts+        moveOrCopyCompressFQs :: [FastQFilePath] -> FilePath -> NGLessIO (IO ())+        moveOrCopyCompressFQs [] _ = return (return ())+        moveOrCopyCompressFQs [FastQFilePath _ f] ofname = moveOrCopyCompress' (woCanMove opts) f ofname+        moveOrCopyCompressFQs multiple ofname = do+            let inputs = fqpathFilePath <$> multiple+            fp' <- makeNGLTempFile (head inputs) "concat" "tmp" $ \h ->+                C.runConduit+                    (mapM_ conduitPossiblyCompressedFile inputs .| C.sinkHandle h)+            moveOrCopyCompress' True fp' ofname+    if woFormatFlags opts == Just "interleaved"+        then+            withOutputFile' ofile $ \hout ->+                C.runConduitRes $+                    interleaveFQs rs .| ostream ofile hout+        else case rs of+            ReadSet [] singles ->+                liftIO =<< moveOrCopyCompressFQs singles ofile+            ReadSet pairs [] -> do+                fname1 <- _formatFQOname ofile "pair.1"+                fname2 <- _formatFQOname ofile "pair.2"+                cp1 <- moveOrCopyCompressFQs (fst <$> pairs) fname1+                cp2 <- moveOrCopyCompressFQs (snd <$> pairs) fname2+                liftIO $ cp1 `concurrently_` cp2+            ReadSet pairs singletons -> do+                fname1 <- _formatFQOname ofile "pair.1"+                fname2 <- _formatFQOname ofile "pair.2"+                fname3 <- _formatFQOname ofile "singles"+                cp1 <- moveOrCopyCompressFQs (fst <$> pairs) fname1+                cp2 <- moveOrCopyCompressFQs (snd <$> pairs) fname2+                cp3 <- moveOrCopyCompressFQs singletons fname3+                liftIO $ cp1 `concurrently_` cp2 `concurrently_` cp3+    return (NGOFilename ofile)++executeWrite el@(NGOMappedReadSet _ iout  _) args = do+    opts <- parseWriteOptions args+    fp <- asFile iout+    let guessFormat :: String -> NGLessIO T.Text+        guessFormat "/dev/stdout" = return "sam"+        guessFormat ofile+            | endswith ".sam" ofile = return "sam"+            | endswith ".sam.gz" ofile = return "sam"+            | endswith ".sam.bz2" ofile = return "sam"+            | endswith ".sam.zst" ofile = return "sam"+            | endswith ".sam.zstd" ofile = return "sam"+            | endswith ".bam" ofile = return "bam"+            | otherwise = do+                outputListLno' WarningOutput ["Cannot determine format of MappedReadSet output based on filename ('", ofile, "'). Defaulting to BAM."]+                return "bam"+    orig <- maybe (guessFormat (woOFile opts)) return (woFormat opts) >>= \case+        "sam"+            | endswith ".bam" fp -> convertBamToSam fp+            | otherwise -> return fp+        "bam"+            | endswith ".bam" fp -> return fp -- We already have a BAM, so just copy it+            | otherwise -> convertSamToBam fp+        s -> throwScriptError ("write does not accept format {" ++ T.unpack s ++ "} with input type " ++ show el)+    moveOrCopyCompress (woCanMove opts) orig (woOFile opts)+    return (NGOFilename $ woOFile opts)++executeWrite (NGOCounts iout) args = do+    opts <- parseWriteOptions args+    outputListLno' InfoOutput ["Writing counts to: ", woOFile opts]+    comment <- buildComment (woComment opts) (woAutoComment opts) (woHash opts)+    case fromMaybe "tsv" (woFormat opts) of+        "tsv" -> do+            fp <- asFile iout+            case comment of+                [] -> moveOrCopyCompress (woCanMove opts) fp (woOFile opts)+                _ -> C.runConduit $+                        (commentC "# " comment >> CB.sourceFile fp)+                        .| CB.sinkFileCautious (woOFile opts)+        "csv" -> do+            let (fp,istream) = asStream iout+            comma <- makeNGLTempFile fp "wcomma" "csv" $ \ohand ->+                C.runConduit $+                    ((commentC "# " comment .| linesVC 1024) >> istream)+                        .| CL.map (V.map tabToComma)+                        .| CC.concat+                        .| byteLineSinkHandle ohand+            moveOrCopyCompress True comma (woOFile opts)+        f -> throwScriptError ("Invalid format in write: {"++T.unpack f++"}.\n\tWhen writing counts, only accepted values are {tsv} (TAB separated values; default) or {csv} (COMMA separated values).")+    return (NGOFilename $ woOFile opts)+  where+    tabToComma :: ByteLine -> ByteLine+    tabToComma (ByteLine line) = ByteLine $ B8.map (\case { '\t' -> ','; c -> c }) line++executeWrite (NGOFilename fp) args = do+    opts <- parseWriteOptions args+    moveOrCopyCompress (woCanMove opts) fp (woOFile opts)+    return (NGOFilename $ woOFile opts)++executeWrite v _ = throwShouldNotOccur ("Error: executeWrite of " ++ show v ++ " not implemented yet.")++
+ NGLess/JSONScript.hs view
@@ -0,0 +1,100 @@+{- Copyright 2017-2022 NGLess Authors+ - License: MIT+ -}++module JSONScript+    ( writeScriptJSON+    ) where++import           System.IO.SafeWrite (withOutputFile)+import           Data.Aeson+import           Data.Aeson.Types (Pair)+import           Control.Arrow (second)+import           Data.String (fromString)+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL++import Language+++newtype EncHeader = EncHeader Header+instance ToJSON EncHeader where+    toJSON (EncHeader (Header ver mods)) = object+                            [ "ngless-version" .= toJSON ver+                            , "modules" .= toJSON (encodeMod <$> mods)+                            ]++jsonType :: String -> Pair+jsonType = ("type" .=)++sP :: T.Text -> T.Text -> Pair+sP a b = fromString (T.unpack a) .= b+++encodeMod (ModInfo n v) = object [jsonType "module", "name" .= n, "version" .= v]+encodeMod (LocalModInfo n v) = object [jsonType "local-module", "name" .= n, "version" .= v]+newtype EncExpression = EncExpression Expression++instance ToJSON EncExpression where+    toJSON (EncExpression e) = toJSONEx e++toJSONEx :: Expression -> Value+toJSONEx (Lookup t (Variable n)) = object [jsonType "lookup", "name" .= toJSON n, "ngless-type" .= encodeMaybeType t]+toJSONEx (ConstStr t) = toJSON t+toJSONEx (ConstInt i) = toJSON i+toJSONEx (ConstDouble d) = toJSON d+toJSONEx (ConstBool b) = toJSON b+toJSONEx (ConstSymbol s) = toJSON (T.concat ["{", s, "}"])+toJSONEx (BuiltinConstant (Variable v)) = toJSON v+toJSONEx (ListExpression exprs) = toJSON (toJSONEx <$> exprs)+toJSONEx Continue = object [jsonType "control0", "op" `sP` "continue"]+toJSONEx Discard = object [jsonType "control0", "op" `sP` "discard"]+toJSONEx (UnaryOp uop e) = object [jsonType "uop", "op" .= encodeUOp uop, "arg" .= toJSONEx e]+toJSONEx (BinaryOp bop el er) = object [jsonType "binop", "op" .= encodeBOp bop, "left" .= toJSONEx el, "right" .= toJSONEx er]+toJSONEx (Condition ec eT eF) = object [jsonType "control", "op" `sP` "if", "cond" .= toJSONEx ec, "if-true" .= toJSONEx eT, "if-false" .= toJSONEx eF]+toJSONEx (IndexExpression e ix) = object [jsonType "index", "arg" .= toJSONEx e, "index" .= toJSONIndex ix]+toJSONEx (Assignment (Variable n) e) = object [jsonType "assignment", "target" .= toJSON n, "value" .= toJSONEx e]+toJSONEx (FunctionCall (FuncName fn) e kwargs block) = object [jsonType "function", "fname" .= toJSON fn, "arg0" .= toJSONEx e, "kwargs" .= toJSONKwArgs kwargs, "block" .= encodeBlock block]+toJSONEx (MethodCall (MethodName mn) ethis marg kwargs) = object [jsonType "method", "mname" .= toJSON mn, "this" .= toJSONEx ethis, "arg0" .= toJSON (EncExpression <$> marg), "kwargs" .= toJSONKwArgs kwargs]+toJSONEx (Sequence es) = object [jsonType "control", "op" `sP` "sequence", "args" .= toJSON (toJSONEx <$> es)]+toJSONEx (Optimized oe) = object [jsonType "optimized", "value" .= encodeOpt oe]++toJSONIndex (IndexOne e) = object [jsonType "index1", "arg" .= toJSONEx e]+toJSONIndex (IndexTwo e0 e1) = object [jsonType "index2", "left" .= maybe Null toJSONEx e0, "right" .= maybe Null toJSONEx e1]++toJSONKwArgs kwargs = object [fromString (T.unpack n) .= toJSONEx e | (Variable n, e) <- kwargs]++encodeOpt (LenThresholdDiscard (Variable n) bop t) = object [jsonType "len-threshold", "name" .= toJSON n, "op" .= encodeBOp bop, "thresh" .= toJSON t]+encodeOpt (SubstrimReassign (Variable n) mq) = object [jsonType "substrim-reassign", "name" .= toJSON n, "minqual" .= toJSON mq]++encodeBlock Nothing = Null+encodeBlock (Just (Block (Variable n) e)) = object [jsonType "block", "variables" .= [toJSON n], "body" .= toJSONEx e]++encodeBOp :: BOp -> T.Text+encodeBOp BOpAdd = "add"+encodeBOp BOpMul = "mul"+encodeBOp BOpGT = "gt"+encodeBOp BOpGTE = "gte"+encodeBOp BOpLT = "lt"+encodeBOp BOpLTE = "lte"+encodeBOp BOpEQ = "eq"+encodeBOp BOpNEQ = "neq"++encodeBOp BOpPathAppend = "path_append"++encodeUOp :: UOp -> String+encodeUOp UOpLen = "len"+encodeUOp UOpMinus = "negate"+encodeUOp UOpNot = "not"++encodeMaybeType Nothing = Null+encodeMaybeType (Just t) = toJSON $ show t++writeScriptJSON :: FilePath -> Script -> Script -> IO ()+writeScriptJSON fname osc tsc =+    withOutputFile fname $ \hout ->+        BL.hPutStr hout $ encode $ object+                [ "header" .= toJSON (EncHeader <$> nglHeader osc)+                , "original-script" .= toJSON (second EncExpression <$> nglBody osc)+                , "transformed-script" .= toJSON (second EncExpression <$> nglBody tsc)+                ]
+ NGLess/Language.hs view
@@ -0,0 +1,284 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}++module Language+    ( Expression(..)+    , OptimizedExpression(..)+    , Variable(..)+    , UOp(..)+    , BOp(..)+    , Index(..)+    , Block(..)+    , FuncName(..)+    , MethodName(..)+    , NGLType(..)+    , ReadSet(..)+    , Header(..)+    , ModInfo(..)+    , Script(..)+    , NGLessObject(..)+    , recursiveAnalyse+    , recursiveTransform+    , usedVariables+    , staticValue+    , evalBinary+    ) where++{- This module defines the internal representation the language -}+import qualified Data.Text as T+import           Data.Either.Extra (eitherToMaybe)+import           Control.Monad.Extra (whenJust)+import           Control.Monad.Writer+import           System.FilePath ((</>))++import Data.FastQ+import Data.Sam+import NGLess.NGError+import FileOrStream.Types (FileOrStream(..))++newtype Variable = Variable T.Text+    deriving (Eq, Ord, Show)++newtype FuncName = FuncName { unwrapFuncName :: T.Text }+    deriving (Eq, Ord)++instance Show FuncName where+    show (FuncName f) = T.unpack f++newtype MethodName = MethodName { unwrapMethodName :: T.Text }+    deriving (Eq, Ord, Show)++-- | unary operators+data UOp = UOpLen | UOpMinus | UOpNot+    deriving (Eq, Ord, Show)++-- | binary operators+data BOp = BOpAdd | BOpMul | BOpGT | BOpGTE | BOpLT | BOpLTE | BOpEQ | BOpNEQ | BOpPathAppend+    deriving (Eq, Ord, Show)++-- | index expression encodes what is inside an index variable+-- either [a] (IndexOne) or [a:b] (IndexTwo)+data Index = IndexOne Expression+            | IndexTwo (Maybe Expression) (Maybe Expression)+    deriving (Eq, Ord, Show)++-- | a block is+--  f(a) using |inputvariables|:+--      expression+data Block = Block+                { blockVariable :: Variable -- ^ input argument+                , blockBody :: Expression -- ^ block body, will likely be Sequence+                }+    deriving (Eq, Ord, Show)++data NGLType =+        NGLString+        | NGLInteger+        | NGLDouble+        | NGLBool+        | NGLSymbol+        | NGLFilename+        | NGLRead+        | NGLReadSet+        | NGLMappedRead+        | NGLMappedReadSet+        | NGLSequenceSet+        | NGLCounts+        | NGLVoid+        | NGLAny+        | NGList !NGLType+    deriving (Eq, Ord, Show)+++data NGLessObject =+        NGOString !T.Text+        | NGOBool !Bool+        | NGOInteger !Integer+        | NGODouble !Double+        | NGOSymbol !T.Text+        | NGOFilename !FilePath+        | NGOShortRead !ShortRead+        | NGOReadSet T.Text ReadSet+        | NGOSequenceSet FileOrStream+        | NGOMappedReadSet+                    { nglgroupName :: T.Text+                    , nglSamFile :: FileOrStream+                    , nglReference :: Maybe T.Text+                    }+        | NGOMappedRead [SamLine]+        | NGOCounts FileOrStream+        | NGOVoid+        | NGOList [NGLessObject]+    deriving (Eq, Show)+++-- | 'Expression' is the main type for holding the AST.++data Expression =+        Lookup (Maybe NGLType) Variable -- ^ This looks up the variable name+        | ConstStr !T.Text -- ^ constant string+        | ConstInt !Integer -- ^ integer+        | ConstDouble !Double -- ^ integer+        | ConstBool !Bool -- ^ true/false+        | ConstSymbol !T.Text -- ^ a symbol+        | BuiltinConstant !Variable -- ^ built-in constant+        | ListExpression [Expression] -- ^ a list+        | Continue -- ^ continue+        | Discard -- ^ discard+        | UnaryOp UOp Expression  -- ^ op ( expr )+        | BinaryOp BOp Expression Expression -- ^ expr bop expr+        | Condition Expression Expression Expression -- ^ if condition: true-expr else: false-expr+        | IndexExpression Expression !Index -- ^ expr [ index ]+        | Assignment Variable Expression -- ^ var = expr+        | FunctionCall FuncName Expression [(Variable, Expression)] (Maybe Block)+        | MethodCall MethodName Expression (Maybe Expression) [(Variable, Expression)] -- ^ expr.method(expre)+        | Sequence [Expression]+        | Optimized OptimizedExpression -- This is a special case, used internally+    deriving (Eq, Ord)++data OptimizedExpression =+        LenThresholdDiscard Variable BOp Int -- if len(r) <op> <int>: discard+        | SubstrimReassign Variable Int -- r = substrim(r, min_quality=<int>)+    deriving (Eq, Ord, Show)++instance Show Expression where+    show (Lookup (Just t) (Variable v)) = "Lookup '"++T.unpack v++"' as "++show t+    show (Lookup Nothing (Variable v)) = "Lookup '"++T.unpack v++"' (type unknown)"+    show (ConstStr t) = show t+    show (ConstInt n) = show n+    show (ConstDouble f) = show f+    show (ConstBool b) = show b+    show (ConstSymbol t) = "{"++T.unpack t++"}"+    show (BuiltinConstant (Variable v)) = T.unpack v+    show (ListExpression e) = show e+    show Continue = "continue"+    show Discard = "discard"+    show (UnaryOp UOpLen a) = "len("++show a++")"+    show (UnaryOp op a) = show op ++ "(" ++ show a ++ ")"+    show (BinaryOp op a b) = "BinaryOp" ++ "(" ++ show a ++ " -" ++ show op ++ "- " ++ show b ++ ")"+    show (Condition c a b) = "if ["++show c ++"] then {"++show a++"} else {"++show b++"}"+    show (IndexExpression a ix) = show a ++ "[" ++ show ix ++ "]"+    show (Assignment (Variable v) a) = T.unpack v++" = "++show a+    show (FunctionCall fname a args block) = show fname ++ "(" ++ show a ++ showArgs args ++ ")"+                                    ++ (case block of+                                        Nothing -> ""+                                        Just b -> "using {"++show b ++ "}")+    show (MethodCall mname self a args) = "(" ++ show self ++ ")." ++ show mname ++ "( " ++ show a ++ showArgs args ++ " )"+    show (Sequence e) = "Sequence " ++ show e+    show (Optimized se) = "Optimized (" ++ show se ++ ")"++showArgs [] = ""+showArgs ((Variable v, e):args) = "; "++T.unpack v++"="++show e++showArgs args++{-- Extract static (ie, constant) values from expressions, if possible -}+staticValue :: Expression -> Maybe NGLessObject+staticValue (ConstStr s) = Just $ NGOString s+staticValue (ConstInt v) = Just $ NGOInteger v+staticValue (ConstBool b) = Just $ NGOBool b+staticValue (ConstSymbol s) = Just $ NGOSymbol s+staticValue (BinaryOp bop e1 e2) = do+    v1 <- staticValue e1+    v2 <- staticValue e2+    eitherToMaybe $ evalBinary bop v1 v2+staticValue (ListExpression e) = NGOList <$> mapM staticValue e+staticValue _ = Nothing++asDouble :: NGLessObject -> NGLess Double+asDouble (NGODouble d) = return d+asDouble (NGOInteger i) = return $ fromIntegral i+asDouble other = throwScriptError ("Expected numeric value, got: " ++ show other)++-- Binary Evaluation+evalBinary :: BOp ->  NGLessObject -> NGLessObject -> Either NGError NGLessObject+evalBinary BOpAdd (NGOInteger a) (NGOInteger b) = Right $ NGOInteger (a + b)+evalBinary BOpAdd (NGOString a) (NGOString b) = Right $ NGOString (T.concat [a, b])+evalBinary BOpAdd a b = (NGODouble .) . (+) <$> asDouble a <*> asDouble b+evalBinary BOpMul (NGOInteger a) (NGOInteger b) = Right $ NGOInteger (a * b)+evalBinary BOpMul a b = (NGODouble .) . (+) <$> asDouble a <*> asDouble b+evalBinary BOpPathAppend a b = case (a,b) of+    (NGOString pa, NGOString pb) -> return . NGOString $! T.pack (T.unpack pa </> T.unpack pb)+    _ -> throwShouldNotOccur ("Operator </>: invalid arguments" :: String)++evalBinary BOpEQ (NGOString a) (NGOString b) = return . NGOBool $! a == b+evalBinary BOpNEQ (NGOString a) (NGOString b) = return . NGOBool $! a /= b+evalBinary op a b = do+        a' <- asDouble a+        b' <- asDouble b+        return . NGOBool $ cmp op a' b'+    where+        cmp BOpLT = (<)+        cmp BOpGT = (>)+        cmp BOpLTE = (<=)+        cmp BOpGTE = (>=)+        cmp BOpEQ = (==)+        cmp BOpNEQ = (/=)+        cmp _ = error "should never occur"++++-- 'recursiveAnalyse f e' will call the function 'f' for all the subexpression inside 'e'+recursiveAnalyse :: (Monad m) => (Expression -> m ()) -> Expression -> m ()+recursiveAnalyse f e = f e >> recursiveAnalyse' e+    where+        rf = recursiveAnalyse f+        recursiveAnalyse' (ListExpression es) = mapM_ rf es+        recursiveAnalyse' (UnaryOp _ eu) = rf eu+        recursiveAnalyse' (BinaryOp _ e1 e2) = rf e1 >> rf e2+        recursiveAnalyse' (Condition cE tE fE) = rf cE >> rf tE >> rf fE+        recursiveAnalyse' (IndexExpression ei ix) = rf ei >> recurseIndex ix+        recursiveAnalyse' (Assignment _ ea) =  rf ea+        recursiveAnalyse' (FunctionCall _ ef args block) = rf ef >> mapM_ rf (snd <$> args) >> maybe (return ()) (rf . blockBody) block+        recursiveAnalyse' (MethodCall _ em eargs args) = rf em >> maybe (return ()) rf eargs >> mapM_ rf (snd <$> args)+        recursiveAnalyse' (Sequence es) =  mapM_ rf es+        recursiveAnalyse' _ = return ()+        recurseIndex (IndexOne ix) = rf ix+        recurseIndex (IndexTwo ix1 ix2) = whenJust ix1 rf >> whenJust ix2 rf++-- 'recursiveTransform' calls 'f' for every sub-expression in its argument,+-- 'f' will get called with expression where the sub-expressions have already been replaced!+recursiveTransform :: (Monad m) => (Expression -> m Expression) -> Expression -> m Expression+recursiveTransform f e = f =<< recursiveTransform' e+    where+        rf = recursiveTransform f+        recursiveTransform' (ListExpression es) = ListExpression <$> mapM rf es+        recursiveTransform' (UnaryOp op eu) = UnaryOp op <$> rf eu+        recursiveTransform' (BinaryOp op e1 e2) = BinaryOp op <$> rf e1 <*> rf e2+        recursiveTransform' (Condition cE tE fE) = Condition <$> rf cE <*> rf tE <*> rf fE+        recursiveTransform' (IndexExpression ei ix) = flip IndexExpression ix <$> rf ei+        recursiveTransform' (Assignment v ea) = Assignment v <$> rf ea+        recursiveTransform' (FunctionCall fname ef args block) = FunctionCall fname+                                    <$> rf ef+                                    <*> forM args (\(n,av) -> (n,) <$> rf av)+                                    <*> forM block (\(Block vars body) -> Block vars <$> rf body)+        recursiveTransform' (MethodCall mname em earg args) = MethodCall mname+                                    <$> rf em+                                    <*> forM earg rf+                                    <*> forM args (\(n, av) -> (n,) <$> rf av)+        recursiveTransform' (Sequence es) = Sequence <$> mapM rf es+        recursiveTransform' esimple = return esimple++usedVariables :: Expression -> [Variable]+usedVariables expr = execWriter . flip recursiveAnalyse expr $ \case+    (Lookup _ v) -> tell [v]+    _ -> return ()++data ModInfo = ModInfo+    { modName :: !T.Text+    , modVersion :: !T.Text+    } | LocalModInfo+    { modName :: !T.Text+    , modVersion :: !T.Text+    } deriving (Eq, Show)++data Header = Header+    { nglVersion :: T.Text+    , nglModules :: [ModInfo]+    } deriving (Eq, Show)++-- | Script is a version declaration followed by a series of expressions+data Script = Script+    { nglHeader :: Maybe Header -- ^ optional if -e option is used+    , nglBody :: [(Int,Expression)] -- ^ (line number, expression)+    } deriving (Eq,Show)+
+ NGLess/Modules.hs view
@@ -0,0 +1,154 @@+{- Copyright 2015-2022 NGLess Authors+ - License: MIT+ -}++{-|+ - # Modules+ -+ - Modules add additional functions, constants, or references to ngless+ -+ - See https://ngless.embl.de/modules.html for user information.+ -+ - The data type 'Module' encapsulates all information about a module.+ -}++module Modules+    ( ArgInformation(..)+    , ArgCheck(..)+    , Function(..)+    , FunctionCheck(..)+    , Reference(..)+    , ExternalReference(..)+    , Module(..)+    , ModInfo(..) -- re-export+    , knownModules+    ) where++import qualified Data.Text as T+import Data.Aeson+import Data.Default (Default, def)++import Language+import NGLess++data Reference = Reference+    { refName :: T.Text+    , refAlias :: Maybe T.Text+    , refVersionedName :: T.Text+    , refUrl :: Maybe FilePath+    , refHasGff :: Bool+    , refHasFunctionalMap :: Bool+    } deriving (Eq, Show)+++-- | Checks for an argument.+data ArgCheck =+            ArgCheckSymbol [T.Text] -- ^ for symbols, list allowed values+            | ArgCheckFileReadable -- ^ file should be readable+            | ArgCheckFileWritable -- ^ file should be writeable (i.e., this is an output file)+            | ArgCheckMinVersion (Int, Int) -- ^ first version where this argument can be used+            | ArgDeprecated (Int, Int) T.Text -- ^ deprecated since given version+            deriving (Eq,Show)++-- | Checks for a function+data FunctionCheck =+            FunctionCheckMinNGLessVersion (Int, Int) -- ^ first version where this function can be used+            | FunctionCheckReturnAssigned -- ^ Function is pure+            | FunctionCheckNGLVersionIncompatibleChange (Int, Int)-- ^ version when behaviour changed+                            T.Text -- ^ reason for change+            deriving (Eq, Show)++-- | Basic information about argument to a function+data ArgInformation = ArgInformation+    { argName :: !T.Text -- ^ argument name+    , argRequired :: !Bool -- ^ whether it is required+    , argType :: !NGLType -- ^  type+    , argChecks :: [ArgCheck] -- ^ what checks should be performed on the argument+    } deriving (Eq, Show)+++-- | This represents an ngless function+data Function = Function+    { funcName :: FuncName -- ^ name of function+    , funcArgType :: Maybe NGLType -- ^ if it takes an unnamed argument, what is its type+    , funcArgChecks :: [ArgCheck] -- ^ checks for first argument+    , funcRetType :: NGLType -- ^ what type it returns+    , funcKwArgs :: [ArgInformation] -- ^ what are the keyword arguments+    , funcAllowsAutoComprehension :: Bool -- ^ if true, then calling this function with [funcArgType] should return [funcRetType]+    , funcChecks :: [FunctionCheck]+    } deriving (Eq, Show)++data ExternalReference = ExternalReference+        { erefName :: T.Text+        , faFile :: FilePath+        , gtfFile :: Maybe FilePath+        , geneMapFile :: Maybe FilePath+        }+        | ExternalPackagedReference+        { refData :: Reference+        }+    deriving (Eq, Show)++instance FromJSON ExternalReference where+    parseJSON = withObject "external reference" $ \o -> do+                    rtype <- o .:? "rtype"+                    case (rtype :: Maybe String) of+                        Just "packaged" -> do+                            name <- o .: "name"+                            vname <- o .: "name-version"+                            path <- o .: "url"+                            hasGtf <- o .: "has-gtf"+                            hasMap <- o .: "has-mapfile"+                            return (ExternalPackagedReference (Reference name Nothing vname (Just path) hasGtf hasMap))+                        _ -> ExternalReference+                                <$> o .: "name"+                                <*> o .: "fasta-file"+                                <*> o .:? "gtf-file"+                                <*> o .:? "map-file"+++-- | This represents a module (i.e., something which is imported by ngless)+data Module = Module+    { modInfo :: !ModInfo -- ^ name & version+    , modPath :: FilePath+    , modCitations :: [T.Text]+    , modConstants :: [(T.Text, NGLessObject)] -- ^ constants defined in this module+    , modReferences :: [ExternalReference]+    , modFunctions :: [Function] -- ^ functions defined by this module+    , modTransform :: [(Int, Expression)] -> NGLessIO [(Int, Expression)] -- ^ this is called before any interpretation. It can also perform validation by throwing exceptions on error+    , runFunction :: T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject -- ^ run a function defined by the module. The first argument is the name of the function+    }++instance Show Module where+    show (Module info p _ cs fs _ _ _) = "Module["++show info++" ("++p++"); constants="++show cs++"; functions="++show fs++"]"++instance Default Module where+    def = Module+        { modInfo = ModInfo "builtin.default" "0.0"+        , modPath = "<internal>"+        , modCitations = []+        , modConstants = []+        , modReferences = []+        , modFunctions = []+        , modTransform = return+        , runFunction = \_ _ _ -> return NGOVoid+        }++++knownModules :: [T.Text]+knownModules =+    ["example-cmd"++    ,"gmgc"++    ,"igc"+    ,"om-rgc"+    ,"DogGutCatalog"+    ,"MouseGutCatalog"+    ,"PigGutCatalog"++    ,"specI"+    ,"motus"+    ]+
+ NGLess/NGLess.hs view
@@ -0,0 +1,140 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts #-}+module NGLess+    ( NGLessIO+    , NGLess+    , NGError(..)+    , runNGLess+    , throwShouldNotOccur+    , throwScriptError+    , throwDataError+    , throwSystemError+    , throwGenericError+    , KwArgsValues+    , boolOrTypeError+    , symbolOrTypeError+    , stringOrTypeError+    , integerOrTypeError+    , decodeSymbolOrError+    , lookupBoolOrScriptError+    , lookupBoolOrScriptErrorDef+    , lookupStringOrScriptError+    , lookupStringOrScriptErrorDef+    , lookupStringListOrScriptError+    , lookupStringListOrScriptErrorDef+    , lookupIntegerOrScriptError+    , lookupIntegerOrScriptErrorDef+    , lookupDoubleOrScriptError+    , lookupDoubleOrScriptErrorDef+    , lookupSymbolOrScriptError+    , lookupSymbolOrScriptErrorDef+    , lookupSymbolListOrScriptError+    , lookupSymbolListOrScriptErrorDef+    , testNGLessIO+    ) where++import qualified Data.Text as T+import           Control.Monad.Except++import Language+import NGLess.NGError+import Utils.Suggestion++type KwArgsValues = [(T.Text, NGLessObject)]+++boolOrTypeError :: (MonadError NGError m) => String -> NGLessObject -> m Bool+boolOrTypeError _ (NGOBool b) = return b+boolOrTypeError context val = throwScriptError ("Expected a boolean (received " ++ show val ++  ") in context '" ++ context ++ "'")++-- | If argument is a NGOBool, then unwraps it; else it raises a type error+symbolOrTypeError :: (MonadError NGError m) => String -> NGLessObject -> m T.Text+symbolOrTypeError _ (NGOSymbol s) = return s+symbolOrTypeError context val = throwScriptError ("Expected a symbol (received " ++ show val ++ ") in context '" ++ context ++ "'")++-- | If argument is a NGOString, then unwraps it; else it raises a type error+stringOrTypeError :: (MonadError NGError m) => String -> NGLessObject -> m T.Text+stringOrTypeError _ (NGOString s) = return s+stringOrTypeError _ (NGOFilename s) = return (T.pack s)+stringOrTypeError context val = throwScriptError ("Expected a string (received " ++ show val ++ ") in context '" ++ context ++ "'")++-- | If argument is an NGOInteger, then unwraps it; else it raises a type error+integerOrTypeError :: (MonadError NGError m) => String -> NGLessObject -> m Integer+integerOrTypeError _ (NGOInteger i) = return i+integerOrTypeError context val = throwScriptError ("Expected an integer (received " ++ show val ++ ") in context '" ++ context ++ "'")++lookupStringOrScriptErrorDef :: (MonadError NGError m) => m T.Text -> String -> T.Text -> KwArgsValues -> m T.Text+lookupStringOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just (NGOString s) -> return s+    Just other -> throwScriptError ("Expected a string in argument " ++ T.unpack name ++ " in context '" ++ context ++ "' instead observed: " ++ show other)++lookupStringOrScriptError :: (MonadError NGError m) => String-> T.Text -> KwArgsValues -> m T.Text+lookupStringOrScriptError = requiredLookup lookupStringOrScriptErrorDef++lookupStringListOrScriptErrorDef :: (MonadError NGError m) => m [T.Text] -> String -> T.Text -> KwArgsValues -> m [T.Text]+lookupStringListOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just (NGOList ss) -> stringOrTypeError context `mapM` ss+    Just other -> throwScriptError ("Expected a string in argument " ++ T.unpack name ++ " in context '" ++ context ++ "', instead saw " ++ show other)++lookupStringListOrScriptError :: (MonadError NGError m) => String -> T.Text -> KwArgsValues -> m [T.Text]+lookupStringListOrScriptError = requiredLookup lookupStringListOrScriptErrorDef+++lookupBoolOrScriptError :: (MonadError NGError m) => String-> T.Text -> KwArgsValues -> m Bool+lookupBoolOrScriptError = requiredLookup lookupBoolOrScriptErrorDef++lookupBoolOrScriptErrorDef :: (MonadError NGError m) => m Bool -> String -> T.Text -> KwArgsValues -> m Bool+lookupBoolOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just v -> boolOrTypeError context v++lookupIntegerOrScriptError :: (MonadError NGError m) => String-> T.Text -> KwArgsValues -> m Integer+lookupIntegerOrScriptError = requiredLookup lookupIntegerOrScriptErrorDef+lookupIntegerOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just (NGOInteger v) -> return v+    Just other -> throwScriptError ("Expected an integer in argument " ++ T.unpack name ++ " in context '" ++ context ++ "' instead observed: " ++ show other)++lookupDoubleOrScriptError :: (MonadError NGError m) => String-> T.Text -> KwArgsValues -> m Double+lookupDoubleOrScriptError = requiredLookup lookupDoubleOrScriptErrorDef+lookupDoubleOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just (NGODouble v) -> return v+    Just other -> throwScriptError ("Expected a double in argument " ++ T.unpack name ++ " in context '" ++ context ++ "' instead observed: " ++ show other)++lookupSymbolOrScriptError :: (MonadError NGError m) => String-> T.Text -> KwArgsValues -> m T.Text+lookupSymbolOrScriptError = requiredLookup lookupSymbolOrScriptErrorDef+lookupSymbolOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just (NGOSymbol s) -> return s+    Just other -> throwScriptError ("Expected a symbol in argument " ++ T.unpack name ++ " in context '" ++ context ++ "' instead observed: " ++ show other)+++lookupSymbolListOrScriptErrorDef :: (MonadError NGError m) => m [T.Text] -> String -> T.Text -> KwArgsValues -> m [T.Text]+lookupSymbolListOrScriptErrorDef defval context name args = case lookup name args of+    Nothing -> defval+    Just (NGOList ss) -> symbolOrTypeError context `mapM` ss+    Just other -> throwScriptError ("Expected a symbol in argument " ++ T.unpack name ++ " in context '" ++ context ++ "', instead saw " ++ show other)++lookupSymbolListOrScriptError :: (MonadError NGError m) => String -> T.Text -> KwArgsValues -> m [T.Text]+lookupSymbolListOrScriptError = requiredLookup lookupSymbolListOrScriptErrorDef++decodeSymbolOrError :: (MonadError NGError m) => String-> [(T.Text, a)] -> T.Text -> m a+decodeSymbolOrError context allowed used = case lookup used allowed of+    Just v -> return v+    Nothing -> throwScriptError ("Invalid symbol value in context "+                                            ++context++".\n"+                                            ++T.unpack (suggestionMessage used (fst <$> allowed))+                                            ++"\nValid values are:"+                                            ++concat ["\n\t - "++T.unpack val | (val,_) <- allowed])+++requiredLookup :: (MonadError NGError m) => (m a -> String-> T.Text -> KwArgsValues -> m a) -> String-> T.Text -> KwArgsValues -> m a+requiredLookup withDefaultLookup context name = withDefaultLookup errorAct context name+    where+        errorAct = throwScriptError ("Could not find '" ++ T.unpack name ++ " arguments (in context '" ++ context ++ "')")+
+ NGLess/NGLess/NGError.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, UndecidableInstances #-}+module NGLess.NGError+    ( NGError(..)+    , NGErrorType(..)+    , NGLessIO(..)+    , NGLess+    , runNGLess+    , testNGLessIO+    , throwShouldNotOccur+    , throwScriptError+    , throwDataError+    , throwSystemError+    , throwGenericError+    ) where++import           Control.DeepSeq+import           Control.Monad.Except+import           Control.Monad.Trans.Resource+import           Control.Monad.Primitive+import           Control.Monad.Catch+import           Control.Exception++-- This file should be a leaf in the import graph (i.e., not import any other NGLess modules)++-- | An error in evaluating an ngless script+-- Normally, it's easier to use the function interface of 'throwShouldNotOccur' and friends+data NGErrorType =+    ShouldNotOccur -- ^ bug in ngless+    | ScriptError -- ^ bug in user script+    | DataError -- ^ bad input+    | SystemError -- ^ system/IO issue+    | GenericError -- ^ arbitrary error message+    | NoErrorExit -- ^ escape valve: ngless should immediately exit without error (arguably should not be overloading the error code)+    deriving (Show, Eq)++instance NFData NGErrorType where+    rnf !_ = ()++data NGError = NGError !NGErrorType !String+    deriving (Show, Eq)++instance NFData NGError where+    rnf !_ = ()++instance Exception NGError++type NGLess = Either NGError++newtype NGLessIO a = NGLessIO { unwrapNGLessIO :: ResourceT IO a }+                        deriving (Functor, Applicative, Monad, MonadIO,+                        MonadResource, MonadThrow, MonadCatch, MonadMask,+                        MonadUnliftIO)+++instance MonadError NGError NGLessIO where+    throwError = liftIO . throwIO+    catchError = error "CATCH"++instance PrimMonad NGLessIO where+    type PrimState NGLessIO = PrimState IO+    primitive act = NGLessIO (primitive act)+    {-# INLINE primitive #-}++instance MonadFail NGLessIO where+    fail err = throwShouldNotOccur err++runNGLess :: (MonadError NGError m) => Either NGError a -> m a+runNGLess (Left err) = throwError err+runNGLess (Right v) = return v++testNGLessIO :: NGLessIO a -> IO a+testNGLessIO (NGLessIO act) = runResourceT act++-- | Internal bug: user is requested to submit a bug report+throwShouldNotOccur :: (MonadError NGError m) => String -> m a+throwShouldNotOccur = throwError . NGError ShouldNotOccur++-- | Script error: user can fix error by re-writing the script+throwScriptError :: (MonadError NGError m) => String -> m a+throwScriptError = throwError . NGError ScriptError++-- | Data error: problem with input data+throwDataError :: (MonadError NGError m) => String -> m a+throwDataError = throwError . NGError DataError++-- | System error: issues such as *subcommand failed* or *out of disk*+throwSystemError :: (MonadError NGError m) => String -> m a+throwSystemError = throwError . NGError SystemError++-- | Generic error: any error message+throwGenericError :: (MonadError NGError m) => String -> m a+throwGenericError = throwError . NGError GenericError+
+ NGLess/NGLess/NGLEnvironment.hs view
@@ -0,0 +1,142 @@+{- Copyright 2016-2022 NGLess Authors+ - License: MIT+ -}+module NGLess.NGLEnvironment+    ( NGLVersion(..)+    , parseVersion+    , NGLEnvironment(..)+    , nglEnvironment+    , nglConfiguration+    , updateNglEnvironment+    , updateNglEnvironment'+    , setQuiet+    , registerModule++    , Hook(..)+    , registerHook+    , registerFailHook+    , triggerFailHook+    , triggerHook++    , setModulesForTestingPurposesOnlyDoNotUseOtherwise+    , setupTestEnvironment+    ) where++import qualified Data.Text as T++import Control.Monad (forM_, when)+import Control.Monad.IO.Class (liftIO)+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef++import Modules (Module(..))+import NGLess.NGError+import Configuration+import CmdArgs (Verbosity(..))++data NGLVersion = NGLVersion !Int !Int+                        deriving (Eq, Show)++instance Ord NGLVersion where+    compare (NGLVersion majV0 minV0) (NGLVersion majV1 minV1)+        | majV0 == majV1 = compare minV0 minV1+        | otherwise = compare majV0 majV1++data Hook = FinishOkHook+    deriving (Eq, Show, Ord, Bounded, Enum)++data NGLEnvironment = NGLEnvironment+                    { ngleVersion :: !NGLVersion+                    , ngleLno :: !(Maybe Int)+                    , ngleScriptText :: !T.Text -- ^ The original text of the script+                    , ngleMappersActive :: [T.Text] -- ^ which mappers can be used+                    , ngleTemporaryFilesCreated :: [FilePath] -- ^ list of temporary files created+                    , ngleConfiguration :: NGLessConfiguration+                    , ngleLoadedModules :: [Module]+                    , ngleActiveHooks :: [(Hook, NGLessIO ())]+                    }++parseVersion :: Maybe T.Text -> NGLess NGLVersion+parseVersion Nothing = return $ NGLVersion 1 4+parseVersion (Just "1.4") = return $ NGLVersion 1 4+parseVersion (Just "1.3") = return $ NGLVersion 1 3+parseVersion (Just "1.2") = return $ NGLVersion 1 2+parseVersion (Just "1.1") = return $ NGLVersion 1 1+parseVersion (Just "1.0") = return $ NGLVersion 1 0+parseVersion (Just "0.0") = return $ NGLVersion 0 0+parseVersion (Just "0.5") = return $ NGLVersion 0 5+parseVersion (Just "0.6") = return $ NGLVersion 0 6+parseVersion (Just "0.7") = return $ NGLVersion 0 7+parseVersion (Just "0.8") = return $ NGLVersion 0 8+parseVersion (Just "0.9") = return $ NGLVersion 0 9+parseVersion (Just "0.10") = return $ NGLVersion 0 10+parseVersion (Just "0.11") = return $ NGLVersion 0 11+parseVersion (Just v) = case T.splitOn "." v of+                            [majV,minV,_] ->+                                throwScriptError $ concat ["The NGLess version string at the top of the file should only\ncontain a major and a minor version, separated by a dot.\n\n"+                                                        ,"You probably meant to write:\n\n"+                                                        ,"ngless \"" , T.unpack majV, ".", T.unpack minV, "\"\n"]+                            [_, _] -> throwScriptError $ concat ["Version ", T.unpack v, " is not supported (only versions 1.[0-2] and 0.0/0.5-12 are available in this release)."]+                            _ -> throwScriptError $ concat ["Version ", T.unpack v, " could not be understood. The version string should look like \"1.0\" or similar"]+ngle :: IORef NGLEnvironment+{-# NOINLINE ngle #-}+ngle = unsafePerformIO (newIORef $ NGLEnvironment (NGLVersion 0 0) Nothing "" ["bwa"] [] (error "Configuration not set") [] [])+++failHooks :: IORef [IO ()]+{-# NOINLINE failHooks #-}+failHooks = unsafePerformIO (newIORef [])+++nglEnvironment :: NGLessIO NGLEnvironment+nglEnvironment = liftIO $ readIORef ngle++updateNglEnvironment' :: (NGLEnvironment -> NGLEnvironment) -> IO ()+updateNglEnvironment' = modifyIORef' ngle++updateNglEnvironment :: (NGLEnvironment -> NGLEnvironment) -> NGLessIO ()+updateNglEnvironment = liftIO . updateNglEnvironment'++nglConfiguration :: NGLessIO NGLessConfiguration+nglConfiguration = ngleConfiguration <$> nglEnvironment++registerModule :: Module -> NGLessIO ()+registerModule m = updateNglEnvironment $ \env ->+    env { ngleLoadedModules = m:ngleLoadedModules env }++setModulesForTestingPurposesOnlyDoNotUseOtherwise :: [Module] -> NGLessIO ()+setModulesForTestingPurposesOnlyDoNotUseOtherwise mods = updateNglEnvironment $ \env -> env { ngleLoadedModules = mods }++registerHook :: Hook -> NGLessIO () -> NGLessIO ()+registerHook hook act = updateNglEnvironment $ \env ->+    env { ngleActiveHooks = (hook, act):ngleActiveHooks env }++{- Run if the script fails. Note that these hooks are in the IO Monad, not+ - NGLessIO! -}+registerFailHook :: IO () -> NGLessIO ()+registerFailHook act = liftIO $ modifyIORef failHooks (act:)++-- Run all fail hooks+triggerFailHook :: IO ()+triggerFailHook = readIORef failHooks >>= sequence_++-- Trigger the actions registered with the given hook+triggerHook :: Hook -> NGLessIO ()+triggerHook hook = do+    registered <- ngleActiveHooks <$> nglEnvironment+    forM_ registered $ \(h,act) ->+        when (h == hook) act+++-- | sets verbosity to Quiet+setQuiet :: NGLessIO ()+setQuiet = updateNglEnvironment (\e -> e { ngleConfiguration = setQuiet' (ngleConfiguration e) })+    where+        setQuiet' c = c { nConfVerbosity = Quiet, nConfPrintHeader = False }++-- | setup an environment that can be used for testing+setupTestEnvironment :: IO ()+setupTestEnvironment = do+    config <- guessConfiguration+    let config' = config { nConfTemporaryDirectory = "testing_tmp_dir", nConfKeepTemporaryFiles = True, nConfVerbosity = Quiet }+    updateNglEnvironment' (\env -> env { ngleConfiguration = config' })
+ NGLess/Output.hs view
@@ -0,0 +1,479 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE TemplateHaskell, RecordWildCards, CPP, FlexibleContexts #-}++module Output+    ( OutputType(..)+    , MappingInfo(..)+    , AutoComment(..)+    , buildComment+    , commentC+    , outputListLno+    , outputListLno'+    , outputFQStatistics+    , outputMappedSetStatistics+    , writeOutputJSImages+    , writeOutputTSV+    , outputConfiguration+    ) where++import           Text.Printf (printf)+import           System.IO (hPutStrLn, hIsTerminalDevice, stdout, stderr)+import           System.IO.Unsafe (unsafePerformIO)+import           System.IO.SafeWrite (withOutputFile)+import           Data.Maybe (maybeToList, fromMaybe, isJust)+import           Data.IORef (IORef, newIORef, modifyIORef, readIORef)+import           Data.List (sort)+import           Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import           System.FilePath ((</>))+import           Data.Aeson.TH (deriveToJSON, defaultOptions, Options(..))+import           Data.Time (getZonedTime, ZonedTime(..))+import           Data.Time.Format (formatTime, defaultTimeLocale)+import qualified System.Console.ANSI as ANSI+import           Control.Monad+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Extra (whenJust)+import           Numeric (showFFloat)+import           Control.Arrow (first)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Conduit as C+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Lazy as BL++import qualified Diagrams.Backend.SVG as D+import qualified Diagrams.TwoD.Size as D+import qualified Diagrams.Prelude as D+import           Diagrams.Prelude ((#), (^&), (|||))++import           System.Environment (lookupEnv)+++import           Data.FastQ (FastQEncoding(..), encodingName)+import qualified Data.FastQ as FQ+import Configuration+import CmdArgs (Verbosity(..))+import NGLess.NGLEnvironment+import NGLess.NGError++data AutoComment = AutoScript | AutoDate | AutoResultHash+                        deriving (Eq, Show)+++buildComment :: Maybe T.Text -> [AutoComment] -> T.Text -> NGLessIO [T.Text]+buildComment c ac rh = do+        ac' <- mapM buildAutoComment ac+        return $ maybeToList c ++ concat ac'+    where+        buildAutoComment :: AutoComment -> NGLessIO [T.Text]+        buildAutoComment AutoDate = liftIO $ do+            t <- formatTime defaultTimeLocale "%a %d-%m-%Y %R" <$> getZonedTime+            return . (:[]) $ T.concat ["Script run on ", T.pack t]+        buildAutoComment AutoScript = (("Output generated by:":) . map addInitialIndent . T.lines . ngleScriptText) <$> nglEnvironment+        buildAutoComment AutoResultHash = return [T.concat ["Output hash: ", rh]]+        addInitialIndent t = T.concat ["    ", t]++-- Output a comment as a conduit+commentC :: Monad m => B.ByteString -> [T.Text] -> C.ConduitT () B.ByteString m ()+commentC cmarker cs = forM_ cs $ \c -> do+                                C.yield cmarker+                                C.yield (TE.encodeUtf8 c)+                                C.yield "\n"+++data OutputType = TraceOutput | DebugOutput | InfoOutput | ResultOutput | WarningOutput | ErrorOutput+    deriving (Eq, Ord)++instance Show OutputType where+    show TraceOutput = "trace"+    show DebugOutput = "debug"+    show InfoOutput = "info"+    show ResultOutput = "result"+    show WarningOutput = "warning"+    show ErrorOutput = "error"++data OutputLine = OutputLine !Int !OutputType !ZonedTime !String++instance Aeson.ToJSON OutputLine where+    toJSON (OutputLine lno ot t m) = Aeson.object+                                        ["lno" .= lno+                                        , "time" .=  formatTime defaultTimeLocale "%a %d-%m-%Y %T" t+                                        , "otype" .= show ot+                                        , "message" .= m+                                        ]+++data BPosInfo = BPosInfo+                    { _mean :: !Int+                    , _median :: !Int+                    , _lowerQuartile :: !Int+                    , _upperQuartile :: !Int+                    } deriving (Show)+$(deriveToJSON defaultOptions{fieldLabelModifier = drop 1} ''BPosInfo)++data FQInfo = FQInfo+                { fileName :: String+                , scriptLno :: !Int+                , gcContent :: !Double+                , nonATCGFrac :: !Double+                , encoding :: !String+                , numSeqs :: !Int+                , numBasepairs :: !Integer+                , seqLength :: !(Int,Int)+                , perBaseQ :: [BPosInfo]+                } deriving (Show)++$(deriveToJSON defaultOptions ''FQInfo)++data MappingInfo = MappingInfo+                { mi_lno :: Int+                , mi_inputFile :: FilePath+                , mi_reference :: String+                , mi_totalReads :: !Int+                , mi_totalAligned :: !Int+                , mi_totalUnique :: !Int+                } deriving (Show)++$(deriveToJSON defaultOptions{fieldLabelModifier = drop 3} ''MappingInfo)++data SavedOutput = SavedOutput+        { outOutput :: [OutputLine]+        , fqOutput :: [FQInfo]+        , mapOutput :: [MappingInfo]+        }++savedOutput :: IORef SavedOutput+{-# NOINLINE savedOutput #-}+savedOutput = unsafePerformIO (newIORef (SavedOutput [] [] []))++addOutputLine :: OutputLine -> SavedOutput -> SavedOutput+addOutputLine !oline so@(SavedOutput ells _ _) = so { outOutput = oline:ells }++addFQOutput !fq so@(SavedOutput _ fqs _) = so { fqOutput = fq:fqs }+addMapOutput !mp so@(SavedOutput _ _ maps) = so { mapOutput = mp:maps }++outputReverse (SavedOutput a b c) = SavedOutput (reverse a) (reverse b) (reverse c)++-- | See `outputListLno'`, which is often the right function to use+outputListLno :: OutputType      -- ^ Level at which to output+                    -> Maybe Int -- ^ Line number (in script). Use 'Nothing' for global messages+                    -> [String]+                    -> NGLessIO ()+outputListLno ot lno ms = output ot (fromMaybe 0 lno) (concat ms)++-- | Output a message using the global line number.+-- This function takes a list as it is often a more convenient interface+outputListLno' :: OutputType      -- ^ Level at which to output+                    -> [String]   -- ^ output. Will be 'concat' together (without any spaces or similar in between)+                    -> NGLessIO ()+outputListLno' !ot ms = do+    lno <- ngleLno <$> nglEnvironment+    outputListLno ot lno ms++shouldPrint :: Bool -- ^ is terminal+                -> OutputType+                -> Verbosity+                -> Bool+shouldPrint _ TraceOutput _ = False+shouldPrint _      _ Loud = True+shouldPrint False ot Quiet = ot == ErrorOutput+shouldPrint False ot Normal = ot > InfoOutput+shouldPrint True  ot Quiet = ot >= WarningOutput+shouldPrint True  ot Normal = ot >= InfoOutput++output :: OutputType -> Int -> String -> NGLessIO ()+output !ot !lno !msg = do+    outputTo <- nConfOutputTo <$> nglConfiguration+    let outputHandle = case outputTo of+            NGLOutStdout -> stdout+            NGLOutStderr -> stderr+    isTerm <- liftIO $ hIsTerminalDevice outputHandle+    hasNOCOLOR <- isJust <$> liftIO (lookupEnv "NO_COLOR")+    verb <- nConfVerbosity <$> nglConfiguration+    traceSet <- nConfTrace <$> nglConfiguration+    colorOpt <- nConfColor <$> nglConfiguration+    let sp = traceSet || shouldPrint isTerm ot verb+        doColor = case colorOpt of+            ForceColor -> True+            NoColor -> False+            AutoColor -> isTerm && not hasNOCOLOR+    c <- colorFor ot+    liftIO $ do+        t <- getZonedTime+        modifyIORef savedOutput (addOutputLine $ OutputLine lno ot t msg)+        when sp $ do+            let st = if doColor+                        then ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull c]+                        else ""+                rst = if doColor+                        then ANSI.setSGRCode [ANSI.Reset]+                        else ""+                tformat = if traceSet -- when trace is set, output seconds+                                then "%a %d-%m-%Y %T"+                                else "%a %d-%m-%Y %R"+                tstr = formatTime defaultTimeLocale tformat t+                lineStr = if lno > 0+                                then printf " Line %s" (show lno)+                                else "" :: String+            hPutStrLn outputHandle $ printf "%s[%s]%s: %s%s" st tstr lineStr msg rst++colorFor :: OutputType -> NGLessIO ANSI.Color+colorFor = return . colorFor'+    where+        colorFor' TraceOutput   = ANSI.White+        colorFor' DebugOutput   = ANSI.White+        colorFor' InfoOutput    = ANSI.Blue+        colorFor' ResultOutput  = ANSI.Black+        colorFor' WarningOutput = ANSI.Yellow+        colorFor' ErrorOutput   = ANSI.Red+++encodeBPStats :: FQ.FQStatistics -> [BPosInfo]+encodeBPStats res = map encode1 (FQ.qualityPercentiles res)+    where encode1 (mean, median, lq, uq) = BPosInfo mean median lq uq++outputFQStatistics :: FilePath -> FQ.FQStatistics -> FastQEncoding -> NGLessIO ()+outputFQStatistics fname stats enc = do+    lno' <- ngleLno <$> nglEnvironment+    let enc'    = encodingName enc+        sSize'  = FQ.seqSize stats+        nSeq'   = FQ.nSeq stats+        gc'     = FQ.gcFraction stats+        nATGC   = FQ.nonATCGFrac stats+        st      = encodeBPStats stats+        lno     = fromMaybe 0 lno'+        nbps    = FQ.nBasepairs stats+        binfo   = FQInfo fname lno gc' nATGC enc' nSeq' nbps sSize' st+    let p s0 s1  = outputListLno' DebugOutput [s0, s1]+    p "Simple Statistics completed for: " fname+    p "Number of base pairs: "      (show $ length (FQ.qualCounts stats))+    p "Encoding is: "               (show enc)+    p "Number of sequences: "   (show $ FQ.nSeq stats)+    liftIO $ modifyIORef savedOutput (addFQOutput binfo)++outputMappedSetStatistics :: MappingInfo -> NGLessIO ()+outputMappedSetStatistics mi@(MappingInfo _ _ ref total aligned unique) = do+        lno <- ngleLno <$> nglEnvironment+        let out = outputListLno' ResultOutput+        out ["Mapped readset stats (", ref, "):"]+        out ["Total reads: ", show total]+        out ["Total reads aligned: ", showNumAndPercentage aligned]+        out ["Total reads Unique map: ", showNumAndPercentage unique]+        out ["Total reads Non-Unique map: ", showNumAndPercentage (aligned - unique)]+        liftIO $ modifyIORef savedOutput (addMapOutput $ mi { mi_lno = fromMaybe 0 lno })+    where+        showNumAndPercentage :: Int -> String+        showNumAndPercentage v = concat [show v, " [", showFFloat (Just 2) ((fromIntegral (100*v) / fromIntegral total') :: Double) "", "%]"]+        total' = if total /= 0 then total else 1+++data InfoLink = HasQCInfo !Int+                | HasStatsInfo !Int+    deriving (Eq, Show)+instance Aeson.ToJSON InfoLink where+    toJSON (HasQCInfo lno) = Aeson.object+                                [ "info_type" .= ("has_QCInfo" :: String)+                                , "lno" .= show lno+                                ]+    toJSON (HasStatsInfo lno) = Aeson.object+                                [ "info_type" .= ("has_StatsInfo" :: String)+                                , "lno" .= show lno+                                ]++data ScriptInfo = ScriptInfo String String [(Maybe InfoLink,T.Text)] deriving (Show, Eq)+instance Aeson.ToJSON ScriptInfo where+   toJSON (ScriptInfo a b c) = Aeson.object [ "name" .= a,+                                            "time" .= b,+                                            "script" .= Aeson.toJSON c ]++wrapScript :: [(Int, T.Text)] -> [FQInfo] -> [Int] -> [(Maybe InfoLink, T.Text)]+wrapScript script tags stats = first annotate <$> script+    where+        annotate i+            | i `elem` (scriptLno <$> tags) = Just (HasQCInfo i)+            | i `elem` stats = Just (HasStatsInfo i)+            | otherwise =  Nothing++writeOutputJSImages :: FilePath -> FilePath -> T.Text -> NGLessIO ()+writeOutputJSImages odir scriptName script = liftIO $ do+    SavedOutput fullOutput fqStats mapStats <- outputReverse <$> readIORef savedOutput+    fqfiles <- forM (zip [(0::Int)..] fqStats) $ \(ix, q) -> do+        let oname = "output"++show ix++".svg"+            bpos = perBaseQ q+        drawBaseQs (odir </> oname) bpos+        return oname+    t <- getZonedTime+    let script' = zip [1..] (T.lines script)+        sInfo = ScriptInfo (odir </> "output.js") (show t) (wrapScript script' fqStats (mi_lno <$> mapStats))+    withOutputFile (odir </> "output.js") $ \hout ->+        BL.hPutStr hout (BL.concat+                    ["var output = "+                    , Aeson.encode $ Aeson.object+                        [ "output" .= fullOutput+                        , "processed" .= sInfo+                        , "fqStats" .= fqStats+                        , "mapStats" .= mapStats+                        , "scriptName" .= scriptName+                        , "plots" .= fqfiles+                        ]+                    ,";\n"])+++-- | Writes QC stats to the given filepaths.+writeOutputTSV :: Bool -- ^ whether to transpose matrix+                -> Maybe FilePath -- ^ FastQ statistics+                -> Maybe FilePath -- ^ Mapping statistics+                -> NGLessIO ()+writeOutputTSV transpose fqStatsFp mapStatsFp = liftIO $ do+        SavedOutput _ fqStats mapStats <- outputReverse <$> readIORef savedOutput+        whenJust fqStatsFp $ \fp ->+            withOutputFile fp $ \hout ->+                BL.hPut hout  . formatTSV $ encodeFQStats <$> fqStats+        whenJust mapStatsFp $ \fp ->+            withOutputFile fp $ \hout ->+                BL.hPutStr hout . formatTSV $ encodeMapStats <$> mapStats+    where+        formatTSV :: [[(BL.ByteString, String)]] -> BL.ByteString+        formatTSV [] = BL.empty+        formatTSV contents@(h:_)+            | transpose = BL.concat ("\tstats\n":(formatTSV1 <$> zip [0..] contents))+            | otherwise = BL.concat [BL8.intercalate "\t" (fst <$> h), "\n",+                                    BL8.intercalate "\n" (asTSVline . fmap snd <$> contents), "\n"]+        formatTSV1 :: (Int, [(BL.ByteString, String)]) -> BL.ByteString+        formatTSV1 (i, contents) = BL.concat [BL8.concat [BL8.concat [BL8.pack . show $ i, ":", h], "\t", BL8.pack c, "\n"]+                                                                        | (h, c) <- contents]+        asTSVline = BL8.intercalate "\t" . map BL8.pack++        encodeFQStats FQInfo{..} = sort+                            [ ("file", fileName)+                            , ("encoding", encoding)+                            , ("numSeqs", show numSeqs)+                            , ("numBasepairs", show numBasepairs)+                            , ("minSeqLen", show (fst seqLength))+                            , ("maxSeqLen", show (snd seqLength))+                            , ("gcContent", show gcContent)+                            , ("nonATCGFraction", show nonATCGFrac)+                            ]+        encodeMapStats MappingInfo{..} = sort+                [ ("inputFile", mi_inputFile)+                , ("lineNumber", show mi_lno)+                , ("reference", mi_reference)+                , ("total", show mi_totalReads)+                , ("aligned", show mi_totalAligned)+                , ("unique", show mi_totalUnique)+                ]++outputConfiguration :: NGLessIO ()+outputConfiguration = do+    cfg <- ngleConfiguration <$> nglEnvironment+    outputListLno' DebugOutput ["# Configuration"]+    outputListLno' DebugOutput ["\tdownload base URL: ", nConfDownloadBaseURL cfg]+    outputListLno' DebugOutput ["\tglobal data directory: ", nConfGlobalDataDirectory cfg]+    outputListLno' DebugOutput ["\tuser directory: ", nConfUserDirectory cfg]+    outputListLno' DebugOutput ["\tuser data directory: ", nConfUserDataDirectory cfg]+    outputListLno' DebugOutput ["\ttemporary directory: ", nConfTemporaryDirectory cfg]+    outputListLno' DebugOutput ["\tkeep temporary files: ", show $ nConfKeepTemporaryFiles cfg]+    outputListLno' DebugOutput ["\tcreate report: ", show $ nConfCreateReportDirectory cfg]+    outputListLno' DebugOutput ["\treport directory: ", nConfReportDirectory cfg]+    outputListLno' DebugOutput ["\tcolor setting: ", show $ nConfColor cfg]+    outputListLno' DebugOutput ["\tprint header: ",  show $ nConfPrintHeader cfg]+    outputListLno' DebugOutput ["\tsubsample: ", show $ nConfSubsample cfg]+    outputListLno' DebugOutput ["\tverbosity: ", show $ nConfVerbosity cfg]+    forM_ (nConfIndexStorePath cfg) $ \p ->+        outputListLno' DebugOutput ["\tindex storage path: ", p]+    outputListLno' DebugOutput ["\tsearch path:"]+    forM_ (nConfSearchPath cfg) $ \p ->+        outputListLno' DebugOutput ["\t\t", p]+++type Diagram = D.QDiagram D.SVG D.V2 Double D.Any+-- Draw a chart of the base qualities+--+-- The code is very empirical in magic numbers+drawBaseQs :: FilePath -> [BPosInfo] -> IO ()+drawBaseQs oname bpos = D.renderSVG oname (D.mkSizeSpec2D (Just (1200.0 :: Double)) (Just 800.0)) $+        D.padX 1.2 $ D.padY 1.1 $ D.centerXY $+        chart ||| D.strutX 0.04 ||| legend+    where+        datalines = [+            ("Mean" ,  style1, meanValues),+            ("Median", style2, medianValues),+            ("Upper Quartile", style3, uqValues),+            ("Lower Quartile", style4, lqValues)+            ]++        lenBP = length bpos+        chart = mconcat [plot st d | (_, st, d) <- datalines]+                    <> horizticks <> vertticks+                    <> text' "Basepair position" # D.moveTo (0.5 ^& (-0.07))+                    <> text' "Quality score" # D.rotate (90 D.@@ D.deg) # D.moveTo ((-0.1) ^& (0.5))++        plot :: (D.Path D.V2 Double, Diagram -> Diagram) -> [(Double, Double)] -> Diagram+        plot (shape, style) ps = let+                        ps' = D.p2 <$> ps+                     in style (D.strokeP $ D.fromVertices ps') `D.atop` D.strokeP (mconcat [ shape D.# D.moveTo p | p <- ps' ])+        horizticks :: Diagram+        horizticks =+            let+                ticks = (takeWhile (< lenBP) [0, 25..]) ++ [lenBP]+                pairs = [(fromIntegral tk * tickspace, show tk) | tk <- ticks]+                tickspace :: Double+                tickspace = 1.0 / fromIntegral lenBP++                textBits = mconcat     [ text' t # D.moveTo ((x)^&(-0.04)) | (x,t) <- pairs ]+                tickBits =    mconcat  [ D.fromVertices [ (x) ^& 0, (x) ^& 0.1     ] | (x,_) <- pairs ]+                            <> mconcat [ D.fromVertices [ (x) ^& h, (x) ^& (h-0.1) ] | (x,_) <- pairs ]+                            <> mconcat [ D.fromVertices [ (x) ^& 0, (x) ^& h       ] # dashedLine | (x,_) <- pairs ]+            in textBits <> tickBits++        h = 1.0+        w = 1.0++        dashedLine = D.lc D.gray . D.dashing [ 0.3, 0.3] 0+        vertticks :: Diagram+        vertticks =+            let+                pairs = [(0.0,  "0"),+                         (0.25, "10"),+                         (0.50, "20"),+                         (0.75, "30"),+                         (1.00, "40")]+                textBits = mconcat [ text' t # D.alignR # D.moveTo   ((-0.04) ^&  y) | (y,t) <- pairs ]+                tickBits = mconcat     [ D.fromVertices [ 0 ^& y,     0.1 ^& y ] | (y,_) <- pairs ]+                            <> mconcat [ D.fromVertices [ w ^& y, (w-0.1) ^& y ] | (y,_) <- pairs ]+                            <> mconcat [ D.fromVertices [ 0 ^& y,       w ^& y ] # dashedLine | (y,_) <- pairs ]+            in textBits <> tickBits+++        legend = D.translateY 0.8 $+                    D.vcat' D.with {D._sep=0.1} $+                        [littleLine s ||| D.strutX 0.2 ||| text' label # D.alignL+                            | (label, s, _) <- datalines]+            where+                littleLine :: (D.Path D.V2 Double, Diagram -> Diagram) -> Diagram+                littleLine (shape, st) = st (D.strokeP $ D.fromVertices [ D.p2 (0, 0), D.p2 (0.2, 0) ]) <> (D.strokeP shape # D.moveTo (D.p2 (0.1, 0)))+        text' :: String -> Diagram+        text' s = D.text s # D.fc D.black # D.lw D.none # D.fontSizeL 0.03+++        [meanValues, medianValues, uqValues, lqValues] = map rescale [_mean, _median, _upperQuartile, _lowerQuartile]++        rescale :: (BPosInfo -> Int) -> [(Double, Double)]+        rescale sel = [(rescale1 1 (toInteger lenBP) x, rescale1 0 40 y) | (x,y) <- zip [1..] values]+            where+                values = map (toInteger . sel) bpos+                rescale1 :: Integer -> Integer -> Integer -> Double+                rescale1 m0 m1 x = let+                                   m0' = fromInteger m0+                                   s = fromInteger (m1 - m0)+                                   x' = fromInteger x+                               in (x'-m0')/s++        style1 = (D.circle   0.01, D.lc D.red)+        style2 = (D.square   0.01, D.lc D.green)+        style3 = (D.pentagon 0.01, D.lc D.blue)+        style4 = (D.star (D.StarSkip 2) (D.pentagon 0.01), D.lc D.brown)+
+ NGLess/Parse.hs view
@@ -0,0 +1,231 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE CPP #-}++module Parse+    ( parsengless+#ifdef IS_BUILDING_TEST+    , _nglbody+    , _cleanupindents+    , _indexexpr+    , _listexpr+#endif+    ) where++import Control.Monad+import Control.Monad.Identity ()+import qualified Data.Text as T+import Text.ParserCombinators.Parsec.Prim hiding (Parser)+import Text.Parsec.Combinator+import Text.Parsec.Pos+import Text.Parsec.Error+import Data.Functor (($>))++import NGLess.NGError+import Language+import Tokens (tokenize, Token(..))+++sliceList :: Int -> Int -> [a] -> [a]+sliceList st e = take (e - st) . drop st++-- | main function of this module+--+-- Because the scripts are expected to be small, we load them whole into memory+-- (with a strict 'Text') before parsing+parsengless :: String -- ^ input filename (for error messages)+            -> Bool -- ^ whether the version statement is mandatory+            -> T.Text -- ^ input data+            -> NGLess Script -- ^ either error message or parsed 'Script'+parsengless inputname reqversion input = tokenize inputname input >>= parsetoks input inputname reqversion++parsetoks :: T.Text -> String -> Bool -> [(SourcePos,Token)] -> NGLess Script+parsetoks input inputname reqversion toks = case parse (nglparser reqversion) inputname (_cleanupindents toks) of+            Right val -> return val+            Left err -> throwScriptError $ buildErrorMessage input err+++buildErrorMessage :: T.Text -> ParseError -> String+buildErrorMessage input err = concat $ ["Parsing error on file '", fname, "' on line ", show line, " (column ", show col, ")\n\n"]+                    ++ preLines 3+                    ++ ["\n\t", indicatorLine]+                    ++ postLines 2+                    ++ ["\n\n", show err, "\n"]+    where+        pos = errorPos err+        fname = sourceName pos+        line = sourceLine pos+        col = sourceColumn pos+        sourceLines = T.unpack <$> T.lines input+        preLines :: Int -> [String]+        preLines n = withNLTAB $ sliceList (max 0 (line - n)) line sourceLines+        postLines n = withNLTAB $ sliceList line (line +  n) sourceLines+        withNLTAB [] = []+        withNLTAB (ell:ls) = "\n\t":ell:withNLTAB ls+        indicatorLine = ['-' | _ <- [1..col+8]] ++ "^"+++-- | '_cleanupindents' removes spaces that do not follow new lines as well as+-- any spaces that are between brackets (round or square).+_cleanupindents ::[(SourcePos,Token)] -> [(SourcePos, Token)]+_cleanupindents = _cleanupindents' []+    where+        _cleanupindents' _ [] = []+        _cleanupindents' cs (t@(_,TOperator o):ts)+                | isOpen o = t : _cleanupindents' (closeOf o:cs) ts+        _cleanupindents' (c:cs) (t@(_,TOperator c'):ts)+                | c' == c = t : _cleanupindents' cs ts+        _cleanupindents' cs@(_:_) ((_,TNewLine):ts) = _cleanupindents' cs ts+        _cleanupindents' cs@(_:_) ((_,TIndent _):ts) = _cleanupindents' cs ts+        _cleanupindents' [] ((_,TNewLine):(_,TIndent _):t0@(_,TNewLine):ts) = _cleanupindents' [] (t0:ts)+        _cleanupindents' [] (t0@(_,TNewLine):t1@(_,TIndent _):ts) = t0 : t1 : _cleanupindents' [] ts+        _cleanupindents' [] ((_,TIndent _):ts) = _cleanupindents' [] ts+        _cleanupindents' cs (t:ts) = t : _cleanupindents' cs ts++        isOpen '(' = True+        isOpen '[' = True+        isOpen _ = False+        closeOf '[' = ']'+        closeOf '(' = ')'+        closeOf _ = error "we should not close anything but [ & ("++type Parser = GenParser (SourcePos,Token) ()++nglparser False = Script <$> optionMaybe ngless_header <*> (many eol *> _nglbody)+nglparser True = Script <$> (Just <$> ngless_header) <*> (many eol *> _nglbody)+_nglbody = (eof *> pure []) <|> (many1 lno_expression <* eof)+lno_expression = (,) <$> linenr <*> expression+    where linenr = sourceLine `fmap` getPosition++expression :: Parser Expression+expression = expression' <* many eol+    where+        expression' =+                    conditional+                    <|> (reserved "discard" $> Discard)+                    <|> (reserved "continue" $> Continue)+                    <|> assignment+                    <|> innerexpression++innerexpression = try $ do+    left <- left_expression+    (try $ do {+        bop <- binop;+        right <- innerexpression;+        return $ BinaryOp bop left right}) <|> return left++left_expression =  uoperator+                    <|> method_call+                    <|> _indexexpr+                    <|> base_expression++base_expression = pexpression+                    <|> (funccall <?> "function call")+                    <|> _listexpr+                    <|> rawexpr+                    <|> (Lookup Nothing <$> variable)++pexpression = operator '(' *> innerexpression <* operator ')'++tokf ::  (Token -> Maybe a) -> Parser a+tokf f = token (show .snd) fst (f . snd)++rawexpr = tokf $ \case+    TExpr e -> Just e+    _ -> Nothing+string = (tokf $ \case { TExpr (ConstStr n) -> Just n; _ -> Nothing }) <?> "String"++operator op = (tokf $ \t -> case t of { TOperator op' | op == op' -> Just t; _ -> Nothing }) <?> (concat ["operator ", [op]])++word = tokf $ \case+    TWord w -> Just w+    _ -> Nothing++match_word w = (tokf $ \case+    TWord w' | w == w' -> Just w+    _ -> Nothing) <?> ("word "++T.unpack w)+reserved r = (tokf $ \case { TReserved r' | r == r' -> Just r; _ -> Nothing }) <?> (concat [T.unpack r, " (reserved word)"])++indentation = (tokf $ \case { TIndent i -> Just i; _ -> Nothing }) <?> "indentation"+eol = (tokf $ \case { TNewLine -> Just (); _ -> Nothing }) <?> "end of line"+binop = (tokf $ \case { TBop b -> Just b; _ -> Nothing }) <?> "binary operator"++uoperator = lenop <|> unary_minus <|> not_expr+    where+        lenop = UnaryOp UOpLen <$> (reserved "len" *> operator '(' *> expression <* operator ')')+        unary_minus = UnaryOp UOpMinus <$> (operator '-' *> base_expression)+        not_expr = UnaryOp UOpNot <$> (reserved "not" *> innerexpression)+funccall = try paired <|> FunctionCall <$>+                try (funcname <* operator '(')+                <*> innerexpression+                <*> (kwargs <* operator ')')+                <*> funcblock++funcblock = optionMaybe (Block <$> (reserved "using" *> operator '|' *> variable <* operator '|' <* operator ':') <*> block)++paired = FunctionCall+            <$> (match_word "paired" $> (FuncName "paired"))+            <*> (operator '(' *> innerexpression <* operator ',')+            <*> pairedKwArgs+            <*> pure Nothing++funcname = FuncName   <$> word <?> "function name"+method   = MethodName <$> word <?> "method name"++pairedKwArgs = (++) <$> (wrap <$> expression) <*> (kwargs <* operator ')')+    where wrap e = [(Variable "second", e)]++kwargs = many (operator ',' *> kwarg) <?> "keyword argument list"+kwarg = kwarg' <?> "keyword argument"+    where kwarg' = (,) <$> (variable <* operator '=') <*> innerexpression++assignment = try assignment'+    where assignment' =+            Assignment <$> variable <*> (operator '=' *> expression)++method_call = try $ do+    self <- base_expression <* operator '.'+    met <- method <* operator '('+    a <- optionMaybe $ try (innerexpression <* notFollowedBy (operator '='))+    optional (operator ',')+    kws <- kwarg `sepBy` (operator ',')+    void $ operator ')'+    return (MethodCall met self a kws)++_indexexpr = try (IndexExpression <$> base_expression <*> indexing)+    where+        indexing = try (IndexTwo <$> (operator '[' *> may_int <* operator ':') <*> (may_int <* operator ']'))+                    <|> (IndexOne <$> (operator '[' *> innerexpression <* operator ']'))+        may_int = optionMaybe innerexpression++_listexpr = try listexpr+    where+        listexpr = (operator '[') *> (ListExpression <$> (innerexpression `sepEndBy` (operator ','))) <* (operator ']')++conditional = Condition <$> (reserved "if" *> innerexpression <* operator ':') <*> block <*> mayelse+mayelse = elseblock <|> pure (Sequence [])+elseblock = reserved "else" *> operator ':' *> block+block = do+        eol+        level <- indentation+        first <- expression <* many eol+        rest <- block' level+        return $ Sequence (first:rest)+    where+        block' level = many (try $ do+                            level' <- indentation+                            if level /= level'+                                then fail "indentation changed"+                                else expression <* many eol)+variable = Variable <$> word <?> "variable"++ngless_header = Header <$> (many eol *> ngless_version <* many eol) <*> many (import_mod <* many eol)+ngless_version = ngless_version' <?> "ngless version declararion"+    where ngless_version' = reserved "ngless" *> (string <?> "ngless version string") <* eol++import_mod =+        LocalModInfo <$> (reserved "local" *> reserved "import" *> (string <?> "module name")) <*> (match_word "version" *> (string <?> "module version")) <* eol+        <|>+        ModInfo <$> (reserved "import" *> (string <?> "module name")) <*> (match_word "version" *> (string <?> "module version")) <* eol+
+ NGLess/ReferenceDatabases.hs view
@@ -0,0 +1,240 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+-}+module ReferenceDatabases+    ( Reference(..)+    , ReferenceFilePaths(..)+    , builtinReferences+    , isBuiltinReference+    , createReferencePack+    , ensureDataPresent+    , installData+    ) where++import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Compression.GZip as GZip+import           Control.Monad.Extra (whenJust, unlessM)++import System.FilePath ((</>), (<.>), dropExtension)+import System.Directory+import System.IO.Error+import Data.Foldable+import Data.Maybe++import Control.Monad (liftM2)+import Control.Applicative ((<|>))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource(release)++import qualified StandardModules.Mappers.Bwa as Bwa+import FileManagement (createTempDir, InstallMode(..))+import NGLess.NGLEnvironment (NGLVersion(..), NGLEnvironment(..), nglConfiguration, nglEnvironment)+import Configuration+import Modules+import Version (versionStr)+import Output (outputListLno', OutputType(..))+import NGLess+import Dependencies.Versions (bwaVersion)+import Utils.Network (downloadExpandTar, downloadOrCopyFile, downloadFile, isUrl)+import Utils.LockFile (withLockFile, LockParameters(..), WhenExistsStrategy(..))+import Utils.Utils (findM, withOutputFile)++data ReferenceFilePaths = ReferenceFilePaths+    { rfpFaFile :: Maybe FilePath+    , rfpGffFile :: Maybe FilePath+    , rfpFunctionalMap :: Maybe FilePath+    } deriving (Eq, Show)+++dataDirectory :: InstallMode -> NGLessIO FilePath+dataDirectory Root = nConfGlobalDataDirectory <$> nglConfiguration+dataDirectory User = nConfUserDataDirectory   <$> nglConfiguration++-- These references were obtained from Ensembl+-- Check build-scripts/create-standard-packs.py for additional information+builtinReferences :: [Reference]+builtinReferences = [Reference rn (Just alias) (T.concat [rn, "-v", ver, "-", T.pack versionStr]) Nothing True False | (rn, alias, ver) <-+                [ ("bosTau4", "Bos_taurus_UMD3.1", "1.0")+                , ("ce10", "Caenorhabditis_elegans_WBcel235", "1.0")+                , ("canFam3", "Canis_familiaris_CanFam3.1", "1.0")+                , ("dm5", "Drosophila_melanogaster_BDGP5", "1.0")+                , ("dm6", "Drosophila_melanogaster_BDGP6", "1.0")+                , ("gg4", "Gallus_gallus_Galgal4", "1.0")+                , ("gg5", "Gallus_gallus_5.0", "1.0")+                , ("hg19", "Homo_sapiens_GRCh37.p13", "1.0")+                , ("hg38.p7", "Homo_sapiens_GRCh38.p7", "1.0")+                , ("hg38.p10", "Homo_sapiens_GRCh38.p10", "1.0")+                , ("mm10.p2", "Mus_musculus_GRCm38.p2", "1.0")+                , ("mm10.p5", "Mus_musculus_GRCm38.p5", "1.0")+                , ("rn5", "Rattus_norvegicus_Rnor_5.0", "1.0")+                , ("rn6", "Rattus_norvegicus_Rnor_6.0", "1.0")+                , ("sacCer3", "Saccharomyces_cerevisiae_R64-1-1", "1.0")+                , ("susScr11", "Sus_scrofa.Sscrofa11.1", "1.0")+                ]]+++findReference :: [Reference] -> T.Text -> Maybe Reference+findReference allrefs rn = find (\ref -> (refName ref == rn) || maybe False (== rn) (refAlias ref)) allrefs++-- Is this a builtin reference (i.e., can be used without importing a module)?+isBuiltinReference :: T.Text -> Bool+isBuiltinReference rn = isJust $ findReference builtinReferences rn++-- Download if it's a URL+downloadIfUrl :: FilePath -- ^ base directory+                -> FilePath -- ^ local filename+                -> Maybe FilePath+                -> NGLessIO (Maybe FilePath)+downloadIfUrl _ _ Nothing = return Nothing+downloadIfUrl basedir fname (Just path)+    | isUrl path = do+        let local = basedir </> "cached" </> fname+        liftIO $ createDirectoryIfMissing True (basedir </> "cached")+        unlessM (liftIO $ doesFileExist local) $+            withLockFile LockParameters+                     { lockFname = local ++ ".download.lock"+                     , maxAge = 300+                     , whenExistsStrategy = IfLockedRetry { nrLockRetries = 37*60, timeBetweenRetries = 60 }+                     , mtimeUpdate = True+                    } $ do+                -- recheck with lock+                unlessM (liftIO $ doesFileExist local) $+                    downloadFile path local+        return (Just local)+    | otherwise = return (Just path)++moduleDirectReference :: T.Text -> NGLessIO (Maybe ReferenceFilePaths)+moduleDirectReference rname = do+    mods <- ngleLoadedModules <$> nglEnvironment+    findM mods $ \m ->+        findM (modReferences m) $ \case+            ExternalReference eref fafile gtffile mapfile+                | eref == rname -> do+                    fafile'  <- downloadIfUrl (modPath m) (T.unpack rname <.> "fna.gz") (Just fafile)+                    gtffile' <- downloadIfUrl (modPath m) (T.unpack rname <.> "gff.gz") gtffile+                    mapfile' <- downloadIfUrl (modPath m) (T.unpack rname <.> "tsv.gz") mapfile+                    return . Just $! ReferenceFilePaths fafile' gtffile' mapfile'+            _ -> return Nothing++referencePath = "Sequence/BWAIndex/reference.fa.gz"+gffPath = "Annotation/annotation.gtf.gz"+functionalMapPath = "Annotation/functional.map.gz"++buildFaFilePath :: FilePath -> FilePath+buildFaFilePath = (</> referencePath)++buildGFFPath :: FilePath -> FilePath+buildGFFPath = (</> gffPath)++buildFunctionalMapPath :: FilePath -> FilePath+buildFunctionalMapPath = (</> functionalMapPath)++-- Create an NGLess-style reference pack, including a FASTA file, and possibly+-- one of two annotation files (GFF or TSV)+createReferencePack :: FilePath -> FilePath -> Maybe FilePath -> Maybe FilePath -> NGLessIO ()+createReferencePack oname reference mgtf mfunc = do+    (rk,tmpdir) <- createTempDir "ngless_ref_creator_"+    outputListLno' DebugOutput ["Working with temporary directory: ", tmpdir]+    liftIO $ do+        createDirectoryIfMissing True (tmpdir ++ "/Sequence/BWAIndex/")+        createDirectoryIfMissing True (tmpdir ++ "/Annotation/")+    downloadOrCopyFile reference (buildFaFilePath tmpdir)+    whenJust mgtf $ \gtf ->+        downloadOrCopyFile gtf (buildGFFPath tmpdir)+    whenJust mfunc $ \func ->+        downloadOrCopyFile func (buildFunctionalMapPath tmpdir)+    Bwa.createIndex (buildFaFilePath tmpdir)+    let indexFiles = [(dropExtension referencePath ++ "-bwa-" ++ bwaVersion ++ ".gz" ++ ext) |+                                    ext <-+                                        [".amb"+                                        ,".ann"+                                        ,".bwt"+                                        ,".pac"+                                        ,".sa"]]+        filelist = [referencePath] ++ indexFiles ++ [gffPath | isJust mgtf] ++ [functionalMapPath | isJust mfunc]+    liftIO $ withOutputFile oname $ \h ->+        BL.hPut h . GZip.compress . Tar.write =<< Tar.pack tmpdir filelist+    outputListLno' ResultOutput ["Created reference package in file ", oname]+    release rk++++-- | Make sure that the passed reference is present, downloading it if+-- necessary.+-- Returns the base path for the data.+ensureDataPresent :: T.Text -- ^ reference name (unversioned)+                        -> NGLessIO ReferenceFilePaths+ensureDataPresent rname = moduleDirectReference rname >>= \case+        Just r -> return r+        Nothing -> findDataFiles (T.unpack rname) >>= \case+            Just refdir -> wrapRefDir refdir+            Nothing -> wrapRefDir =<< installData Nothing rname+    where+        wrapRefDir refdir = return $! ReferenceFilePaths+                        (Just $ buildFaFilePath refdir)+                        (Just $ buildGFFPath refdir)+                        Nothing++-- | Installs reference data uncondictionally+-- When mode is Nothing, tries to install them in global directory, otherwise+-- installs it in the user directory+installData :: Maybe InstallMode -> T.Text -> NGLessIO FilePath+installData Nothing refname = do+    p' <- nConfGlobalDataDirectory <$> nglConfiguration+    canInstallGlobal <- liftIO $ do+        created <- (createDirectoryIfMissing False p' >> return True) `catchIOError` (\_ -> return False)+        if created+            then writable <$> getPermissions p'+            else return False+    if canInstallGlobal+        then installData (Just Root) refname+        else installData (Just User) refname+installData (Just mode) refname = do+    basedir <- dataDirectory mode+    mods <- ngleLoadedModules <$> nglEnvironment+    let unpackRef (ExternalPackagedReference r) = Just r+        unpackRef _ = Nothing+        refs = mapMaybe unpackRef $ concatMap modReferences mods+    ref  <- case findReference (refs ++ builtinReferences) refname of+        Just ref -> return ref+        Nothing -> throwScriptError ("Could not find reference '" ++ T.unpack refname ++ "'. It is not builtin nor in one of the loaded modules.")+    url <- case refUrl ref of+        Just u -> return u+        Nothing+            | isBuiltinReference (refName ref) -> do+                    version@(NGLVersion majV minV) <- ngleVersion <$> nglEnvironment+                    let versionDirectory = if version < NGLVersion 0 9+                                                then ""+                                                else show majV ++ "." ++ show minV+                    baseURL <- nConfDownloadBaseURL <$> nglConfiguration+                    return $ baseURL </> "References" </> versionDirectory </> T.unpack (refName ref) <.> "tar.gz"+            | otherwise ->+                throwScriptError ("Expected reference data, got "++T.unpack (refName ref))+    outputListLno' InfoOutput ["Starting download from ", url]+    let destdir = basedir </> "References" </> T.unpack refname+    downloadExpandTar url destdir+    outputListLno' InfoOutput ["Reference download completed!"]+    return destdir++++-- | checks first user and then global data directories for <ref>.+-- The user directory is checked first to allow the user to override a+-- problematic global installation.+findDataFiles :: FilePath -> NGLessIO (Maybe FilePath)+findDataFiles ref = liftM2 (<|>)+    (findDataFilesIn ref User)+    (findDataFilesIn ref Root)++findDataFilesIn :: FilePath -> InstallMode -> NGLessIO (Maybe FilePath)+findDataFilesIn ref mode = do+    basedir <- dataDirectory mode+    let refdir = basedir </> "References" </> ref+    hasIndex <- Bwa.hasValidIndex (buildFaFilePath refdir)+    outputListLno' TraceOutput ["Looked for ", ref, " in directory ", refdir, if hasIndex then " (and found it)" else " (and did not find it)"]+    return $! (if hasIndex+                then Just refdir+                else Nothing)+
+ NGLess/StandardModules/Batch.hs view
@@ -0,0 +1,46 @@+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++module StandardModules.Batch+    ( loadModule+    ) where++import System.Environment (lookupEnv)+import Control.Concurrent (setNumCapabilities)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Control.Applicative+import Control.Monad+import Text.Read (readMaybe)+import Data.Maybe+import Data.Default++import Language+import Modules+import NGLess+import Utils.Batch (getNcpus)++getLSFjobIndex :: IO (Maybe Integer)+getLSFjobIndex = (>>= readMaybe) <$> lookupEnv "LSB_JOBINDEX"++getGEjobIndex :: IO (Maybe Integer)+getGEjobIndex = (>>= readMaybe) <$> lookupEnv "SGE_TASK_ID"+++getJobIndex :: IO (Maybe Integer)+getJobIndex = liftA2 (<|>) getLSFjobIndex getGEjobIndex++loadModule :: T.Text -> NGLessIO Module+loadModule _ = liftIO $ do+    job_id <- getJobIndex+    ncpus <- getNcpus+    when (isJust ncpus) $+        setNumCapabilities (fromJust ncpus)+    return def+        { modInfo = ModInfo "stdlib.batch" "1.0"+        , modConstants =+                [("JOBINDEX_OR_0", NGOInteger (fromMaybe 0 job_id))+                ,("JOBINDEX_VALID", NGOBool (isJust job_id))+                ]+        }
+ NGLess/StandardModules/Example.hs view
@@ -0,0 +1,50 @@+{- Copyright 2015-2016 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE TupleSections, OverloadedStrings #-}++module StandardModules.Example+    ( loadModule+    ) where++import qualified Data.Text as T+import Control.Monad.IO.Class (liftIO)+import Data.Default++import Language+import Modules+import NGLess++execute :: T.Text -> NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+execute fname input args = liftIO $do+    putStrLn ("Called example function '"++T.unpack fname++"'")+    putStrLn ("First argument is "++show input)+    putStrLn ("Keyword arguments are "++show args)+    putStrLn "This function does nothing except print this information"+    return input++exampleFunction = Function+    { funcName = FuncName "example"+    , funcArgType = Just NGLReadSet+    , funcArgChecks = []+    , funcRetType = NGLReadSet+    , funcKwArgs =+            [ArgInformation "opt1" False NGLSymbol [ArgCheckSymbol ["test1", "test2"]]+            ]+    , funcAllowsAutoComprehension = True+    , funcChecks = []+    }++loadModule :: T.Text -> NGLessIO Module+loadModule _ = return def+    { modInfo = ModInfo "stdlib.example" "1.0"+    , modConstants =+            [("EXAMPLE_0", NGOInteger 0)+            ,("EXAMPLE_TRUE", NGOBool True)+            ,("EXAMPLE_HELLO", NGOString "Hello")+            ]+    , modFunctions = [exampleFunction]+    , runFunction = execute+    }+
+ NGLess/StandardModules/Mappers/Bwa.hs view
@@ -0,0 +1,99 @@+{- Copyright 2013-2020 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE RankNTypes #-}++module StandardModules.Mappers.Bwa+    ( hasValidIndex+    , createIndex+    , callMapper+    ) where++import           System.Directory (doesFileExist)+import           System.Posix (getFileStatus, fileSize, FileOffset)+import           System.FilePath (splitExtension)+import           Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as B++import qualified Data.Conduit as C+import           Control.Monad.Extra (allM)+import           Control.Concurrent (getNumCapabilities)++import Output+import NGLess+import Data.FastQ+import Configuration+import NGLess.NGLEnvironment+import Dependencies.Versions (bwaVersion)+import FileManagement (bwaBin)+import Utils.Process (runProcess)++-- | Appends bwa version to the index such that different versions+-- of bwa use different indices+indexPrefix :: FilePath -> NGLessIO FilePath+indexPrefix base = do+    let (basename, ext) = splitExtension base+    return $ basename ++ "-bwa-" ++ bwaVersion ++ ext++-- | Checks whether all necessary files are present for a BWA index+-- Does not change any file on disk.+hasValidIndex :: FilePath -> NGLessIO Bool+hasValidIndex basepath = do+    base <- indexPrefix basepath+    let indexRequiredFormats = [".amb",".ann",".bwt",".pac",".sa"]+    liftIO $ allM (doesFileExist . (base ++)) indexRequiredFormats++-- BWA's default indexing parameters are quite conservative. This leads to+-- a small memory footprint at the cost of more CPU hours.+-- With large databases (~100GB) default settings require over 2 weeks of+-- CPU time. Increasing the default blocksize will increase the memory+-- footprint but will reduce indexing time 3 to 6 fold.+--+-- This patch increases the blocksize to roughly 1/10th of the filesize.+-- The memory footprint should be about the size of the database.+--+-- As per https://github.com/lh3/bwa/issues/104 this patch may become+-- obsolete once this functionality is built into bwa.+--+-- | Checks whether we should customize bwa's indexing blocksize+customBlockSize :: FilePath -> IO [String]+customBlockSize path = sizeAsParam . fileSize <$> getFileStatus path++sizeAsParam :: FileOffset -> [String]+sizeAsParam size+    | size >= minimalsize = ["-b", show $ div size factor]+    | otherwise = []+        where minimalsize = 100*1000*1000 -- 100MB - if smaller, use software's default+              factor = 10++-- | Creates bwa index on disk+createIndex :: FilePath -> NGLessIO ()+createIndex fafile = do+    outputListLno' InfoOutput ["Start BWA index creation for ", fafile]+    blocksize <- liftIO $ customBlockSize fafile+    prefix <- indexPrefix fafile+    bwaPath <- bwaBin+    runProcess+            bwaPath+            (["index"] ++ blocksize ++ ["-p", prefix, fafile])+            (return ())+            (Left ())++callMapper :: FilePath -> ReadSet -> [String] -> C.ConduitT B.ByteString C.Void NGLessIO a -> NGLessIO a+callMapper refIndex rs extraArgs outC = do+    outputListLno' InfoOutput ["Starting mapping to ", refIndex]+    bwaPath <- bwaBin+    refIndex' <- indexPrefix refIndex+    numCapabilities <- liftIO getNumCapabilities+    strictThreads <- nConfStrictThreads <$> nglConfiguration+    let bwathreads+            | strictThreads && numCapabilities > 1 = numCapabilities - 1+            | otherwise = numCapabilities+                                                    -- -K 100000000 is a hidden option to set the chunk size+                                                    -- this makes the output independent of the number of threads+        cmdargs =  concat [["mem", "-t", show bwathreads, "-K", "100000000", "-p"], extraArgs, [refIndex', "-"]]+    runProcess+            bwaPath+            cmdargs+            (interleaveFQs rs) -- stdin+            (Right outC) -- stdout
+ NGLess/StandardModules/Mappers/Minimap2.hs view
@@ -0,0 +1,105 @@+{- Copyright 2018-2020 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE RankNTypes #-}++module StandardModules.Mappers.Minimap2+    ( hasValidIndex+    , createIndex+    , callMapper+    ) where++import           System.Directory (doesFileExist)+import           System.FilePath (splitExtension)+import           Control.Monad.IO.Class (liftIO)+import qualified Data.Vector as V+import qualified Data.ByteString as B++import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms (mergeC)+import           GHC.Conc (getNumCapabilities)+import           Control.Monad.Trans.Class (lift)++import Data.FastQ+import Data.Sam (isSamHeaderString)+import Output+import NGLess+import Configuration+import Dependencies.Versions (minimap2Version)+import NGLess.NGLEnvironment+import Utils.Vector (sortParallel)+import Utils.Conduit (linesC, ByteLine(..))+import Utils.Process (runProcess)+import FileManagement (makeNGLTempFile, minimap2Bin)++indexName :: FilePath -> FilePath+indexName fp = base ++ "-minimap2-" ++ minimap2Version ++ ext ++ ".mm2.idx"+    where (base, ext) = splitExtension fp++hasValidIndex :: FilePath -> NGLessIO Bool+hasValidIndex = liftIO . doesFileExist . indexName++createIndex :: FilePath -> NGLessIO ()+createIndex fafile = do+    outputListLno' InfoOutput ["Start minimap2 index creation for ", fafile]+    minimap2Path <- minimap2Bin+    runProcess+        minimap2Path+        [fafile, "-d", indexName fafile]+        (return ())+        (Left ())++callMapper :: FilePath -> ReadSet -> [String] -> C.ConduitT B.ByteString C.Void NGLessIO a -> NGLessIO a+callMapper refIndex rs extraArgs outC = do+    outputListLno' InfoOutput ["Starting mapping to ", refIndex, " (minimap2)"]+    minimap2Path <- minimap2Bin+    numCapabilities <- liftIO getNumCapabilities+    strictThreads <- nConfStrictThreads <$> nglConfiguration+    let minimap2threads+            | strictThreads && numCapabilities > 1 = numCapabilities - 1+            | otherwise = numCapabilities+        cmdargs =  concat [["-t", show minimap2threads, "-a"], extraArgs, [refIndex, "-"]]+    usam <- makeNGLTempFile "fastq" "minimap2." "sam" $ \hout -> do+        runProcess+            minimap2Path+            cmdargs+            (interleaveFQs rs) -- stdin+            (Right $ CB.sinkHandle hout) -- stdout+    C.runConduit $ sortSam usam+                        .| CL.map (`B.snoc` 10)+                        .| outC++sortSam :: FilePath -> C.ConduitT () B.ByteString NGLessIO ()+sortSam samfile =+        CB.sourceFile samfile+            .| linesC+            .| CL.map unwrapByteLine+            .| do+                CC.takeWhile isSamHeaderString+                partials <- samSorter []+                C.toProducer (mergeC partials)+    where+        samSorter :: [C.ConduitT () B.ByteString NGLessIO () ] -> C.ConduitM B.ByteString B.ByteString NGLessIO [C.ConduitT () B.ByteString NGLessIO ()]+        samSorter partials = do+                block <- CC.sinkVectorN (1024*1024)+                block' <- liftIO $ do+                    numCapabilities <- getNumCapabilities+                    block' <- V.unsafeThaw block+                    sortParallel numCapabilities block'+                    V.unsafeFreeze block'+                isDone <- CC.null+                if isDone+                    then return (CC.yieldMany block':partials)+                    else do+                        partial <- lift $+                            makeNGLTempFile samfile "partial" "sam" $ \hout ->+                                C.runConduit $+                                    CC.yieldMany block'+                                        .| CL.map (`B.snoc` 10)+                                        .| CB.sinkHandle hout+                        samSorter ((CB.sourceFile partial .| linesC .| CL.map unwrapByteLine):partials)+
+ NGLess/StandardModules/Mappers/Soap.hs view
@@ -0,0 +1,190 @@+{- Copyright 2016-2019 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++module StandardModules.Mappers.Soap+    ( hasValidIndex+    , createIndex+    , callMapper+    ) where++import System.Process+import System.IO+import System.Exit+import System.Directory+import           Control.Monad (forM_)+import           Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as BL8++import qualified UnliftIO.Async as A+import qualified Control.Concurrent.STM.TBMQueue as TQ++import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.TQueue as CA+import qualified Data.Conduit.Process as CP+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import qualified UnliftIO as U+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Utils (awaitJust)+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import           Control.Monad.Extra (guard, allM, whenM)+import           GHC.Conc (getNumCapabilities, setNumCapabilities)+import           Data.List (isSuffixOf)+import           Control.Monad.Except (MonadError)+import           Control.Monad.Trans.Resource++import Output+import NGLess+import Data.FastQ+import Utils.Conduit (ByteLine(..), linesC)+import FileManagement+import Configuration+import NGLess.NGLEnvironment+import Utils.Utils (dropEnd)++hasValidIndex :: FilePath -> NGLessIO Bool+hasValidIndex basepath = liftIO $ flip allM indexRequiredFormats $ \ext -> doesFileExist (basepath' ++ ext)+    where+        basepath'+            | ".gz" `isSuffixOf` basepath = dropEnd 3 basepath+            | otherwise = basepath+        indexRequiredFormats =+                [".index.amb"+                ,".index.ann"+                ,".index.bwt"+                ,".index.fmv"+                ,".index.hot"+                ,".index.lkt"+                ,".index.pac"+                ,".index.rev.bwt"+                ,".index.rev.fmv"+                ,".index.rev.lkt"+                ,".index.rev.pac"+                ,".index.sa"+                ,".index.sai"+                ]+++createIndex :: FilePath -> NGLessIO ()+createIndex fafile = do+    outputListLno' InfoOutput ["Start SOAP index creation for ", fafile]+    fafile' <- if ".gz" `isSuffixOf` fafile+                    then do+                        let gunzipped = dropEnd 3 fafile+                        outputListLno' WarningOutput ["SOAP indexing does not work on gzipped files directly. Gunzipping '", fafile, "'..."]+                        whenM (liftIO $ doesFileExist gunzipped) $+                            throwDataError ("SOAP indexing does not work on gzipped files (got argument '" ++ fafile ++ "' and gunzipped version already exists (so refusing to overwrite).")+                        C.runConduit $ conduitPossiblyCompressedFile fafile .| CB.sinkFile gunzipped+                        return gunzipped+                    else return fafile+    (exitCode, out, err) <- liftIO $+        readProcessWithExitCode "2bwt-builder" [fafile'] []+    outputListLno' DebugOutput ["SOAP-index stderr: ", err]+    outputListLno' DebugOutput ["SOAP-index stdout: ", out]+    case exitCode of+        ExitSuccess -> return ()+        ExitFailure _err -> throwSystemError err++callMapper :: FilePath -> ReadSet -> [String] -> C.ConduitT B.ByteString C.Void NGLessIO a -> NGLessIO a+callMapper refIndex (ReadSet rs1 rs2) extraArgs outC = do+    outputListLno' InfoOutput ["Starting mapping to ", refIndex]+    numCapabilities <- liftIO getNumCapabilities+    strictThreads <- nConfStrictThreads <$> nglConfiguration+    let fps1 = map (\(FastQFilePath _ a, FastQFilePath _ b) -> [a, b]) rs1+        fps2 = map (\(FastQFilePath _ a) -> [a]) rs2+        with1Thread act+            | strictThreads = U.bracket_+                                (liftIO $ setNumCapabilities 1)+                                (liftIO $ setNumCapabilities numCapabilities)+                                act+            | otherwise = act+        soapThreads+            | strictThreads && numCapabilities > 1 = numCapabilities - 1+            | otherwise = numCapabilities+        soapPath = "soap2.21"++    -- We are going to create a thread which simply consumes input and feeds it+    -- to `outC`. Then we feed it both the SAM header and the result of+    -- soup2sam for both runs.  This is possibly not the simplest way to+    -- achieve this goal, but without having a resumable sink, I do not see+    -- exactly how to get it all to work.+    q <- liftIO $ TQ.newTBMQueueIO 4+    out <- A.async (C.runConduit $ CA.sourceTBMQueue q .| outC)+    C.runConduitRes $+        makeSAMHeader refIndex+            .| CA.sinkTBMQueue q+    forM_ (filter (not . null) (fps1 ++ fps2)) $ \fps -> do+        (rk,(otemp,htemp)) <- openNGLTempFile' refIndex "map_" "soap"+        (rk2,(otemp2,htemp2)) <- openNGLTempFile' refIndex "map2_" "soap"+        liftIO $ hClose htemp+        liftIO $ hClose htemp2+        let fps' = case fps of+                        [fp] -> ["-a", fp]+                        [fp, fp'] -> ["-a", fp, "-b", fp', "-2", otemp2]+                        _ -> error "SOAP Multiple errors"+            cmdargs =  concat [fps', ["-p", show soapThreads, "-D", refIndex ++ ".index", "-o", otemp], extraArgs]+        outputListLno' TraceOutput ["Calling binary ", soapPath, " with args: ", unwords cmdargs]+        let cp = proc soapPath cmdargs+        (exitCode, (), err) <- liftIO $ with1Thread $+                CP.sourceProcessWithStreams cp+                    (return ()) -- stdin+                    (return ()) -- stdout+                    CL.consume -- stderr+        outputListLno' DebugOutput ["SOAP info: ", BL8.unpack $ BL8.fromChunks err]+        case exitCode of+            ExitFailure code ->+                throwSystemError $ concat ["Failed mapping\nCommand line was::\n\t",+                                soapPath, " ", unwords cmdargs, "\n",+                                "SOAP error code was ", show code, "."]+            ExitSuccess -> return ()+        outputListLno' InfoOutput ["Done mapping to ", refIndex, ". Converting to SAM..."]+        let cmdargs' =  ["-p" | length fps' == 4]+            soap2samPath = "soap2sam.pl"+            soup2sam = proc soap2samPath cmdargs'+        (exitCode', (), err') <- liftIO $+            withFile otemp ReadMode $ \otemph ->+                withFile otemp2 ReadMode $ \otemp2h ->+                    CP.sourceProcessWithStreams soup2sam+                        (CB.sourceHandle otemph >> CB.sourceHandle otemp2h) -- stdin+                        (C.toConsumer $ CA.sinkTBMQueue q) -- stdout+                        (CL.consume :: C.ConduitT B.ByteString C.Void IO [B.ByteString])+        release rk+        release rk2+        case exitCode' of+            ExitSuccess -> do+                outputListLno' InfoOutput ["Done soap2sam."]+            ExitFailure code ->+                throwSystemError $ concat ["Failed conversion to SAM\nCommand line was::\n\t",+                                soap2samPath, " ", unwords cmdargs', "\n",+                                "SOAP2SAM error code was ", show code, ".\n",+                                "Error output: ", B8.unpack (B8.intercalate "\n\t" err')]++    liftIO $ do+        U.atomically (TQ.closeTBMQueue q)+        A.wait out++makeSAMHeader :: (MonadResource m, MonadUnliftIO m, MonadThrow m, MonadError NGError m) => FilePath -> C.ConduitT () B.ByteString m ()+makeSAMHeader fafile = conduitPossiblyCompressedFile fafile .| linesC .| asSamHeader+    where+        -- asSamHeader :: C.Conduit ByteLine IO B.ByteString+        asSamHeader = awaitJust $ \(ByteLine line) -> case readId line of+                                                Just rid -> processRead rid 0+                                                Nothing -> return ()+        -- processRead :: B.ByteString -> Int -> C.Conduit ByteLine IO B.ByteString+        processRead rid !n = C.await >>= \case+            Nothing -> emit rid n+            Just (ByteLine line) -> case readId line of+                Just rid' -> do+                    emit rid n+                    processRead rid' 0+                Nothing -> processRead rid (n + B.length line)+        readId :: B.ByteString -> Maybe B.ByteString+        readId line = do+            (mark,rest) <- B8.uncons line+            guard (mark == '>')+            return $ head (B8.split ' ' rest)+        emit rid n = C.yield $ B.concat ["@SQ\tSN:", rid, "\t", B8.pack (show n), "\n"]
+ NGLess/StandardModules/Minimap2.hs view
@@ -0,0 +1,29 @@+{- Copyright 2018-2019 NGLess Authors+ - License: MIT+ -}++module StandardModules.Minimap2+    ( loadModule+    ) where++import qualified Data.Text as T+import Data.Default++import NGLess+import Modules+import NGLess.NGLEnvironment++loadModule :: T.Text -> NGLessIO Module+loadModule _ = do+    updateNglEnvironment addMinimap2+    return def+        { modInfo = ModInfo "stdlib.minimap2" "1.0"+        , modCitations = [citation]+        , modFunctions = []+        , runFunction = \_ _ _ -> throwShouldNotOccur "minimap2 has no functions!"+        }+    where+        addMinimap2 e@NGLEnvironment { ngleMappersActive = p } = e { ngleMappersActive = "minimap2":p }+        citation = T.concat+                    ["Li.  Minimap2: pairwise alignment for nucleotide sequences"+                    ," in arXiv (2018) https://arxiv.org/abs/1708.01492"]
+ NGLess/StandardModules/Mocat.hs view
@@ -0,0 +1,110 @@+{- Copyright 2016-2020 NGLess Authors+ - License: MIT+ -}+++module StandardModules.Mocat+    ( loadModule+    ) where++import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Conduit.Combinators as C+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import Control.Monad+import Data.Default+++import Output+import NGLess+import Modules+import Language+import FileManagement+import Utils.Conduit+import NGLess.NGLEnvironment+import BuiltinModules.LoadDirectory (executeLoad)++executeLoad' :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeLoad' expr kwargs = do+    v <- ngleVersion <$> nglEnvironment+    when (v >= NGLVersion 1 2) $+        outputListLno' InfoOutput [+                        "load_mocat_sample is now available as load_fastq_directory without the need to load the 'mocat' module"]+    executeLoad expr kwargs+++executeParseCoord :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeParseCoord (NGOString coordfp) _ = do+    let coordfp' = T.unpack coordfp+    newfp <- makeNGLTempFile coordfp' "converted_" "gtf" $ \hout ->+        C.runConduit $+            conduitPossiblyCompressedFile coordfp'+                .| linesC+                .| CL.mapM convertToGff+                .| C.unlinesAscii+                .| C.sinkHandle hout+    return (NGOString . T.pack $ newfp)+        where+            convertToGff :: ByteLine -> NGLessIO B.ByteString+            convertToGff (ByteLine line) = case B8.split '\t' line of+                                    [gene,start,end] -> return $! B.intercalate "\t"+                                                                    [gene+                                                                    ,"protein_coding"+                                                                    ,"gene"+                                                                    ,start+                                                                    ,end+                                                                    ,"."+                                                                    ,"."+                                                                    ,"."+                                                                    ,B.concat ["gene_id=\"", gene, "\""]+                                                                    ]+                                    _ -> throwDataError ("Could not parse coord file entry: " ++ show line)+executeParseCoord other _ = throwScriptError ("coord_file_to_gtf called with wrong argument: " ++ show other)++mocatLoadSample = Function+    { funcName = FuncName "load_mocat_sample"+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLReadSet+    , funcKwArgs =+            [ArgInformation "__perform_qc" False NGLBool []+            ,ArgInformation "encoding" False NGLSymbol [ArgCheckSymbol ["auto", "33", "64", "sanger", "solexa"]]+            ]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++coordToGtf = Function+    { funcName = FuncName "coord_file_to_gtf"+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLString+    , funcKwArgs = []+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }+++loadModule :: T.Text -> NGLessIO Module+loadModule _ =+        return def+        { modInfo = ModInfo "stdlib.mocat" "1.1"+        , modCitations = citations+        , modFunctions = [mocatLoadSample, coordToGtf]+        , runFunction = \case+                        "load_mocat_sample" -> executeLoad'+                        "coord_file_to_gtf" -> executeParseCoord+                        other -> \_ _ -> throwShouldNotOccur ("mocat execute function called with wrong arguments: " ++ show other)+        }+    where+        citations =+            [T.concat ["MOCAT2: a metagenomic assembly, annotation and profiling framework.\n"+            ,"Kultima JR, Coelho LP, Forslund K, Huerta-Cepas J, Li S, Driessen M, et al. (2016)\n"+            ,"Bioinformatics (2016) doi:10.1093/bioinformatics/btw183\n\n"]+            ,T.concat ["MOCAT: A Metagenomics Assembly and Gene Prediction Toolkit.\n"+            ,"Kultima JR, Sunagawa S, Li J, Chen W, Chen H, Mende DR, et al. (2012)\n"+            ,"PLoS ONE 7(10): e47656. doi:10.1371/journal.pone.0047656\n"]]
+ NGLess/StandardModules/Motus.hs view
@@ -0,0 +1,28 @@+{- Copyright 2022 NGLess Authors+ - License: MIT+ -}++module StandardModules.Motus+    ( loadModule+    ) where++import qualified Data.Text as T+import Control.Monad (when)++import Modules+import Output+import NGLess+import NGLess.NGLEnvironment+import qualified ExternalModules++loadModule :: T.Text -> NGLessIO Module+loadModule ver+    | ver == "1.0" = do+        activeVersion <- ngleVersion <$> nglEnvironment+        when (activeVersion >= NGLVersion 1 4) $+            throwScriptError "motus module is not supported in NGLess 1.4 (it supported motus1 only and that is now very old; please see https://github.com/ngless-toolkit/ngless-contrib/tree/master/motus.ngm)"+        outputListLno' WarningOutput ["motus module is deprecated\nIt supports motus1 only and that is now very old (please see https://github.com/ngless-toolkit/ngless-contrib/tree/master/motus.ngm)"]+        let info = ModInfo "motus" ver+        ExternalModules.loadModule info+    | otherwise = do+        throwScriptError "To use the motus module for newer versions, you need to download it and import it with 'local import'"
+ NGLess/StandardModules/NGLStdlib.hs view
@@ -0,0 +1,36 @@+{- Copyright 2015-2022 NGLess Authors+ - License: MIT+ -}++module StandardModules.NGLStdlib+    ( loadStdlibModules+    ) where+++import qualified StandardModules.Example as Example+import qualified StandardModules.Batch as Batch+import qualified StandardModules.Samtools as Samtools+import qualified StandardModules.Mocat as Mocat+import qualified StandardModules.Soap as Soap+import qualified StandardModules.Minimap2 as Minimap2+import qualified StandardModules.Parallel as Parallel+import qualified StandardModules.Motus as Motus1+import qualified ExternalModules as Ext++import Modules+import NGLess++loadStdlibModules :: [ModInfo] -> NGLessIO [Module]+loadStdlibModules = mapM loadModules1+    where+        loadModules1 :: ModInfo -> NGLessIO Module+        loadModules1 (ModInfo "example" version) = Example.loadModule version+        loadModules1 (ModInfo "batch" version) = Batch.loadModule version+        loadModules1 (ModInfo "samtools" version) = Samtools.loadModule version+        loadModules1 (ModInfo "mocat" version) = Mocat.loadModule version+        loadModules1 (ModInfo "parallel" version) = Parallel.loadModule version+        loadModules1 (ModInfo "soap" version) = Soap.loadModule version+        loadModules1 (ModInfo "minimap2" version) = Minimap2.loadModule version+        loadModules1 (ModInfo "motus" version) = Motus1.loadModule version+        loadModules1 minfo = Ext.loadModule minfo+
+ NGLess/StandardModules/Parallel.hs view
@@ -0,0 +1,616 @@+{- Copyright 2016-2022 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE FlexibleContexts, CPP #-}++module StandardModules.Parallel+    ( loadModule+    , pasteCounts+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import           Data.Time (getZonedTime)+import           Data.Time.Format (formatTime, defaultTimeLocale)+import           Data.List.Extra (snoc, chunksOf)++#ifndef WINDOWS+import           System.Posix.Unistd (fileSynchronise)+import           System.Posix.IO (openFd, defaultFileFlags, closeFd, OpenMode(..))+import           Control.Exception (bracket)+#endif+++import           System.FilePath+import           GHC.Conc (getNumCapabilities, atomically)+import qualified Control.Concurrent.Async as A+import qualified Control.Concurrent.STM.TBMQueue as TQ+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.TQueue as CA+import qualified Data.Conduit.Algorithms as CAlg+import qualified Data.Conduit.Algorithms.Async as CAlg+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import           Control.Monad.ST (runST)+import           Control.Monad.Except (throwError)+import           Control.Monad.Extra (allM, unlessM)+import           Control.DeepSeq+import           Data.Traversable+import           Control.Monad.Trans.Class+import           System.AtomicWrite.Writer.Text (atomicWriteFile)+++import Control.Monad.Trans.Resource+import Control.Monad.State.Lazy+import System.IO+import Data.Default+import Data.Maybe (fromMaybe)+import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents)++import qualified Data.Hash.MD5 as MD5+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.Binary as CB+import           Data.Conduit ((.|), (.|), ($$+))++import Output+import NGLess+import Modules+import Language+import Transform+import FileOrStream+import Configuration+import FileManagement+import NGLess.NGError+import NGLess.NGLEnvironment++import Interpretation.Write (moveOrCopyCompress)++import Utils.Utils (fmapMaybeM, allSame, moveOrCopy)+import Utils.Conduit+import Utils.LockFile++syncFile :: FilePath -> IO ()+#ifndef WINDOWS+syncFile fname = do+    bracket (openFd fname ReadWrite Nothing defaultFileFlags)+        closeFd+        fileSynchronise+    -- The code below will not work on Windows+    bracket (openFd (takeDirectory fname) ReadOnly Nothing defaultFileFlags)+        closeFd+        fileSynchronise++#else+syncFile _ = return ()+#endif+++setupHashDirectory :: String -> FilePath -> T.Text -> NGLessIO FilePath+setupHashDirectory prefix basename hash = do+    isSubsample <- nConfSubsample <$> nglConfiguration+    let actiondir = basename </> prefix ++ take 8 (T.unpack hash) ++ (if isSubsample then "-subsample" else "")+        scriptfile = actiondir </> "script.ngl"+    liftIO $ createDirectoryIfMissing True actiondir+    unlessM (liftIO $ doesFileExist scriptfile) $ do+        sct <- ngleScriptText <$> nglEnvironment+        liftIO $ atomicWriteFile scriptfile sct+    return actiondir++-- Beware that addition of characters here can lead to lock collisions+-- as is "project/sample" clashes with "project_sample" but ... uncommon case+unsafeCharMap = [('/', '_'),+                 ('\\', '_')]++-- | Remove '/' and '\' from filenames+sanitizePath :: T.Text -> T.Text+sanitizePath = T.map (\x -> fromMaybe x (lookup x unsafeCharMap))++executeLock1 (NGOList entries) kwargs  = do+    entries' <- mapM (stringOrTypeError "lock1") entries+    hash <- lookupStringOrScriptError "lock1" "__hash" kwargs+    tag <- lookupStringOrScriptErrorDef (return "") "collect arguments (hidden tag)" "__parallel_tag" kwargs+    let prefix+            | T.null tag = ""+            | otherwise = T.unpack tag ++ "-"+    lockdir <- setupHashDirectory prefix "ngless-locks" hash+    -- Keep a map of 'sane -> original' names used for locks to backtrace+    -- what file was locked and return the unsanitized name+    -- See also https://github.com/ngless-toolkit/ngless/issues/68+    let saneentries = sanitizePath <$> entries'+        lockmap = zip saneentries entries'+    (e,rk) <- getLock lockdir saneentries+    outputListLno' InfoOutput ["lock1: Obtained lock file: '", lockdir </> T.unpack e ++ ".lock", "'"]+    reportbase <- setupHashDirectory prefix "ngless-stats" hash+    let reportdir = reportbase </> T.unpack e+    outputListLno' InfoOutput ["Writing stats to '", reportdir, "'"]+    let setReportDir c = c { nConfReportDirectory = reportdir }+    updateNglEnvironment $ \env -> env { ngleConfiguration = setReportDir (ngleConfiguration env) }+    registerHook FinishOkHook $ do+        let receiptfile = lockdir </> T.unpack e ++ ".finished"+        liftIO $ withFile receiptfile WriteMode $ \h -> do+            t <- getZonedTime+            let tformat = "%a %d-%m-%Y %R"+                tstr = formatTime defaultTimeLocale tformat t+            hPutStrLn h (concat ["Finished ", T.unpack e, " at ", tstr])+        release rk+    registerFailHook $ do+        let logfile = lockdir </> T.unpack e ++ ".failed"+        withFile logfile WriteMode $ \h ->+            hPutStrLn h "Execution failed" -- TODO output log here+    return $! NGOString $ fromMaybe e $ lookup e lockmap++executeLock1 arg _ = throwScriptError ("Wrong argument for lock1 (expected a list of strings, got `" ++ show arg ++ "`")+++lockName = (++ ".lock") . T.unpack+finishedName = (++ ".finished") . T.unpack+failedName = (++ ".failed") . T.unpack++-- | Create a lock file+getLock :: FilePath+                -- ^  directory where to create locks+                -> [T.Text]+                -- ^ keys to attempt to ock+                -> NGLessIO (T.Text, ReleaseKey)+getLock basedir fs = do+    existing <- liftIO $ getDirectoryContents basedir+    let notfinished = flip filter fs $ \fname -> finishedName fname `notElem` existing+        notlocked = flip filter notfinished $ \fname -> lockName fname `notElem` existing+        notfailed = flip filter notlocked $ \fname -> failedName fname `notElem` existing++    outputListLno' TraceOutput [+                    "Looking for a lock in ", basedir, ". ",+                    "Total number of elements is ", show (length fs),+                    " (not locked: ", show (length notlocked), "; not finished: ", show (length notfinished), ")."]+    -- first try all the elements that are not locked and have not failed+    -- if that fails, try the unlocked but failed+    -- Finally, try the locked elements in the hope that some may be stale+    getLock' basedir notfailed >>= \case+        Just v -> return v+        Nothing -> getLock' basedir (filter (`notElem` notfailed) notlocked) >>= \case+            Just v -> return v+            Nothing -> do+                outputListLno' TraceOutput ["All elements locked. checking for stale locks"]+                getLock' basedir notfinished >>= \case+                    Just v -> return v+                    Nothing -> do+                        let msg = if null (notfailed ++ notfailed)+                                then "All jobs are finished"+                                else "Jobs appear to be running"+                        outputListLno' WarningOutput ["Could get a lock for any file: ", msg]+                        throwError $ NGError NoErrorExit msg++getLock' _ [] = return Nothing+getLock' basedir (f:fs) = do+    let lockname = basedir </> lockName f+    finished <- liftIO $ doesFileExist (basedir </> finishedName f)+    if finished+        then getLock' basedir fs+        else acquireLock LockParameters+                            { lockFname = lockname+                            , maxAge = fromInteger (60*60)+                                -- one hour. Given that lock files are touched+                                -- every ten minutes if things are good (see+                                -- thread below), this is an indication that+                                -- the process has crashed+                            , whenExistsStrategy = IfLockedNothing+                            , mtimeUpdate = True } >>= \case+            Nothing -> getLock' basedir fs+            Just rk -> do+                return $ Just (f,rk)++executeCollect :: NGLessObject -> [(T.Text, NGLessObject)] -> NGLessIO NGLessObject+executeCollect (NGOCounts istream) kwargs = do+    isSubsample <- nConfSubsample <$> nglConfiguration+    current <- lookupStringOrScriptError "collect arguments" "current" kwargs+    allentries <- lookupStringListOrScriptError "collect arguments" "allneeded" kwargs+    ofile <- lookupStringOrScriptError "collect arguments" "ofile" kwargs+    hash <- lookupStringOrScriptError "collect arguments" "__hash" kwargs+    tag <- lookupStringOrScriptErrorDef (return "") "collect arguments (hidden tag)" "__parallel_tag" kwargs+    let prefix+            | T.null tag = ""+            | otherwise = T.unpack tag ++ "-"+    hashdir <- setupHashDirectory prefix "ngless-partials" hash+    (gzfp,gzout) <- openNGLTempFile "compress" "partial." "tsv.gz"+    C.runConduit $+        (snd . asStream $ istream)+        .| CC.concat+        .| CL.map unwrapByteLine+        .| C.unlinesAscii+        .| CAlg.asyncGzipTo gzout+    let partialfile entry = hashdir </> "partial." ++ T.unpack (sanitizePath entry) <.> "tsv.gz"+    outputListLno' TraceOutput ["Collect will write partial file to ", partialfile current]+    liftIO $ do+        hClose gzout+        syncFile gzfp+        moveOrCopy gzfp (partialfile current)+    canCollect <- liftIO $ allM (doesFileExist . partialfile)  (reverse allentries)+                 -- ^ checking in reverse order makes it more likely that ngless notices a missing file early on++    -- It seems wasteful to build the comment string even if `canCollect` is False.+    -- However, these operations are very cheap and provide some basic error checking:+    manualComment <- fmapMaybeM (stringOrTypeError "comment argument to collect() function") (lookup "comment" kwargs)++    autoComments <- case lookup "auto_comments" kwargs of+                        Nothing -> return []+                        Just (NGOList cs) -> mapM (\s -> do+                                                        let errmsg = "auto_comments argument in collect() call"+                                                        symbolOrTypeError errmsg s >>=+                                                            decodeSymbolOrError errmsg+                                                                [("date", AutoDate)+                                                                ,("script", AutoScript)+                                                                ,("hash", AutoResultHash)]) cs+                        _ -> throwScriptError "auto_comments argument to collect() call must be a list of symbols"+    comment <- buildComment manualComment autoComments hash++    if canCollect+        then do+            outputListLno' TraceOutput ["Can collect"]+            newfp <- pasteCounts comment False allentries (map partialfile allentries)+            outputListLno' TraceOutput ["Pasted. Will move result to ", T.unpack ofile]+            moveOrCopyCompress True newfp (T.unpack ofile ++ (if isSubsample then ".subsample" else ""))+        else do+            outputListLno' TraceOutput ["Cannot collect (not all files present yet), wrote partial file to ", partialfile current]+            Just lno <- ngleLno <$> nglEnvironment+            registerHook FinishOkHook $+                outputListLno InfoOutput Nothing+                        ["The collect() call at line ", show lno, " could not be executed as there are partial results missing.\n"+                        ,"When you use the parallel module and the collect() function,\n"+                        ,"you typically need to run ngless *multiple times* (once per sample)!\n"+                        ,"\n\n"+                        ,"For more information, see https://ngless.embl.de/stdlib.html#parallel-module"]+    return NGOVoid+executeCollect arg _ = throwScriptError ("collect got unexpected argument: " ++ show arg)++executeSetTag :: NGLessObject -> [(T.Text, NGLessObject)] -> NGLessIO NGLessObject+executeSetTag _ _ = throwShouldNotOccur "set_parallel_tag should have been transformed away!"+++-- | split a list into a given number of (roughly) equally sized chunks+nChunks :: Int -- ^ number of chunks+            -> [a] -> [[a]]+nChunks 1 xs = [xs]+nChunks n xs = chunksOf p xs+    where+        p = 1 + (length xs `div` n)++splitAtTab ell = case B.elemIndex 9 ell of -- 9 is TAB+    Nothing -> throwDataError "Line does not have a TAB character"+    Just tix -> return $ B.splitAt tix ell++-- partialPaste pastes a set of inputs, returning both the indices (row+-- headers) and the pasted row content+partialPaste :: [V.Vector B.ByteString] -> NGLess (V.Vector B.ByteString, V.Vector B.ByteString)+partialPaste [] = throwShouldNotOccur "partialPaste called with empty vector"+partialPaste vs+    | not (allSame $ V.length <$> vs) = throwDataError $ "collect(): inputs have differing number of rows"+partialPaste (first_ell:ells) = runST $ do+        indices <- VM.new n+        contents <- VM.new n+        fillData 0 indices contents+    where+        n = V.length first_ell+        splitCheck :: Int -> B.ByteString -> V.Vector B.ByteString -> NGLess B.ByteString+        splitCheck !ix !h e+            | B.isPrefixOf h (e V.! ix) = return $! B.drop (B.length h) (e V.! ix)+            | otherwise = throwDataError $+                                "Inconsistent row index in files for collect() [expected index entry '"++B8.unpack h++"', saw '"++B8.unpack (e V.! ix)++"']."+        fillData !ix indices contents+            | ix == n = do+                indices' <- V.unsafeFreeze indices+                contents' <- V.unsafeFreeze contents+                return . Right $ (indices', contents')+            | otherwise = case splitAtTab (first_ell V.! ix) of+                    Left err -> return $ Left err+                    Right (!h,!c) -> case forM ells (splitCheck ix h) of+                        Left err -> return $ Left err+                        Right cs -> do+                            VM.write indices ix h+                            VM.write contents ix $! B.concat (c:cs)+                            fillData (ix + 1) indices contents++concatPartials :: [(V.Vector B.ByteString, V.Vector B.ByteString)] -> NGLess BL.ByteString+concatPartials [] = throwShouldNotOccur "concatPartials of empty set"+concatPartials groups+    | not (allSame (fst <$> groups)) = throwDataError "indices do not match"+    | otherwise = do+        let contents = snd <$> groups+            header = fst (head groups)+        return . BL.fromChunks $ concatMap (\ix -> (header V.! ix):(map (V.! ix) contents ++ ["\n"])) [0 .. V.length header - 1]++-- | strict variation of sinkTBMQueue+sinkTBMQueue' q shouldClose = do+        C.awaitForever $ \ !v -> liftSTM (TQ.writeTBMQueue q v)+        when shouldClose (liftSTM $ TQ.closeTBMQueue q)+    where+        liftSTM = liftIO . atomically++-- If the number of input files is very large (>1024, typically), we risk+-- hitting the limit on open files by a process, so we work in batches of 512.+maxNrOpenFiles = 512 :: Int+++{- Now there is a whole lot of complicated code to efficiently solve the+ - following problem:+ -+ - INPUT 0+ -+ -       h0+ - row1 c01+ - row2 c02+ - row3 c03+ -+ - INPUT 1+ -+ -       h1+ - row0 c11+ - row2 c12+ - row4 c14+ -+ - INPUT 2+ -+ -       h2+ - row0 c21+ - row1 c21+ - row3 c23+ -+ - should produce+ -+ - OUTPUT+ -+ -       h0  h1  h2+ - row0 c00 c10 c20+ - row1 c01 c11 c21+ - row2 c02 c12 c22+ - row3 c03 c13 c23+ - row4 c04 c14 c24+ -+ - Where the missing values (e.g., c00) are assumed to be 0+ -+ - A further complication is that each individual input file may itself have+ - multiple columns.+ -}++data SparseCountData = SparseCountData+                            { spdHeader :: !B.ByteString+                            , _spdIndex :: {-# UNPACK #-} !Int+                            , _spdPayload :: !B.ByteString+                            }+    deriving (Eq)++instance Ord SparseCountData where+    compare (SparseCountData ah ai _) (SparseCountData bh bi _) = case compare ah bh of+        EQ -> compare ai bi+        LT -> LT+        GT -> GT++tagSource :: Int -> C.ConduitT ByteLine SparseCountData NGLessIO ()+tagSource ix = C.awaitForever $ \(ByteLine v) -> case splitAtTab v of+    Left err -> lift $ throwError err+    Right (h, pay) -> C.yield $ SparseCountData h ix pay++-- complete takes a set of SparseCountData and fills in missing columns from+-- the placeholder set.+--+-- Example+--      placeholder = [p_0, p_1, p_2, p_3, p_4]+--      hinput = ...+--      inputs = [h_0 0 l_0, h_2 2 l_2, h_3 3 l_3]+--+--      output = [l_0, p_1, l_2, l_3, p_4]+--+complete :: [B.ByteString] -> (SparseCountData,[SparseCountData]) -> ByteLine+complete placeholders (hinput,inputs) = ByteLine $ B.concat merged+    where+        header = spdHeader hinput+        merged = header:complete' 0 placeholders (hinput:inputs)+        complete' _ [] [] = []+        complete' _ [] (_:_) = error "Logic error in StandardModules/parallel//complete"+        complete' ix (p:ps) xs@(SparseCountData _ ix' pay:rest)+            | ix == ix' = pay:complete' (ix+1) ps rest+            | otherwise = p:complete' (ix+1) ps xs+        complete' _ ps [] = ps++-- Merge input lines by index (first element). The input lines are assumed to+-- be sorted, but not necessary identical (i.e., some may be missing).+mergeCounts :: [C.ConduitT () ByteLine NGLessIO ()] -> C.ConduitT () ByteLine NGLessIO ()+mergeCounts [] = throwShouldNotOccur "Attempt to merge empty sources"+mergeCounts ss = do+        start <- forM ss $ \s -> do+            (s', v) <- lift $ s $$+ (CL.mapM (splitAtTab . unwrapByteLine) .| CC.head)+            case v of+                Nothing -> do+                    lift $ outputListLno' WarningOutput ["Merging empty file"]+                    return (s', placeholder 1)+                Just (_,hs) -> do+                    let p = placeholder (B8.count '\t' hs)+                    return (s', p)+        let (ss', placeholders) = unzip start+            ss'' = map C.unsealConduitT ss'+        CAlg.mergeC [s .| tagSource ix | (s,ix) <- zip ss'' [0..]]+            .| CL.groupOn1 spdHeader+            .| CL.map (complete placeholders)+    where+        placeholder :: Int -> B.ByteString+        placeholder n = B.intercalate "\t" ("":["0" | _ <- [1..n]])+++{- There are two modes:+ -+ - 1) The rows match (i.e., row headers are always identical). This is the easy+ - case, and it is like the `paste` command+ -+ - 2) The rows do not match. In this case, NGLess assumes that they are sorted+ - [in "C" locale] and merges them.+ -}+pasteCounts :: [T.Text]+            -- ^ comment text+            -> Bool+            -- ^ whether rows match+            -> [T.Text]+            -- ^ headers+            -> [FilePath]+            -- ^ input files+            -> NGLessIO FilePath+pasteCounts comments matchingRows headers inputs+    | length inputs > maxNrOpenFiles = do+        let current = take maxNrOpenFiles inputs+            currenth = take maxNrOpenFiles headers+            rest = drop maxNrOpenFiles inputs+            resth = drop maxNrOpenFiles headers+        first <- pasteCounts [] matchingRows currenth current+        pasteCounts comments matchingRows (snoc resth $ T.intercalate "\t" currenth) (snoc rest first)+    | otherwise = makeNGLTempFile "collected" "collected.counts." "txt" $ \hout -> do+        C.runConduit (commentC "# " comments .| CB.sinkHandle hout)+        liftIO $ T.hPutStrLn hout (T.intercalate "\t" ("":headers))+        numCapabilities <- liftIO getNumCapabilities+        if matchingRows+            then do+                let sources =+                        [conduitPossiblyCompressedFile f+                            .| CB.lines+                            .| (CC.drop 1 >>+                                C.conduitVector 2048 :: C.ConduitT B.ByteString (V.Vector B.ByteString) (ResourceT IO) ())+                            | f <- inputs]+                    sourcesplits = nChunks numCapabilities sources+                channels <- liftIO $ forM sourcesplits $ \ss -> do+                    ch <- TQ.newTBMQueueIO 4+                    a <- A.async $ C.runConduitRes (C.sequenceSources ss .| CL.map (force . partialPaste) .| sinkTBMQueue' ch True)+                    A.link a+                    return (CA.sourceTBMQueue ch, a)+                C.runConduit $+                    C.sequenceSources (fst <$> channels)+                    .| CAlg.asyncMapEitherC numCapabilities (sequence >=> concatPartials)+                    .| CL.map BB.lazyByteString+                    .| CB.sinkHandleBuilder hout+                forM_ (snd <$> channels) (liftIO . A.wait)+            else C.runConduit $+                    mergeCounts [conduitPossiblyCompressedFile f .|  linesC | f <- inputs]+                    .| byteLineSinkHandle hout+++executePaste :: NGLessObject -> [(T.Text, NGLessObject)] -> NGLessIO NGLessObject+executePaste (NGOList ifiles) kwargs = do+    outputListLno' WarningOutput ["Calling __paste which is an internal function, exposed for testing only"]+    ofile <- lookupStringOrScriptError "__paste arguments" "ofile" kwargs+    headers <- lookupStringListOrScriptError "__paste arguments" "headers" kwargs+    matchingRows <- lookupBoolOrScriptErrorDef (return False) "__paste arguments" "matching_rows" kwargs+    ifiles' <- forM ifiles (stringOrTypeError "__concat argument")+    newfp <- pasteCounts [] matchingRows headers (map T.unpack ifiles')+    liftIO $ moveOrCopy newfp (T.unpack ofile)+    return NGOVoid+executePaste _ _ = throwScriptError "Bad call to test function __paste"++lock1 = Function+    { funcName = FuncName "lock1"+    , funcArgType = Just (NGList NGLString)+    , funcArgChecks = []+    , funcRetType = NGLString+    , funcKwArgs = []+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++collectFunction = Function+    { funcName = FuncName "collect"+    , funcArgType = Just NGLCounts+    , funcArgChecks = []+    , funcRetType = NGLVoid+    , funcKwArgs =+        [ArgInformation "current" True NGLString []+        ,ArgInformation "allneeded" True (NGList NGLString) []+        ,ArgInformation "ofile" True NGLString [ArgCheckFileWritable]+        ,ArgInformation "__can_move" False NGLBool []+        ,ArgInformation "comment" False NGLString []+        ,ArgInformation "auto_comments" False (NGList NGLSymbol) [ArgCheckSymbol ["date", "script", "hash"]]+        ]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++setTagFunction = Function+    { funcName = FuncName "set_parallel_tag"+    , funcArgType = Just NGLString+    , funcArgChecks = []+    , funcRetType = NGLString+    , funcKwArgs = []+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }+++pasteHiddenFunction = Function+    { funcName = FuncName "__paste"+    , funcArgType = Just (NGList NGLString)+    , funcArgChecks = []+    , funcRetType = NGLString+    , funcKwArgs =+        [ ArgInformation "ofile" True NGLString [ArgCheckFileWritable]+        , ArgInformation "headers" True (NGList NGLString) []+        , ArgInformation "matching_rows" False NGLBool []+        ]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++parallelTransform :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+parallelTransform script = addLockHash (processSetParallelTag script)++addLockHash :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+addLockHash script = pureTransform addLockHash' script+    where+        addLockHash' :: Expression -> Expression+        addLockHash' (FunctionCall (FuncName "lock1") expr kwargs block) =+            FunctionCall (FuncName "lock1") expr ((Variable "__hash", ConstStr h):kwargs) block+            where+                h = T.pack . MD5.md5s . MD5.Str . show $ map snd script+        addLockHash' e = e+++processSetParallelTag :: [(Int, Expression)] -> [(Int, Expression)]+processSetParallelTag = processSetParallelTag' False+    where+        processSetParallelTag' :: Bool -> [(Int, Expression)] -> [(Int, Expression)]+        processSetParallelTag' _ [] = []+        processSetParallelTag' hasTag ((lno, e):rest) = let+                (e',ch) = case e of+                    FunctionCall (FuncName "set_parallel_tag") expr [] Nothing+                            -> (Assignment (Variable "$parallel$tag") expr, True)+                    FunctionCall fn@(FuncName fname) expr kwargs block+                        | hasTag && fname `elem` ["lock1", "collect"]+                            -> (FunctionCall fn expr ((Variable "__parallel_tag", Lookup (Just NGLString) (Variable "$parallel$tag")):kwargs) block, True)+                    _ -> (e, False)+                rest' = processSetParallelTag' (hasTag || ch) rest+            in (lno, e'):rest'+++loadModule :: T.Text -> NGLessIO Module+loadModule v+    | v `notElem` ["1.0", "0.6"] = throwScriptError ("The behaviour of the parallel module changed.\n"+++                                    "Only versions 1.0 & 0.6 is now supported (currently attempting to import version '"++T.unpack v++"')")+    | otherwise =+        return def+        { modInfo = ModInfo "stdlib.parallel" "1.0"+        , modFunctions =+            [ lock1+            , collectFunction+            , setTagFunction+            , pasteHiddenFunction+            ]+        , modTransform = parallelTransform+        , runFunction = \case+            "lock1" -> executeLock1+            "collect" -> executeCollect+            "set_parallel_tag" -> executeSetTag+            "__paste" -> executePaste+            _ -> error "Bad function name"+        }+
+ NGLess/StandardModules/Samtools.hs view
@@ -0,0 +1,246 @@+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}++module StandardModules.Samtools+    ( loadModule+    ) where++import Control.Monad.Trans.Resource+import Control.Exception+import Control.Concurrent+import Control.Monad++import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import qualified Data.Text as T+import qualified Control.Concurrent.Async as A+import           Data.List (uncons, tails)+import           Data.Maybe (mapMaybe)+++import System.FilePath+import System.Process+import System.Exit+import System.IO++import Control.Monad.IO.Class (liftIO)+import Data.Default (def)++import FileManagement+import FileOrStream+import Transform+import Language+import Modules+import Output+import NGLess++import Utils.Conduit (byteLineVSinkHandle)+import Utils.Utils (passthrough)+++headtails :: [a] -> [(a,[a])]+headtails = mapMaybe uncons . tails++-- This function is necessary because we cannot call readProcessWithErrorCode directly (see comment below)+callSamtools :: FileOrStream -> [String] -> Handle -> NGLessIO ExitCode+callSamtools istream cmdargs hout = do+    samtoolsPath <- samtoolsBin+    outputListLno' TraceOutput ["Calling binary ", samtoolsPath, " with args: ", unwords cmdargs]+    let (_, istream') = asSamStream istream+        cp = (proc samtoolsPath cmdargs) { std_in = CreatePipe, std_out = UseHandle hout, std_err = CreatePipe }+    (Just pipe_out, Nothing, Just herr, jHandle) <- liftIO $ createProcess cp+    samP <- liftIO . A.async $ waitForProcess jHandle+    errP <- liftIO . A.async $ do+                -- In a separate thread, consume all the error input.+                -- the same pattern is used in the implementation of+                -- readProcessWithErrorCode (which cannot be used here+                -- as we want control over stdin/stdout)+                err <- hGetContents herr+                void (evaluate (length err))+                hClose herr+                return err+    C.runConduit $ istream' .| byteLineVSinkHandle pipe_out+    (err,exitCode) <- liftIO $ do+        hClose pipe_out+        A.waitBoth errP samP+    outputListLno' DebugOutput ["Samtools err output: ", err]+    liftIO $ hClose hout+    return exitCode++executeSort :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeSort (NGOMappedReadSet name istream rinfo) args = do+    outBam <- lookupBoolOrScriptErrorDef (return False) "samtools_sort" "__output_bam" args+    sortByName <- lookupSymbolOrScriptErrorDef (return "coordinate") "arguments to samtools_sort" "by" args >>= \case+        "coordinate" -> return False+        "name" -> return True+        other -> throwShouldNotOccur ("Check failed. No samtool_sort option: " ++ T.unpack other)+    let oformat = if outBam then "bam" else "sam"+        fname = case istream of+                    File f -> f+                    Stream _ f _ -> f+    (rk, (newfp, hout)) <- openNGLTempFile' fname "sorted_" oformat+    (trk, tdirectory) <- createTempDir "samtools_sort_temp"++    numCapabilities <- liftIO getNumCapabilities+    let cmdargs = ["sort"] <> ["-n" | sortByName] <> ["-@", show numCapabilities, "-O", oformat, "-T", tdirectory </> "samruntmp"]+    exitCode <- callSamtools istream cmdargs hout+    release trk+    case exitCode of+        ExitSuccess -> do+            outputListLno' InfoOutput ["Done samtools sort"]+            return (NGOMappedReadSet name (File newfp) rinfo)+        ExitFailure code -> do+            release rk+            samtoolsPath <- samtoolsBin+            throwSystemError $ concat ["Failed samtools sort\n",+                            "Executable used::\t", samtoolsPath,"\n",+                            "Command line was::\n\t", unwords cmdargs, "\n",+                            "Samtools exit code was ", show code, "."]+executeSort _ _ = throwScriptError "Unexpected arguments for samtools_sort function"++sortOFormat :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+sortOFormat = return . sortOFormat'++-- If samtools_sort is called and its return value is only used in a write()+-- call which is in BAM format, then we should immediately use BAM as the+-- output format.+sortOFormat' :: [(Int, Expression)] -> [(Int, Expression)]+sortOFormat' [] = []+sortOFormat' ((lno,e):es) = (lno,e'):sortOFormat' es+    where+        e' = case e of+            Assignment v (FunctionCall fname@(FuncName "samtools_sort") expr args Nothing)+                | outputBam v es -> Assignment v (FunctionCall fname expr ((Variable "__output_bam", ConstBool True):args) Nothing)+            _ -> e+        outputBam _ [] = False+        outputBam v ((_,c):rest) = case c of+            FunctionCall (FuncName "write") (Lookup _ v') args Nothing+                | v == v' -> isOBam args && not (isVarUsed v rest)+            _+                | isVarUsed1 v c -> False+                | otherwise -> outputBam v rest+        -- The rules are+        --  1. if a format argument is present, it takes priority;+        --     else, infer from ofile argument+        --  2. In doubt, False is the safe option+        isOBam args = case oFormat args of+            Just "bam" -> True+            Just _ -> False+            Nothing -> case lookup (Variable "ofile") args of+                Nothing -> False+                Just oname -> stringWillEndWith oname ".bam" == Just True+        oFormat :: [(Variable, Expression)] -> Maybe String+        oFormat args = case lookup (Variable "format") args of+            Just (ConstSymbol "bam") -> Just "bam"+            Just _ -> Just "?"+            Nothing -> Nothing++        stringWillEndWith :: Expression -> T.Text -> Maybe Bool+        stringWillEndWith (ConstStr b) post+            | T.length b >= T.length post = Just $ T.takeEnd (T.length post) b == post+            | otherwise = Nothing+        stringWillEndWith (BinaryOp BOpAdd _ left) post = stringWillEndWith left post+        stringWillEndWith _ _ = Nothing+++checkUnique :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+checkUnique = passthrough $ \sc ->+        forM_ (headtails $ reverse sc) $ \((lno, e), rest) -> case e of+            Assignment _ (FunctionCall (FuncName "select") (Lookup _ v) kwargs Nothing)+                        | selectsUnique kwargs -> checkSorted lno v (map snd rest)+            _ -> return ()+    where+        checkSorted _ _ [] = return ()+        checkSorted lno v (r:rs) = case r of+            Assignment v' expr+                | v == v' -> case expr of+                    FunctionCall (FuncName "samtools_sort") _ _ _ ->+                            throwScriptError ("Cannot select unique reads from a sorted mappedreadset (at line " ++ show lno ++ ").\n\tConsider selecting, *then* sorting.")+                    Lookup _ v'' -> checkSorted lno v'' rs+                    _ -> return ()+            _ -> checkSorted lno v rs+        selectsUnique :: [(Variable, Expression)] -> Bool+        selectsUnique = any $ \(Variable k,v) -> k == "keep_if" && hasUnique v+        hasUnique (ConstSymbol "unique") = True+        hasUnique (ListExpression vs) = any hasUnique vs+        hasUnique _ = False++samtools_sort_function = Function+    { funcName = FuncName "samtools_sort"+    , funcArgType = Just NGLMappedReadSet+    , funcArgChecks = []+    , funcRetType = NGLMappedReadSet+    , funcKwArgs = [ArgInformation "by" False NGLSymbol [ArgCheckSymbol ["coordinate", "name"]]]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }+++executeView :: NGLessObject -> KwArgsValues -> NGLessIO NGLessObject+executeView (NGOMappedReadSet name istream rinfo) args = do+    outBam <- lookupBoolOrScriptErrorDef (return False) "samtools_view" "__output_bam" args+    bedFile <- lookupStringOrScriptError "coordinates in BED format" "bed_file" args++    let oformat = if outBam then "bam" else "sam"+        fname = case istream of+                    File f -> f+                    Stream _ f _ -> f++    (rk, (newfp, hout)) <- openNGLTempFile' fname "subset_" oformat++    numCapabilities <- liftIO getNumCapabilities+    let cmdargs = ["view", "-h", "-@", show numCapabilities, "-O", oformat, "-L", T.unpack bedFile]+    exitCode <- callSamtools istream cmdargs hout+    case exitCode of+        ExitSuccess -> do+            outputListLno' InfoOutput ["Done samtools view"]+            return (NGOMappedReadSet name (File newfp) rinfo)+        ExitFailure code -> do+            release rk+            samtoolsPath <- samtoolsBin+            throwSystemError $ concat ["Failed samtools view\n",+                            "Executable used::\t", samtoolsPath,"\n",+                            "Command line was::\n\t", unwords cmdargs, "\n",+                            "Samtools exit code was ", show code, "."]+executeView _ _ = throwScriptError "Unexpected arguments for samtools_view function"++samtools_view_function = Function+    { funcName = FuncName "samtools_view"+    , funcArgType = Just NGLMappedReadSet+    , funcArgChecks = []+    , funcRetType = NGLMappedReadSet+    , funcKwArgs = [ArgInformation "bed_file" True NGLString [ArgCheckFileReadable]]+    , funcAllowsAutoComprehension = False+    , funcChecks = []+    }++loadModule :: T.Text -> NGLessIO Module+loadModule v+    | v == "0.0" = return def+                   { modInfo = ModInfo "stdlib.samtools" "0.0"+                   , modCitations = [citation]+                   , modFunctions = [samtools_sort_function]+                   , modTransform = sortOFormat >=> checkUnique+                   , runFunction = \case+                                   "samtools_sort" -> executeSort+                                   other -> \_ _ -> throwShouldNotOccur ("samtools runction called with wrong arguments: " ++ show other)+                   }+    | v `elem` ["1.0", "0.1"] = return def+                   { modInfo = ModInfo "stdlib.samtools" "1.0"+                   , modCitations = [citation]+                   , modFunctions = [samtools_sort_function, samtools_view_function]+                   , modTransform = sortOFormat >=> checkUnique+                   , runFunction = \case+                                   "samtools_sort" -> executeSort+                                   "samtools_view" -> executeView+                                   other -> \_ _ -> throwShouldNotOccur ("samtools runction called with wrong arguments: " ++ show other)+                                   }+    | otherwise = throwScriptError ("samtools module version " ++ T.unpack v ++ " doesn't exist")+    where+        citation = T.concat+            ["'The Sequence Alignment/Map format and SAMtools' "+            ,"by Heng Li, Bob Handsaker, Alec Wysoker, Tim Fennell, Jue Ruan, Nils Homer, Gabor Marth, Goncalo Abecasis, Richard Durbin, and 1000 Genome Project Data Processing Subgroup "+            ,"in Bioinformatics (2009) 25 (16): 2078-2079 (2009) DOI:10.1093/bioinformatics/btp352"]
+ NGLess/StandardModules/Soap.hs view
@@ -0,0 +1,31 @@+{- Copyright 2016 NGLess Authors+ - License: MIT+ -}++module StandardModules.Soap+    ( loadModule+    ) where++import qualified Data.Text as T+import Data.Default++import NGLess+import Modules+import NGLess.NGLEnvironment++loadModule :: T.Text -> NGLessIO Module+loadModule _ = do+    -- TODO: Add check for SOAP binaries in PATH+    updateNglEnvironment addSoap+    return def+        { modInfo = ModInfo "stdlib.soap" "1.0"+        , modCitations = [citation]+        , modFunctions = []+        , runFunction = \_ _ _ -> throwShouldNotOccur "soap has no functions!"+        }+    where+        addSoap e@NGLEnvironment { ngleMappersActive = p } = e { ngleMappersActive = "soap":p }+        citation = T.concat+                    ["Li, Ruiqiang, Yingrui Li, Karsten Kristiansen, and Jun Wang. \n"+                    ,"\"SOAP: short oligonucleotide alignment program.\"\n"+                    ,"Bioinformatics 24, no. 5 (2008): 713-714."]
+ NGLess/Tokens.hs view
@@ -0,0 +1,159 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts, CPP #-}++-- | This module handles tokenization+module Tokens+    ( Token(..)+    , tokenize+#ifdef IS_BUILDING_TEST+    , eol+#endif+    ) where++import qualified Data.Text as T+import Control.Monad (void)+import Text.Parsec.Text ()+import Text.Parsec.Combinator+import Data.Functor (($>))+import Text.Parsec++import NGLess.NGError+import Language++-- | Token datatype+data Token =+        TExpr Expression -- ^ These are Const* type of expressions+        | TBop BOp -- ^ Binary operators+        | TReserved T.Text -- ^ Reserved keywords+        | TConstant T.Text -- ^ Builtin constant+        | TWord T.Text -- ^ Any other word (function name, variable, &c)+        | TOperator Char -- ^ A single character operator (',', '[', ...)+        | TNewLine -- ^ A new line+        | TIndent Int -- ^ A sequence of spaces+    deriving (Eq, Show)++-- | tokenize is the main function of this module+-- It returns tokens with position information (the position in the original+-- file)+tokenize :: String -- ^ input filename (for error messages)+        -> T.Text -- ^ input text+        -> NGLess [(SourcePos,Token)]+tokenize inname input = case parse tokenizer inname input of+        Right val -> return val+        Left err -> throwScriptError $ show err++tokenizer = many ngltoken' <* eof+ngltoken' = (,) <$> getPosition <*> ngltoken++-- | 'ngltoken' parse a token as a series of possibilities.+-- All of these are written so that they never fail after consuming input+ngltoken = comment+        <|> symbol+        <|> tstring+        <|> double+        <|> integer+        <|> word+        <|> boperator+        <|> operator+        <|> indent+        <|> taberror+        <|> eol++eol = semicolon <|> real_eol+    where+        real_eol = ((char '\r' *> char '\n') <|> char '\n') $> TNewLine+        semicolon = char ';' *> skipMany (char ' ') $> TNewLine++try_string s = try (string s)++symbol = char '{'  *>+                (TExpr . ConstSymbol . T.pack <$> many1 (char '_' <|> alphaNum))+                <* (option () $ char '-' *> parserFail "Symbols cannot contain hyphens (-), perhaps you meant to use an underscore.")+                <* char '}'++tstring = tstring' '\'' <|> tstring' '"'+    where tstring' term = char term *> (TExpr . ConstStr <$> strtext term) <* char term+strtext term = T.pack <$> many (escapedchar <|> noneOf [term])+    where+        escapedchar = char '\\' *> escapedchar'+        escapedchar' = do+            c <- anyChar+            case c of+                'n' -> return '\n'+                't' -> return '\t'+                '\\' -> return '\\'+                _ -> return c+comment = singlelinecomment <|> multilinecomment+singlelinecomment = commentstart *> skiptoeol+    where commentstart = (void $ char '#') <|> (void . try $ string "//")+skiptoeol = eol  <|> (anyChar *> skiptoeol)+multilinecomment = try_string "/*" *> skipmultilinecomment+skipmultilinecomment = (try_string "*/" $> TIndent 0)+            <|> (anyChar *> skipmultilinecomment)+            <|> (eof *> fail "Unexpected End Of File inside a comment")++word = try $ do+    k <- variableStr+    let k' = pure (T.pack k)+    case k of+        "true" -> pure (TExpr $ ConstBool True)+        "True" -> pure (TExpr $ ConstBool True)+        "false" -> pure (TExpr $ ConstBool False)+        "False" -> pure (TExpr $ ConstBool False)+        _+            | k `elem` reservedwords -> TReserved <$> k'+            | k `elem` constants -> TExpr . BuiltinConstant . Variable <$> k'+            | otherwise -> TWord <$> k'++reservedwords =+        ["if"+        ,"else"+        ,"ngless"+        ,"len"+        ,"discard"+        ,"continue"+        ,"not"+        ,"local"+        ,"import"+        ,"using"+        ]++constants =+        ["STDIN"+        ,"STDOUT"+        ]++variableStr = (:) <$> (char '_' <|> letter) <*> many (char '_' <|> alphaNum)+operator = TOperator <$> oneOf "=,+-*():[]<>.|"+boperator =+        -- Check for a not-so-unreasonable user mistake+        (try_string "<\\>" *> fail "<\\> found. Did you mean </>?")+        <|> choice [+                (try_string long $> TBop short)+                    | (long,short) <-+                    [ ("!=", BOpNEQ)+                    , ("==", BOpEQ)++                    , ("</>", BOpPathAppend)++                    , ("<=", BOpLTE)+                    , ("<", BOpLT)+                    , (">=", BOpGTE)+                    , (">", BOpGT)++                    , ("+", BOpAdd)+                    , ("*", BOpMul)+                    ]]+indent = TIndent . length <$> many1 (char ' ')+taberror = tab *> fail "Tabs are not used in NGLess. Please use spaces."++double = TExpr . ConstDouble . read <$> try double'+    where+        double' = (\int frac -> (int ++ "." ++ frac)) <$> many1 digit <*> (char '.' *> many1 digit)++integer = TExpr . ConstInt <$> (try hex <|> dec)+    where+        hex = read . ("0x"++) <$> (string "0x" *> many1 hexDigit)+        dec = read <$> many1 digit
+ NGLess/Transform.hs view
@@ -0,0 +1,644 @@+{- Copyright 2016-2022 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts #-}++module Transform+    ( transform+    , pureTransform+    , isVarUsed+    , isVarUsed1+    ) where++import qualified Data.Text as T+import Control.Monad.Trans.Cont+import Control.Monad.Except+import Control.Monad.Writer+import Control.Monad.RWS+import Control.Arrow (first, second)+import Control.Monad.Identity (Identity(..), runIdentity)+import Control.Monad.State.Lazy+import Control.Monad.Extra (whenJust)+import Data.Maybe+import qualified Data.Hash.MD5 as MD5+import qualified Data.Map.Strict as M+import           Data.List (sortOn)++import Language+import Modules+import Output (outputListLno', OutputType(..))+import NGLess+import Utils.Utils (uniq, secondM)+import NGLess.NGLEnvironment+import BuiltinFunctions (findFunction)+++{-| NOTE+ -+ - Before interpretation, scripts are transformed to allow for several+ - optimizations.+ -+ - INITIAL NORMALIZATION+ -+ - As a first step, the script is normalized, introducing temporary variables+ - so that function calls do not contain nested expressions.  For example:+ -+ -     write(mapstats(samfile('input.sam')), ofile='stats.txt')+ -+ - is re-written to the equivalent of:+ -+ -     temp$0 = samfile('input.sam')+ -     temp$1 = mapstats(temp$0)+ -     write(temp$1, ofile='stats.txt')+ -+ - Note that "temp$xx" are not valid ngless variable names. Thus, these+ - temporary variables can only be introduced internally and will never clash+ - with any user variables. All subsequent transformations can assume that the+ - scripts have been normalized.+ -+ -}+transform :: [Module] -> Script -> NGLessIO Script+transform mods sc = Script (nglHeader sc) <$> applyM transforms (nglBody sc)+    where+        applyM [] e = return e+        applyM (t:ts) e = t e >>= applyM ts+        transforms = preTransforms ++ modTransforms ++ builtinTransforms+        modTransforms = map modTransform mods+        preTransforms =+                [ reassignPreprocess+                , addTemporaries+                , addOutputHash -- Hashing should be based on what the user input (pre-transforms)+                , checkSimple+                ]+        builtinTransforms =+                [ writeToMove+                , qcInPreprocess+                , ifLenDiscardSpecial+                , substrimReassign+                , addFileChecks+                , addIndexChecks+                , addUseNewer+                , addCountsCheck+                ]++{-| The condition is "one single function call per top level expression"+ -}+checkSimple :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+checkSimple expr = forM_ expr (checkSimple1 . snd) *> return expr+    where+        checkSimple0 = \case+            Condition{} -> throwShouldNotOccur "Non-simple expression (Condition)"+            Assignment{} -> throwShouldNotOccur "Non-simple expression (Assignment)"+            FunctionCall{} -> throwShouldNotOccur "Non-simple expression (FunctionCall)"+            -- Rewriting for MethodCall is not implemented!+            MethodCall{} -> return () -- throwShouldNotOccur "Non-simple expression (MethodCall)"++            ListExpression s -> mapM_ checkSimple0 s+            UnaryOp _ a -> checkSimple0 a+            BinaryOp _ a b -> checkSimple0 a *> checkSimple0 b+            IndexExpression e ix -> checkSimple0 e *> checkSimpleIndex ix+            Sequence s -> mapM_ checkSimple0 s++            Lookup{} -> return ()+            ConstStr{} -> return ()+            ConstInt{} -> return ()+            ConstDouble{} -> return ()+            ConstBool{} -> return ()+            ConstSymbol{} -> return ()+            BuiltinConstant{} -> return ()+            Continue -> return ()+            Discard -> return ()+            Optimized{} -> return ()++        checkSimpleIndex (IndexOne e) = checkSimple0 e+        checkSimpleIndex (IndexTwo a b) =  whenJust a checkSimple0 *> whenJust b checkSimple0++        checkSimple1 = \case+            Condition ifC ifT ifF ->+                checkSimple0 ifC *>+                checkSimple1 ifT *>+                checkSimple1 ifF+            Assignment _ e  -> checkSimple1 e+            FunctionCall _ _ _ Just{} -> return () -- NOT IMPLEMENTED, BUT SHOULD BE!+            FunctionCall _ e kwargs Nothing ->+                checkSimple0 e *>+                forM_ kwargs (checkSimple0 . snd)+                -- whenJust block (checkSimple1 . blockBody)+            MethodCall _ e arg kwargs ->+                checkSimple0 e *>+                whenJust arg checkSimple0 *>+                forM_ kwargs (checkSimple0 . snd)+            Sequence s -> mapM_ checkSimple1 s+            ListExpression s -> mapM_ checkSimple0 s+            UnaryOp _ a -> checkSimple0 a+            BinaryOp _ a b -> checkSimple0 a *> checkSimple0 b+            e -> checkSimple0 e+++asSequence :: [Expression] -> Expression+asSequence [e] = e+asSequence es = Sequence es++pureRecursiveTransform :: (Expression -> Expression) -> Expression -> Expression+pureRecursiveTransform f e = runIdentity (recursiveTransform (return . f) e)++-- | A little helper function which turns a lifts a pure transform `Expression+-- -> Expression` into the generic `[(Int, Expression)] -> NGLessIO [(Int, Expression)]`+pureTransform :: (Expression -> Expression) -> [(Int,Expression)] -> NGLessIO [(Int, Expression)]+pureTransform f = return . map (second (pureRecursiveTransform f))++-- | Add an argument to a function call iff the expression includes that function call+addArgument :: T.Text -- ^ function name+            -> (Variable, Expression) -- ^ new argument+            -> Expression -- ^ expression to transform+            -> Expression -- ^ transformed expression+addArgument func newArg expr = case expr of+    Assignment v e -> Assignment v (addArgument func newArg e)+    FunctionCall fname@(FuncName fname') e args b+        | fname' == func ->+            FunctionCall fname e (newArg:args) b+    _ -> expr++-- | Checks if a variable is used in any of the given expressions+--+-- See 'isVarUsed1'+isVarUsed :: Variable -> [(Int, Expression)] -> Bool+isVarUsed v = any (isVarUsed1 v . snd)+++-- | Checks if a variable is used in a single 'Expression'+--+-- See 'isVarUsed'+isVarUsed1 :: Variable -> Expression -> Bool+isVarUsed1 v expr = evalCont $ callCC $ \exit -> do+                recursiveAnalyse (isVarUsed1' exit) expr+                return False+    where+        isVarUsed1' :: (Bool -> Cont Bool ()) -> Expression -> Cont Bool ()+        isVarUsed1' exit (Assignment v' _)+            | v == v' = exit True+        isVarUsed1' exit (Lookup _ v')+            | v == v' = exit True+        isVarUsed1' _ _ = return ()++{- If a variable is not used after a call to write(), we can destroy it.+    This is implemented by adding the argument __can_move=True to+    write() calls -}+writeToMove :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+writeToMove = return . writeToMove' []+writeToMove' _ [] = []+writeToMove' blocked ((lno,expr):rest) = (lno, addMove toRemove expr):writeToMove' blocked' rest+    where+        toRemove = filter (`notElem` blocked) unused+        unused = filter (not . flip isVarUsed rest) $ functionVars "write" expr+        blocked' = blockhere ++ blocked+        blockhere = case expr of+                      Assignment var (FunctionCall (FuncName fname) _ _ _)+                        | fname `elem` ["fastq", "paired", "samfile"] -> [var]+                      Assignment var (Lookup _ prev)+                        | prev `elem` blocked -> [var]+                      _ -> []+        addMove :: [Variable] -> Expression -> Expression+        addMove dead = pureRecursiveTransform addMove'+            where+                addMove' (FunctionCall f@(FuncName "write") e@(Lookup _ v) args b)+                    | v `elem` dead = FunctionCall f e ((Variable "__can_move", ConstBool True):args) b+                addMove' e = e++-- | Variables used in calling the function func+functionVars :: T.Text -- ^ function name+                -> Expression -- expression to analyse+                -> [Variable]+functionVars fname expr = execWriter (recursiveAnalyse fvars expr)+    where+        fvars :: Expression -> Writer [Variable] ()+        fvars (FunctionCall (FuncName fname') (Lookup _ v) _ _)+            | fname' == fname = tell [v]+        fvars _ = return ()++qcInPreprocess :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+qcInPreprocess [] = return []+qcInPreprocess ((lno,expr):rest) = case fastQVar expr of+        Nothing -> ((lno,expr):) <$> qcInPreprocess rest+        Just (fname, v) -> if not $ canQCPreprocessTransform v rest+                    then ((lno,expr):) <$> qcInPreprocess rest+                    else do+                        let expr' = addArgument fname (Variable "__perform_qc", ConstBool False) expr+                            rest' = rewritePreprocess v rest+                        outputListLno' TraceOutput ["Transformation for QC triggered for variable ", show v, " on line ", show lno, "."]+                        ((lno, expr'):) <$> qcInPreprocess rest'++rewritePreprocess _ [] = [] -- this should never happen+rewritePreprocess v ((lno,expr):rest) = case expr of+    Assignment t (FunctionCall f@(FuncName "preprocess") e@(Lookup _ v') args b)+        | v == v' ->+                let expr' = FunctionCall f e ((Variable "__input_qc", ConstBool True):args) b+                    in (lno,Assignment t expr'):rest+    _ -> (lno,expr):rewritePreprocess v rest++fastQVar :: Expression -> Maybe (T.Text, Variable)+fastQVar (Assignment v (FunctionCall (FuncName fname) _ _ _))+        | fname `elem` ["fastq", "paired", "load_fastq_directory", "load_mocat_sample"] = Just (fname, v)+fastQVar _ = Nothing++-- The rule is: we can perform the transform if the first usage of the Variable+-- 'v' is in a preproces call. Otherwise, it is not guaranteed to be safe+canQCPreprocessTransform :: Variable -> [(Int, Expression)] -> Bool+canQCPreprocessTransform _ [] = False+canQCPreprocessTransform v ((_,Assignment _ (FunctionCall (FuncName "preprocess") (Lookup _ v') _ _)):_)+    | v' == v = True+canQCPreprocessTransform v ((_, expr):rest)+    | isVarUsed1 v expr = False+    | otherwise = canQCPreprocessTransform v rest+++-- | 'ifLenDiscardSpecial' special cases a common case inside preprocess+-- blocks, namely:+--+-- if len(read) < #:+--     discard+--+-- gets rewritten to+--+-- Optimized (LenThresholdDiscard read < #)+--+ifLenDiscardSpecial :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+ifLenDiscardSpecial = pureTransform $ \case+        (Condition (BinaryOp b (UnaryOp UOpLen (Lookup _ v)) (ConstInt thresh))+                                    (Sequence [Discard])+                                    (Sequence []))+            | b `elem` [BOpLT, BOpLTE, BOpGT, BOpGTE] -> Optimized (LenThresholdDiscard v b (fromInteger thresh))+        e -> e++substrimReassign :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+substrimReassign = pureTransform $ \case+        (Assignment v (FunctionCall (FuncName "substrim") (Lookup _ v') [(Variable "min_quality", ConstInt mq)] Nothing))+            | v == v' -> Optimized (SubstrimReassign v (fromInteger mq))+        e -> e+++-- | 'addFileChecks' implements the following transformation+--+-- variable = <non constant expression>+--+-- <code>+--+-- write(input, ofile="output/"+variable+".sam")+--+-- into+--+-- variable = <non constant expression>+-- __check_ofile("output/"+variable+".sam")+--+-- <code>+--+-- write(input, ofile="output/"+variable+".sam")+addFileChecks :: [(Int,Expression)] -> NGLessIO [(Int, Expression)]+addFileChecks sc = reverse <$> (checkIFiles (reverse sc) >>= checkOFiles)+    -- convert to genericCheckUpfloat+    where+        -- This could be combined into a single pass+        -- For script preprocessing, we generally disregard performance, however+        checkIFiles = addFileChecks' "__check_ifile" ArgCheckFileReadable+        checkOFiles = addFileChecks' "__check_ofile" ArgCheckFileWritable++addFileChecks' :: T.Text -> ArgCheck -> [(Int,Expression)] -> NGLessIO [(Int, Expression)]+addFileChecks' _ _ [] = return []+addFileChecks' checkFname tag ((lno,e):rest) = do+        mods <- ngleLoadedModules <$> nglEnvironment+        vars <- runNGLess $ execWriterT (recursiveAnalyse (getFileExpressions mods) e)+        rest' <- addFileChecks' checkFname tag (addCheck vars (maybeAddChecks vars rest))+        return ((lno,e):rest')++     where+        addCheck [(_, oexpr)] = ((lno, checkFileExpression oexpr):)+        addCheck _ = id++        maybeAddChecks :: [(Variable,Expression)] -> [(Int, Expression)] -> [(Int, Expression)]+        maybeAddChecks _ [] = []+        maybeAddChecks vars@[(v,complete)] ((lno',e'):rest') = case e' of+            Assignment v' _+                | v' == v -> (lno', checkFileExpression complete) : (lno', e') : rest'+            _ -> (lno',e') : maybeAddChecks vars rest'+        maybeAddChecks _ rest' = rest'++        checkFileExpression complete = FunctionCall+                            (FuncName checkFname)+                            complete+                            [(Variable "original_lno", ConstInt (toInteger lno))]+                            Nothing++        -- returns the variables used and expressions that depend on them+        getFileExpressions :: [Module] -> Expression -> (WriterT [(Variable,Expression)] NGLess) ()+        getFileExpressions mods (FunctionCall f expr args _) = case findFunction mods f of+            Just finfo -> do+                when (tag `elem` funcArgChecks finfo) $+                    extractExpressions (Just expr)+                forM_ (funcKwArgs finfo) $ \ainfo ->+                    when (tag `elem` argChecks ainfo) $+                        extractExpressions (lookup (Variable $ argName ainfo) args)+            Nothing -> throwShouldNotOccur ("Transform.getFileExpressions: Unknown function: '" ++ show f ++ "'. This should have been caught before")+        getFileExpressions _ _ = return ()++        extractExpressions :: (MonadWriter [(Variable, Expression)] m) =>  Maybe Expression -> m ()+        extractExpressions (Just ofile) = case ofile of+            BinaryOp _ re le -> case uniq (validVariables re ++ validVariables le) of+                [v] -> tell [(v, ofile)]+                _ -> return ()+            Lookup _ v -> tell [(v, ofile)]+            _ -> return ()+        extractExpressions Nothing = return ()++        validVariables (Lookup _ v) = [v]+        validVariables (BinaryOp _ re le) = validVariables re ++ validVariables le+        validVariables (ConstStr _) = []+        validVariables _ = [Variable "this", Variable "wont", Variable "work"] -- this causes the caller to bailout++-- | 'addIndexChecks' implements the following transformation+--+-- array = <non constant expression>+--+-- <code>+--+--   array[ix]+--+-- into+--+-- array = <non constant expression>+-- __check_index_access(array, index1=ix,...)+--+-- <code>+--+-- write(input, ofile="output/"+variable+".sam")+addIndexChecks :: [(Int,Expression)] -> NGLessIO [(Int, Expression)]+addIndexChecks = return . genericCheckUpfloat addIndexChecks'+addIndexChecks' :: (Int, Expression) -> Maybe ([Variable],Expression)+addIndexChecks' (lno, e) =+        case execWriter (recursiveAnalyse extractIndexOne e) of+            [] -> Nothing+            vars -> Just (map fst vars, asSequence $ map (uncurry indexCheckExpr) vars)++     where+        extractIndexOne :: Expression -> Writer [(Variable, Expression)] ()+        extractIndexOne (IndexExpression (Lookup _ v) (IndexOne ix1@ConstInt{})) = tell [(v, ix1)]+        extractIndexOne _ = return ()++        indexCheckExpr :: Variable -> Expression -> Expression+        indexCheckExpr arr ix1 = FunctionCall+                            (FuncName "__check_index_access")+                            (Lookup Nothing arr)+                            [(Variable "original_lno", ConstInt (toInteger lno))+                            ,(Variable "index1", ix1)]+                            Nothing++-- Many checks can be generalize so that certain expressions generate a+-- corresponding __check() function call. For example, bounds checks, transform+--+--      print(list[2])+--+-- into+--+--      __check_index_access(list, index1=2)+--      print(list[2])+--+--+-- More interesting, these can be "bubbled up" so that __check_index_access+-- moves up (floats up):+--+--      list = [1,2,3]+--      <code>+--      print(list[2])+--+-- transforms into+--+--      list = [1,2,3]+--      __check_index_access(list, index1=2)+--      <code>+--      print(list[2])+--+-- 'genericCheckUpfloat' generalizes this pattern++genericCheckUpfloat :: ((Int, Expression) -> Maybe ([Variable],Expression))+                        -> [(Int, Expression)]+                        -> [(Int, Expression)]+                                -- this is easier to do on the reversed script+genericCheckUpfloat f exprs = reverse $ genericCheckUpfloat' f (reverse exprs)+genericCheckUpfloat' :: ((Int, Expression) -> Maybe ([Variable],Expression))+                        -> [(Int, Expression)]+                        -> [(Int, Expression)]+genericCheckUpfloat' _ [] = []+genericCheckUpfloat' f (c@(lno, expr):rest) = case expr of+                    -- expand sequences+    Sequence es -> genericCheckUpfloat' f (reverse [(lno,e) | e <- es] ++ rest)+    -- Conditions are tricky. At some point, NGLess would erroneuously float+    -- checks above the Condition, so that+    --+    -- list = [1]+    --+    -- if len(list) > 1:+    --    print(list[1])+    --+    -- would trigger an error. Now, checks only float up within the block+    Condition eC eT eF -> let+        eT' = genericCheckUpfloat f [(lno, eT)]+        eF' = genericCheckUpfloat f [(lno, eF)]+        rest' = case f (lno,eC) of+                Nothing -> rest+                Just (vars, ne) -> floatDown vars (lno, ne) rest+        untag tagged = asSequence (snd <$> tagged)+        in+            ((lno, Condition eC (untag eT') (untag eF')):rest')++    _ -> let+        rest' = case recursiveCall f c of+                Nothing -> rest+                Just (vars, ne) -> floatDown vars (lno,ne) rest+        in (c:genericCheckUpfloat' f rest')++recursiveCall :: ((Int, Expression) -> Maybe a) -> (Int, Expression) -> Maybe a+recursiveCall f (lno, e) = evalCont $ callCC $ \exit -> do+    flip recursiveAnalyse e (\sub -> case f (lno, sub) of+                                        Nothing -> return ()+                                        j -> exit j)+    return Nothing++floatDown :: [Variable] -> (Int, Expression) -> [(Int, Expression)] -> [(Int, Expression)]+floatDown _ e [] = [e]+floatDown vars e (c:rest)+    | any (`isVarUsed1` snd c) vars = e : c : rest+    | otherwise = c : floatDown vars e rest++-- | Implements addition of temp$nn variables to simplify expressions+--+-- This allows the rest of the code to be simpler. Namely, there are no complex expressions.+addTemporaries = addTemporaries' 0+    where+        addTemporaries' :: Int -> [(Int,Expression)] -> NGLessIO [(Int,Expression)]+        addTemporaries' _ [] = return []+        addTemporaries' next ((lno,e):rest) = do+                mods <- ngleLoadedModules <$> nglEnvironment+                let (next', es) = addTemporaries1 mods next e+                rest' <- addTemporaries' next' rest+                let lno_e' = (lno,) <$> es+                return $ lno_e' ++ rest'++        addTemporaries1 :: [Module] -> Int -> Expression -> (Int, [Expression])+        addTemporaries1 _ next e@(FunctionCall _ _ _ (Just _)) = (next, [e])+        addTemporaries1 _ next e@(Assignment _ (FunctionCall _ _ _ (Just _))) = (next, [e])+        addTemporaries1 mods next (Condition ifC ifT ifF) = let+                (next1, ifC') = addTemporaries1 mods next ifC+                (next2, ifT') = addTemporaries1 mods next1 ifT+                (next3, ifF') = addTemporaries1 mods next2 ifF+            in (next3, init ifC' ++ [Condition (last ifC') (asSequence ifT') (asSequence ifF')])+        addTemporaries1 mods next expr = let (e', next', pre) = runRWS (recursiveTransform functionCallTemp expr) () next in+                                                    (next', combineExpr pre e')+            where+                isAssignTo v (Assignment v' _) = v == v'+                isAssignTo _ _ = False++                findDrop :: [a] -> (a -> Bool) -> Maybe ([a], a)+                findDrop [] _ = Nothing+                findDrop (x:xs) f+                    | f x = Just (xs, x)+                    | otherwise = first (x:) <$> findDrop xs f++                combineExpr :: [Expression] -> Expression -> [Expression]+                combineExpr pre (Lookup _ v) = case findDrop pre (isAssignTo v) of+                    Just (pre', Assignment _ e') -> combineExpr pre' e'+                    _ -> error "This is impossible"+                combineExpr pre (Assignment v' (Lookup _ vt@(Variable t)))+                    | T.isPrefixOf "temp$" t = case findDrop pre (isAssignTo vt) of+                        Just (pre', Assignment _ e) -> pre' ++ [Assignment v' e]+                        _ -> error "Impossible [combineExpr2]"+                combineExpr pre e' = pre ++ [e']++                functionCallTemp :: Expression -> RWS () [Expression] Int Expression+                functionCallTemp e@(FunctionCall f _ _ _) = do+                    let t = funcRetType <$> findFunction mods f+                    if t == Just NGLVoid+                        then return e+                        else do+                            n <- get+                            let v = Variable (T.pack $ "temp$"++show n)+                            put (n + 1)+                            tell [Assignment v e]+                            return (Lookup t v)+                {- The code below seemed like a good idea, but breaks the early+                 - error checking (as it relies on a very simplistic way of+                 - "bubbling up" the error checking code:+                 -+                functionCallTemp e@BinaryOp{} = do+                            n <- get+                            let v = Variable (T.pack $ "temp$"++show n)+                            put (n + 1)+                            tell [Assignment v e]+                            return (Lookup Nothing v)+                -}+                functionCallTemp e = return e++{-| Calculation of hashes for output method calls+ so that the hash depends only on the relevant (influencing the result) part of+ the script.++ Hashes for variables are stored in a map (as a state).  For each expression+ (top to bottom) first the block variables are added to the map (if present),+ then hashes are calculated and applied (in lookups) recursively.+ Each output call receives new variable __hash storing the hash of its own nput+ expression (with hashes already applied inside).+-}++addOutputHash :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+addOutputHash expr_lst = do+        nv <- ngleVersion <$> nglEnvironment+        modules <- ngleLoadedModules <$> nglEnvironment+        let modInfos = map modInfo modules+            state0 = M.insert (Variable "ARGV") (T.pack "ARGV") M.empty+            versionString = show nv ++ show (sortOn modName modInfos)+        return $! evalState (mapM (secondM $ addOutputHash' versionString) expr_lst) state0+    where+        addOutputHash' :: String -> Expression -> State (M.Map Variable T.Text) Expression+        addOutputHash' versionString expr = flip recursiveTransform expr $ \e -> case e of+                        Assignment v val -> do+                            h <- hashOf val+                            modify (M.insert v h)+                            return e+                        FunctionCall f@(FuncName fname) oarg kwargs block+                            | fname `elem` ["collect", "write"] -> do+                                h <- hashOf oarg+                                return (FunctionCall f oarg ((Variable "__hash", ConstStr h):kwargs) block)+                        _ -> return e+            where+                injectBlockVars :: Maybe Block -> M.Map Variable T.Text -> M.Map Variable T.Text+                injectBlockVars Nothing m = m+                injectBlockVars (Just (Block v@(Variable n) _)) m = M.insert v n m+                hashOf :: Expression -> State (M.Map Variable T.Text) T.Text+                hashOf e@(FunctionCall _ _ _ block) = withState (injectBlockVars block) $ hashOf' e+                hashOf e  = hashOf' e++                hashOf' ex = do+                    expr' <- flip recursiveTransform ex $ \case+                        Lookup t v@(Variable n) -> do+                            h <- fromMaybe n <$> gets (M.lookup v)+                            return $! Lookup t (Variable h)+                        e -> return e+                    return . T.pack . MD5.md5s . MD5.Str . (versionString ++) . show $ expr'++-- In ngless 0.0, preprocess() would change its arguments, so that+--+--  preprocess(input) ...+--+-- was equivalent to+--+-- input = preprocess(input) ...+reassignPreprocess :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+reassignPreprocess sc = do+    v <- ngleVersion <$> nglEnvironment+    return $! case v of+        NGLVersion 0 0 -> map (second reassignPreprocess') sc+        _ -> sc+reassignPreprocess' :: Expression -> Expression+reassignPreprocess' e@(FunctionCall (FuncName "preprocess") (Lookup _ v) _ _) = Assignment v e+reassignPreprocess' e = e+++-- | addUseNewer+-- +-- Implements the following transformation:+--+-- mapped = select(mapped) using |mr|:+--      mr = mr.filter(...)+--+--+-- mapped = select(mapped) using |mr|:+--      mr = mr.filter(..., __version11_or_higher=True)+--+--+-- if the ngless declaration asks for "ngless 1.1" or higher+addUseNewer :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+addUseNewer exprs = do+    v <- ngleVersion <$> nglEnvironment+    if v >= NGLVersion 1 1+        then do+            return exprs+        else do+            let addUseNewer' e = flip recursiveTransform e $ \case+                    (MethodCall mname@(MethodName mname') arg0 arg1 kwargs)+                        | mname' `elem` ["filter", "allbest"] -> do+                            outputListLno' WarningOutput ["The filter() and allbest() methods have changed behaviour in NGLess 1.1. Now using old behaviour for compatibility, but, if possible, upgrade your version statement. This refers to how a corner case in computing match sizes/identities is handled and will have no practical impacts on almost all datasets."]+                            return (MethodCall mname arg0 arg1 ((Variable "__version11_or_higher", ConstBool True):kwargs))+                    e' -> return e'+            mapM (secondM addUseNewer') exprs+++addCountsCheck :: [(Int, Expression)] -> NGLessIO [(Int, Expression)]+addCountsCheck = return . genericCheckUpfloat countCheck+    where+        countCheck (lno, FunctionCall (FuncName "count") _ kwargs Nothing) = Just (extractVars kwargs, buildCheck lno kwargs)+        countCheck _ = Nothing+        buildCheck lno kwargs =+            FunctionCall+                (FuncName "__check_count")+                (BuiltinConstant (Variable "__VOID"))+                ((Variable "original_lno", ConstInt (toInteger lno)):kwargs)+                Nothing+        extractVars kwargs = concat (usedVariables . snd <$> kwargs)
+ NGLess/Types.hs view
@@ -0,0 +1,398 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts #-}+module Types+    ( checktypes+    ) where++{-| # Type Checking+ -+ - This module performs type inferrence and checking.+ -}++import qualified Data.Text as T+import qualified Data.Map as Map+import           Control.Arrow+import Data.Maybe+import Control.Monad+import Control.Monad.State.Strict+import Control.Monad.Trans.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Applicative+import           Data.String (fromString)+import           Data.List (find, foldl')+import           Data.Functor (($>))++import Modules+import Language+import NGLess.NGError+import BuiltinFunctions+import Utils.Suggestion+import Utils.Utils++type TypeMap = Map.Map T.Text NGLType+type TypeMSt = StateT (Int, TypeMap)        -- ^ Current line & current type map (type map is inferred top-to-bottom)+                (ExceptT NGError            -- ^ to enable early exit for certain types of error+                    (ReaderT [Module]       -- ^ the modules passed in (fixed)+                        (Writer [T.Text]))) -- ^ we write out error messages++--+-- | checktypes attempts to add types to all the Lookup Expression objects+checktypes :: [Module] -> Script -> NGLess Script+checktypes mods script@(Script _ exprs) = let+            initial = foldl' addmod Map.empty mods+            addmod :: TypeMap -> Module -> TypeMap+            addmod tm m = foldl' addconst tm (modConstants m)+            addconst tm (name, val) = case typeOfObject val of+                Just t -> Map.insert name t tm+                Nothing -> tm+            w = runExceptT (runStateT (inferScriptM exprs) (0,initial))+    in case runWriter (runReaderT w mods) of+        (Right (_,(_, tmap)), []) -> do+            typed <- addTypes tmap exprs+            return $ script { nglBody = typed }+        (Left err, []) -> Left err+        (_, errs) -> throwScriptError . T.unpack . T.unlines $ errs++-- | error in line concat+errorInLineC :: [String] -> TypeMSt ()+errorInLineC = errorInLine . T.concat . map fromString++errorInLine :: T.Text -> TypeMSt ()+errorInLine e = do+    (line,_) <- get+    tell [T.concat ["Error in type-checking (line ", T.pack (show line), "): ", e]]++-- | There are two types of errors: errors which can potentially be recovered+-- from (mostly by pretending that the type was what was expected and+-- continuing): these get accumulated until the end of parsing. Some errors,+-- however, trigger an immediate abort by calling 'cannotContinue'+cannotContinue :: TypeMSt a+cannotContinue = tell ["Cannot continue typechecking."] >> throwScriptError "Error in type checking"+++inferScriptM :: [(Int,Expression)] -> TypeMSt ()+inferScriptM [] = return ()+inferScriptM ((lno,e):es) = modify (first (const lno)) >> inferM e >> inferScriptM es++inferM :: Expression -> TypeMSt ()+inferM (Sequence es) = inferM `mapM_` es+inferM (Assignment (Variable v) expr) = do+    ltype <- envLookup Nothing v+    mrtype <- nglTypeOf expr+    check_assignment ltype mrtype+    case mrtype of+        Nothing -> errorInLine "Cannot infer type for right-hand of assignment"+        Just rtype -> envInsert v rtype+inferM (Condition c te fe) = checkBool c *> inferM te *> inferM fe+inferM e = void (nglTypeOf e)++inferBlock :: FuncName -> Maybe Block -> TypeMSt ()+inferBlock _ Nothing = return ()+inferBlock (FuncName f) (Just (Block (Variable v) es)) = case f of+        "preprocess" -> inferBlock' NGLRead+        "select" -> inferBlock' NGLMappedRead+        _ -> do+            errorInLineC ["Function '", T.unpack f, "' does not accept blocks"]+            void cannotContinue+    where+        inferBlock' btype = do+            envInsert v btype+            inferM es++envLookup :: Maybe NGLType -> T.Text -> TypeMSt (Maybe NGLType)+envLookup Nothing v = envLookup' v+envLookup mt@(Just t) v = envLookup' v >>= \case+        Nothing -> return mt+        Just t'+            | t == t' -> return mt+            | otherwise -> do+                errorInLineC ["Incompatible types detected for variable '"+                                , T.unpack v, "': previously assigned to type "+                                , show t, ", now being detected as ", show t']+                return mt+envLookup' v = liftM2 (<|>)+                    (constantLookup v)+                    (Map.lookup v . snd <$> get)++constantLookup :: T.Text -> TypeMSt (Maybe NGLType)+constantLookup v = do+    moduleBuiltins <- asks (concatMap modConstants)+    case filter ((==v) . fst) moduleBuiltins of+        [] -> return Nothing+        [(_,r)] -> return $ typeOfObject r+        _ -> do+            errorInLineC ["Multiple matches for constant: ", T.unpack v]+            cannotContinue++envInsert :: T.Text -> NGLType -> TypeMSt ()+envInsert v t = modify $ second (Map.insert v t)++check_assignment :: Maybe NGLType -> Maybe NGLType -> TypeMSt ()+check_assignment _ (Just NGLVoid) = errorInLine "Assigning void value to variable"+check_assignment Nothing _ = return ()+check_assignment a b = when (a /= b)+        (errorInLine $ T.concat ["Assigning type ", showType b, " to a variable that has type ", showType a])+    where+        showType = T.pack . show . fromJust++nglTypeOf :: Expression -> TypeMSt (Maybe NGLType)+nglTypeOf (FunctionCall f arg args b) = inferBlock f b *> checkFuncKwArgs f args *> checkFuncUnnamed f arg+nglTypeOf (MethodCall m self arg args) = checkmethodcall m self arg args+nglTypeOf (Lookup mt (Variable v)) = envLookup mt v+nglTypeOf (BuiltinConstant (Variable v)) = return (typeOfConstant v)+nglTypeOf (ConstStr _) = return (Just NGLString)+nglTypeOf (ConstInt _) = return (Just NGLInteger)+nglTypeOf (ConstDouble _) = return (Just NGLDouble)+nglTypeOf (ConstBool _) = return (Just NGLBool)+nglTypeOf (ConstSymbol _) = return (Just NGLSymbol)+nglTypeOf e@(ListExpression _) = do+    mt <- checkindexable e+    case mt of+        Nothing -> return Nothing+        Just t -> return (Just (NGList t))+nglTypeOf Continue = return Nothing+nglTypeOf Discard = return Nothing+nglTypeOf (Assignment _ expr) = nglTypeOf expr+nglTypeOf (UnaryOp uop expr) = checkuop uop expr+nglTypeOf (BinaryOp bop a b) = checkbop bop a b+nglTypeOf (IndexExpression expr index) = checkindex expr index+nglTypeOf Optimized{}    = error "unexpected nglTypeOf(Optimized)"+nglTypeOf Condition{}    = error "unexpected nglTypeOf(Condition)"+nglTypeOf (Sequence _es) = error "unexpected nglTypeOf(Sequence)"++typeOfConstant :: T.Text -> Maybe NGLType+typeOfConstant "STDIN"        = Just NGLString+typeOfConstant "STDOUT"       = Just NGLString+typeOfConstant _              = Nothing++typeOfObject :: NGLessObject -> Maybe NGLType+typeOfObject (NGOString _) = Just NGLString+typeOfObject (NGOBool _) = Just NGLBool+typeOfObject (NGOInteger _) = Just NGLInteger+typeOfObject (NGODouble _) = Just NGLDouble+typeOfObject (NGOSymbol _) = Just NGLSymbol+typeOfObject (NGOFilename _) = Just NGLFilename+typeOfObject (NGOShortRead _) = Just NGLRead+typeOfObject NGOReadSet{} = Just NGLReadSet+typeOfObject NGOMappedReadSet{} = Just NGLMappedReadSet+typeOfObject NGOMappedRead{} = Just NGLMappedRead+typeOfObject NGOSequenceSet{} = Just NGLSequenceSet+typeOfObject NGOCounts{} = Just NGLCounts+typeOfObject NGOVoid = Just NGLVoid+typeOfObject (NGOList []) = Nothing+typeOfObject (NGOList (v:_)) = NGList <$> typeOfObject v+++checkuop UOpLen e = checkindexable e $> Just NGLInteger+checkuop UOpMinus e = checknum e+checkuop UOpNot e = checkBool e++checkbop :: BOp -> Expression -> Expression -> TypeMSt (Maybe NGLType)+checkbop BOpAdd a b = do+    t <- liftM2 (<|>)+        (softCheckPair NGLInteger a b)+        (softCheckPair NGLString a b)+    when (isNothing t) $+        errorInLineC ["Addition operator (+) must be applied to a pair of strings or integers"]+    return t+checkbop BOpMul a b = checknum a *> checknum b++checkbop BOpGT  a b = checknum a *> checknum b $> Just NGLBool+checkbop BOpGTE a b = checknum a *> checknum b $> Just NGLBool+checkbop BOpLT  a b = checknum a *> checknum b $> Just NGLBool+checkbop BOpLTE a b = checknum a *> checknum b $> Just NGLBool+checkbop BOpPathAppend a b = softCheck NGLString a *> softCheck NGLString b $> Just NGLString+checkbop BOpNEQ  a b = checkbop BOpEQ a b+checkbop BOpEQ  a b = do+    t <- liftM3 (\x y z -> x <|> y <|> z)+        (softCheckPair NGLInteger a b)+        (softCheckPair NGLDouble a b)+        (softCheckPair NGLString a b)+    when (isNothing t) $+        errorInLineC ["Comparison operators (== or !=) must be applied to a pair of strings or numbers"]+    return (Just NGLBool)+++softCheck :: NGLType -> Expression -> TypeMSt (Maybe NGLType)+softCheck expected expr = do+    t <- nglTypeOf expr+    return $ if t /= Just expected+        then Nothing+        else t++softCheckPair t a b = do+    ta <- softCheck t a+    tb <- softCheck t b+    return $! if ta == tb && tb == Just t+        then ta+        else Nothing++checkBool (ConstBool _) = return (Just NGLBool)+checkBool expr = do+    t <- nglTypeOf expr+    when (t /= Just NGLBool) $+        errorInLineC ["Expected boolean expression, got ", show t, " for expression ", show expr]+    return (Just NGLBool)++checkinteger (ConstInt _) = return (Just NGLInteger)+checkinteger expr = do+    t <- nglTypeOf expr+    when (t /= Just NGLInteger) $+        errorInLineC ["Expected integer expression, got ", show t, " for expression ", show expr]+    return (Just NGLInteger)++checknum e = do+    t <- nglTypeOf e+    if t `elem` [Just NGLInteger, Just NGLDouble, Nothing]+        then return t+        else do+            errorInLineC ["Expected numeric expression, got ", show t, " for expression ", show e]+            return $ Just NGLDouble -- a decent guess most of the time++checkindex expr index = checkindex' index *> checkindexable expr+    where+        checkindex' (IndexOne e) = checkinteger e+        checkindex' (IndexTwo a b) = checkinteger' a *> checkinteger' b+        checkinteger' Nothing = return Nothing+        checkinteger' (Just v) = checkinteger v++checkindexable (ListExpression []) = return (Just NGLVoid)+checkindexable (ListExpression es) = do+    types <- nglTypeOf `mapM` es+    let ts = catMaybes types+    if null ts+        then return Nothing+        else do+            unless (allSame ts)+                (errorInLine "List of mixed type")+            return (Just $ head ts)+checkindexable expr = do+    t <- nglTypeOf expr+    case t of+        Just (NGList !btype) -> return $ Just btype+        Just NGLRead -> return t+        e -> do+            errorInLineC ["List expected. Type ", show e , " provided."]+            return $ Just NGLVoid+++funcInfo fn = do+    fs <- asks (concatMap modFunctions)+    let matched = filter ((==fn) . funcName) fs+    case matched of+        [fi] -> return fi+        [] -> do+            errorInLineC ["Unknown function '", show fn, "'. ", T.unpack (suggestionMessage (unwrapFuncName fn) (unwrapFuncName . funcName <$> fs))]+            cannotContinue+        _ -> do+            errorInLineC ["Too many matches for function '", show fn, "'"]+            cannotContinue++findMethodInfo :: MethodName -> Expression -> TypeMSt MethodInfo+findMethodInfo m self =  case filter ((==m) . methodName) builtinMethods of+    [mi] -> return mi+    ms@(_:_) -> nglTypeOf self >>= \case+        Nothing -> do+            errorInLineC ["Cannot disambiguate method `", T.unpack (unwrapMethodName m), "` as it is called on an expression of unknown type (", show self, ")."]+            cannotContinue+        Just selfType -> case filter (\mi -> methodSelfType mi == selfType) ms of+            [mi] -> return mi+            _ -> do+                errorInLineC ["Cannot disambiguate method `", T.unpack (unwrapMethodName m), "` as it was called on an unsupported type"]+                cannotContinue+    _ -> do+        errorInLineC+            ["Cannot find method `", T.unpack (unwrapMethodName m), "`. "+            ,T.unpack $ suggestionMessage (unwrapMethodName m) ((unwrapMethodName . methodName) <$> builtinMethods)+            ]+        cannotContinue++checkFuncUnnamed :: FuncName -> Expression -> TypeMSt (Maybe NGLType)+checkFuncUnnamed f arg = do+        targ <- nglTypeOf arg+        Function _ metype _ rtype _ allowAutoComp _ <- funcInfo f+        case metype of+            Just etype -> case targ of+                Just (NGList t)+                    | allowAutoComp -> checkfunctype etype t $> Just (NGList rtype)+                Just t -> checkfunctype etype t $> Just rtype+                Nothing -> do+                    errorInLineC ["While checking types for function ", show f, ".\n\tCould not infer type of argument (saw :", show arg, ")"]+                    cannotContinue+            Nothing -> return Nothing+    where+        checkfunctype NGLAny NGLVoid = errorInLineC+                                    ["Function '", show f, "' can take any type, but the input is of illegal type Void."]+        checkfunctype NGLAny _ = return ()+        checkfunctype t t'+                | t /= t' = errorInLineC+                                    ["Bad type in function call (function '", show f,"' expects ", show t, " got ", show t', ")."]+                | otherwise = return ()++checkFuncKwArgs :: FuncName -> [(Variable, Expression)] -> TypeMSt ()+checkFuncKwArgs f args = do+    Function _ _ _ _ argInfo _ _ <- funcInfo f+    mapM_ (check1arg (concat ["function '", show f, "'"]) argInfo) args+++check1arg :: String -> [ArgInformation] -> (Variable, Expression) -> TypeMSt ()+check1arg ferr arginfo (Variable v, e) = do+    eType <- nglTypeOf e+    let ainfo = find ((==v) . argName) arginfo+    case (ainfo,eType) of+        (Nothing, _) -> errorInLineC $+            ["Bad argument '", T.unpack v, "' for ",  ferr, ".\n"+            ,T.unpack $ suggestionMessage v (argName <$> arginfo)+            ,"\nThis function takes the following arguments:\n"]+            ++ map ((\aname -> "\t"++aname++"\n") . T.unpack . argName) arginfo+        (_, Nothing) -> return () -- Could not infer type of argument. Maybe an error, but maybe not+        (Just ainfo', Just t') ->+            when (argType ainfo' /= t') $+                errorInLineC+                    ["Bad argument type in ", ferr ,", variable " , show v, ". ",+                    "Expected ", show . argType $ ainfo', " got ", show t', "."]+++requireType :: NGLType -> Expression -> TypeMSt NGLType+requireType def_t e = nglTypeOf e >>= \case+    Nothing -> do+        errorInLineC ["Could not infer required type of expression (", show e, ")"]+        return def_t+    Just t -> return t++checkmethodcall :: MethodName -> Expression -> Maybe Expression -> [(Variable, Expression)] -> TypeMSt (Maybe NGLType)+checkmethodcall m self arg args = do+    minfo <- findMethodInfo m self+    let reqSelfType = methodSelfType minfo+        reqArgType = methodArgType minfo+    stype <- requireType reqSelfType self+    when (stype /= reqSelfType) (errorInLineC+        ["Wrong type for method ", show m, ". This method is defined for type ", show reqSelfType,+         ", but expression (", show self, ") has type ", show stype])+    actualType <- maybe (return Nothing) nglTypeOf arg+    case (actualType, reqArgType) of+        (Nothing, _) -> return ()+        (Just _, Nothing) -> errorInLineC ["Method ", show m, " does not take any unnamed argument (saw ", show arg, ")"]+        (Just t, Just t') -> when (t /= t') (errorInLineC+                        ["Method ", show m, " expects type ", show t', " got ", show t])++    let ainfo = methodKwargsInfo minfo+    forM_ args (check1arg (concat ["method '", show m, "'"]) ainfo)+    forM_ (filter argRequired ainfo) $ \ai ->+        case filter (\(Variable v,_) -> v == argName ai) args of+            [_] -> return ()+            [] -> errorInLineC ["Required argument ", T.unpack (argName ai), " is missing in method call ", show m, "."]+            _ -> error "This should never happen: multiple arguments with the same name should have been caught before"+    return . Just . methodReturnType $ minfo++addTypes :: TypeMap -> [(Int, Expression)] -> NGLess [(Int,Expression)]+addTypes tmap exprs = mapM (secondM (runNGLess . recursiveTransform addTypes')) exprs+    where+        addTypes' :: Expression -> NGLess Expression+        addTypes' (Lookup Nothing v@(Variable n)) = case Map.lookup n tmap of+            t@(Just _) -> return $ Lookup t v+            Nothing -> throwScriptError ("Could not assign type to variable '" ++ show n ++ "'.")+        addTypes' e = return e
+ NGLess/Utils/Batch.hs view
@@ -0,0 +1,21 @@+{- Copyright 2015-2020 NGLess Authors+ - License: MIT+ -}+module Utils.Batch+    ( getNcpus+    ) where++import Text.Read (readMaybe)+import System.Environment (lookupEnv)+import Control.Monad.Extra (firstJustM)++getNcpus :: IO (Maybe Int)+getNcpus = firstJustM getIntFromEnv+                 [ "OMP_NUM_THREADS"+                 , "NSLOTS"+                 , "LSB_DJOB_NUMPROC"+                 , "SLURM_CPUS_PER_TASK"+                 ]++getIntFromEnv :: String -> IO (Maybe Int)+getIntFromEnv evar = (>>= readMaybe) <$> lookupEnv evar
+ NGLess/Utils/Conduit.hs view
@@ -0,0 +1,131 @@+{- Copyright 2013-2019 NGLess Authors+ - License: MIT -}+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, CPP #-}++module Utils.Conduit+    ( ByteLine(..)+    , byteLineSinkHandle+    , byteLineVSinkHandle+    , linesC+    , linesVC+    , zipSink2+    , zipSource2+    ) where++import qualified Data.ByteString as B++import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import qualified Data.Vector         as V+import qualified Data.Vector.Mutable as VM++import           Control.Monad (when)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.Error.Class (MonadError(..))+import           System.IO++import NGLess.NGError++-- | This just signals that a "line" is expected.+newtype ByteLine = ByteLine { unwrapByteLine :: B.ByteString }+                deriving (Show)++-- A limit was introduced to avoid running out of memory on corrupt files, but+-- it needs to be large enough to accommodate nanopore reads, see:+-- https://groups.google.com/forum/#!topic/ngless/-ovfYW8hfAs+maxLineSize :: Int+maxLineSize = 1024 * 1024 * 1024++concatrevline :: B.ByteString -> [B.ByteString] -> ByteLine+concatrevline line [] = ByteLine $ lineWindowsTerminated line+concatrevline line toks = ByteLine . lineWindowsTerminated $ B.concat (reverse (line:toks))+{-# INLINE concatrevline #-}++linesC:: (MonadError NGError m) => C.ConduitT B.ByteString ByteLine m ()+linesC = continue 0 []+    where+        continue n toks+            | n > maxLineSize = throwDataError ("Line too long (length is " ++ show n ++ " characters).")+            | otherwise = C.await >>= maybe+                                        (when (n > 0) $ C.yield (concatrevline B.empty toks))+                                        (emit n toks)+        emit n toks tok = case B.elemIndex 10 tok of+                Nothing -> continue (n + B.length tok) (tok:toks)+                Just ix -> let (start,rest) = B.splitAt ix tok in do+                                C.yield (concatrevline start toks)+                                emit 0 [] (B.tail rest)++{-# INLINE linesC #-}++-- | Remove trailing \r present when the original line terminator was \r\n (windows)+lineWindowsTerminated :: B.ByteString -> B.ByteString+lineWindowsTerminated line = if not (B.null line) && B.index line (B.length line - 1) == carriage_return+                                then B.take (B.length line - 1) line+                                else line+                                    where carriage_return = 13+{-# INLINE lineWindowsTerminated #-}++-- | Equivalent to 'linesC .| CC.conduitVector nlines'+linesVC :: (MonadIO m, MonadError NGError m) => Int -> C.ConduitT B.ByteString (V.Vector ByteLine) m ()+linesVC nlines = do+            vec <- liftIO $ VM.new nlines+            continue vec 0 0 []+        where+            continue vec vix n toks+                | n > maxLineSize = throwDataError ("Line too long (length is " ++ show n ++ " characters).")+                | otherwise = C.await >>= maybe (finish vec vix toks) (emit vec vix n toks)++            finish   _   0 [] = return ()+            finish vec vix [] = C.yield =<< liftIO (V.unsafeSlice 0 vix <$> V.unsafeFreeze vec)+            finish vec vix toks = do+                    liftIO $ VM.write vec vix (ByteLine . lineWindowsTerminated . B.concat $ reverse toks)+                    finish vec (vix + 1) []++            emit vec vix n toks tok = do+                (done, vec', vix', n', toks') <- liftIO $ splitWrite [] vec vix n toks tok+                CL.sourceList (reverse done)+                continue vec' vix' n' toks'++            -- splitWrite is in IO. This is a micro-optimization, but this code+            -- can be in the inner loop, so it's worthwhile to micro-optimize.+            --+            -- Basically, moving up and down the transformer stack (with lift &+            -- friends) can be expensive. Doing the inner loop in IO is+            -- measurably faster.+            splitWrite done vec vix !n toks tok+                | vix >= nlines = do+                    f <- V.unsafeFreeze vec+                    vec' <- VM.new nlines+                    splitWrite (f:done) vec' 0 n toks tok+                | otherwise = case B.elemIndex 10 tok of+                    Nothing -> return (done, vec, vix, n + B.length tok, (if not (B.null tok) then (tok:toks) else toks))+                    Just ix -> do+                        let (start, rest) = B.splitAt ix tok+                        VM.write vec vix (concatrevline start toks)+                        splitWrite done vec (vix + 1) 0 [] (B.tail rest)+{-# INLINE linesVC #-}+++byteLineSinkHandle :: (MonadIO m) => Handle -> C.ConduitT ByteLine C.Void m ()+byteLineSinkHandle h = CL.mapM_ (\(ByteLine val) -> liftIO (B.hPut h val >> B.hPut h nl))+    where+        nl = B.singleton 10+{-# INLINE byteLineSinkHandle #-}+++byteLineVSinkHandle :: (MonadIO m) => Handle -> C.ConduitT (V.Vector ByteLine) C.Void m ()+byteLineVSinkHandle h = CL.mapM_ $ liftIO . V.mapM_ (\(ByteLine val) -> B.hPut h val >> B.hPut h nl)+    where+        nl = B.singleton 10+{-# INLINE byteLineVSinkHandle #-}+++zipSource2 :: Monad m => C.ConduitT () a m () -> C.ConduitT () b m () -> C.ConduitT () (a,b) m ()+zipSource2 a b = C.getZipSource ((,) <$> C.ZipSource a <*> C.ZipSource b)+{-# INLINE zipSource2 #-}+++zipSink2 :: (Monad m) => C.ConduitT i C.Void m a -> C.ConduitT i C.Void m b -> C.ConduitT i C.Void m (a,b)+zipSink2 a b = C.getZipSink((,) <$> C.ZipSink a <*> C.ZipSink b)+{-# INLINE zipSink2 #-}+
+ NGLess/Utils/Debug.hs view
@@ -0,0 +1,16 @@+{- Copyright 2015 NGLess Authors+ - License: MIT+ -}++module Utils.Debug+    ( tracex+    , trace+    ) where+++import Debug.Trace++-- | Show value when evaluated, then return it+tracex :: Show a => a -> a+tracex x = trace (show x) x+{-# WARNING tracex "Using tracex [remove before committing]" #-}
+ NGLess/Utils/Here.hs view
@@ -0,0 +1,14 @@+module Utils.Here (here) where+import Language.Haskell.TH+import Language.Haskell.TH.Quote++-- | Heredocs+here = QuasiQuoter+    { quoteExp = stringE . skipStartNL+    , quotePat = const (error "cannot be used as pattern")+    , quoteType = const (error "cannot be used as type")+    , quoteDec = const (error "cannot be used as declaration")+    }++skipStartNL ('\n':rest) = rest+skipStartNL s = s
+ NGLess/Utils/IntGroups.hs view
@@ -0,0 +1,58 @@+{- Copyright 2016-2018 NGLess Authors+ - License: MIT -}+{-# LANGUAGE ScopedTypeVariables #-}++module Utils.IntGroups+    ( IntGroups(..)++    , fromList+    , toList++    , empty+    , length+    , null++    , forM_+    ) where+import qualified Data.Vector.Unboxed as VU+import qualified Control.Monad+import Control.DeepSeq          (NFData(..))+import qualified Prelude+import Prelude hiding (length, null)++-- | IntGroups are a faster, strict, representation of [[Int]]+data IntGroups = IntGroups !(VU.Vector Int) !(VU.Vector Int)+instance NFData IntGroups where+    rnf (IntGroups !_ !_) = ()+++fromList :: [[Int]] -> IntGroups+fromList gs = IntGroups values indices+    where+        values = VU.fromList (concat gs)+        indices = VU.fromList (scanl (+) 0 $ map Prelude.length gs)++toList :: IntGroups -> [VU.Vector Int]+toList (IntGroups values indices) = go 0+    where+        go ix+            | ix == VU.length indices - 1 = []+            | otherwise = VU.slice st n values:go (ix+1)+                where+                    st = indices VU.! ix+                    e = indices VU.! (ix + 1)+                    n = e - st+{-# INLINE toList #-}++length (IntGroups _ indices) = VU.length indices - 1+{-# INLINE length #-}++null (IntGroups values _) = VU.null values+{-# INLINE null #-}++empty = IntGroups VU.empty VU.empty++forM_ :: (Monad m) => IntGroups -> ((VU.Vector Int) -> m ()) -> m ()+forM_ vs = Control.Monad.forM_ (toList vs)+{-# INLINE forM_ #-}+
+ NGLess/Utils/LockFile.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE RecordWildCards, CPP #-}+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++module Utils.LockFile+    ( withLockFile+    , LockParameters(..)+    , WhenExistsStrategy(..)+    , acquireLock+    , fileAge+    , removeFileIfExists+    ) where++import qualified Control.Concurrent.Async as A++#ifndef WINDOWS+import           System.Posix.Process+import           System.Posix.Files (touchFile)+#endif+++import System.IO.Error (isDoesNotExistError)+import System.Directory (getModificationTime, removeFile)+import Data.Time (NominalDiffTime+                 , getZonedTime+                 , formatTime+                 , defaultTimeLocale+                 , getCurrentTime+                 , diffUTCTime+                 )+import Control.Monad.Except+import Control.Exception+import Control.Concurrent (threadDelay)++import Data.Bits ((.|.))+import Foreign.C (eEXIST, errnoToIOError, getErrno)+import GHC.IO.Handle.FD (fdToHandle)+import System.IO (Handle, hClose, hPutStrLn)+import System.Posix.Internals+    ( c_close+    , c_open+    , o_BINARY+    , o_CREAT+    , o_EXCL+    , o_NOCTTY+    , o_NONBLOCK+    , o_RDWR+    , withFilePath+    )+import Control.Monad.Trans.Resource+import Network.HostName (getHostName)++import NGLess.NGError+import Output++data LockParameters = LockParameters+                { lockFname :: FilePath+                , maxAge :: NominalDiffTime+                , whenExistsStrategy :: WhenExistsStrategy+                , mtimeUpdate :: Bool -- ^ start a thread which updates the mtime on the file every 10 minutes+                } deriving (Eq, Show)++data WhenExistsStrategy =+                IfLockedNothing+                | IfLockedThrow NGError+                | IfLockedRetry { nrLockRetries :: !Int, timeBetweenRetries :: !NominalDiffTime }+            deriving (Eq, Show)++pidAsStr :: IO String+#ifndef WINDOWS+pidAsStr = show <$> getProcessID+#else+pidAsStr = return "(PID is not available on Windows)"+#endif++#ifdef WINDOWS+touchFile fname = writeFile fname "lock file"+#endif++-- | Executes the action specified with a lock file around it so that multiple+-- ngless do not clash with each other+withLockFile :: LockParameters -> NGLessIO a -> NGLessIO a+withLockFile params act =+    acquireLock params >>= \case+        Just rk -> do+            v <- act+            release rk+            return v+        Nothing -> throwSystemError "Could not acquire required lock file."+++sleep :: NominalDiffTime -> IO ()+sleep = threadDelay . toMicroSeconds+    where+        toMicroSeconds :: NominalDiffTime -> Int+        toMicroSeconds = (1000000 *) . fromInteger . round+++-- | Atomically create a lock file+-- If file already exists, returns 'Nothing'+acquireLock :: LockParameters -> NGLessIO (Maybe ReleaseKey)+acquireLock params@LockParameters{..} = liftIO (openLockFile lockFname) >>= \case+    Just h -> do+        -- rkC is for the case where an exception is raised between this line and the release call below+        rkC <- register (hClose h)+        rk <- register (removeFileIfExists lockFname)+        outputListLno' DebugOutput ["Acquired lock file ", lockFname]+        liftIO $ do+            pid <- pidAsStr+            hostname <- getHostName+            t <- getZonedTime+            let tformat = "%a %d-%m-%Y %R"+                tstr = formatTime defaultTimeLocale tformat t+            hPutStrLn h ("Lock file created for PID " ++ pid ++ " on hostname " ++ hostname ++ " at time " ++ tstr)+            release rkC+        Just <$> if mtimeUpdate+                then do+                    let updateloop :: IO ()+                        updateloop = threadDelay (10*60*1000*1000) >> touchFile lockFname >> updateloop+                    (rk', _) <- allocate (A.async updateloop) A.cancel+                    register (release rk' >> release rk)+                else return rk+    Nothing -> liftIO (fileAge lockFname) >>= \case+        Nothing -> do+            outputListLno' InfoOutput ["Lock file ", lockFname, " existed but has been removed. Retrying."]+            acquireLock params+        Just age | age > maxAge -> do+            outputListLno' InfoOutput ["Lock file ", lockFname, " exists but is too old. Assuming it is stale and removing it."]+            liftIO $ removeFileIfExists lockFname+            acquireLock params+        _ -> case whenExistsStrategy of+            IfLockedNothing -> return Nothing+            IfLockedThrow err -> throwError err+            IfLockedRetry{ .. }+                | nrLockRetries > 0 -> do+                    outputListLno' InfoOutput ["Lock file ", lockFname, " exists and seems current, sleeping for ", show timeBetweenRetries, "."]+                    liftIO $ sleep timeBetweenRetries+                    let lessOneTry = IfLockedRetry (nrLockRetries - 1) timeBetweenRetries+                    acquireLock (params { whenExistsStrategy = lessOneTry })+                | otherwise -> throwSystemError ("Could not obtain lock " ++ lockFname ++ " even after waiting for its release.")++-- This code is adapted from+-- https://hackage.haskell.org/package/lock-file-0.5.0.2/docs/src/System-IO-LockFile-Internal.html+openLockFile :: FilePath -> IO (Maybe Handle)+openLockFile lockFileName = do+    let openFlags = o_NONBLOCK .|. o_NOCTTY .|. o_RDWR .|. o_CREAT .|. o_EXCL .|. o_BINARY+    fd <- withFilePath lockFileName $ \ fp -> c_open fp openFlags 0o644+    if fd > 0+        then Just <$> fdToHandle fd `onException` c_close fd+        else do+            errno <- getErrno+            when (errno /= eEXIST) . ioError+                . errnoToIOError "lock" errno Nothing $ Just lockFileName+            -- Failed to open lock file because it already exists+            return Nothing++handleIf :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a+handleIf cond alt act = handleJust+    (\e -> if cond e then return (Just ()) else return Nothing)+    (const alt)+    act++fileAge :: FilePath -> IO (Maybe NominalDiffTime)+fileAge fname = handleIf isDoesNotExistError (return Nothing) $ Just <$> do+    mtime <- getModificationTime fname+    cur <- getCurrentTime+    return (cur `diffUTCTime` mtime)++removeFileIfExists :: FilePath -> IO ()+removeFileIfExists fp = removeFile fp `catch` ignoreDoesNotExistError+    where+        ignoreDoesNotExistError e+                | isDoesNotExistError e = return ()+                | otherwise = throwIO e
+ NGLess/Utils/Network.hs view
@@ -0,0 +1,90 @@+{- Copyright 2013-2019 NGLess Authors+ - License: MIT+ -}+module Utils.Network+    ( downloadFile+    , downloadOrCopyFile+    , downloadExpandTar+    , isUrl+    ) where++import           Control.Monad.IO.Class (liftIO, MonadIO(..))+import           Control.Monad (void)+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import           Data.Conduit ((.|))+import qualified Data.Conduit.Tar as CTar++import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString as B+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Simple as HTTPSimple+import           Data.Conduit.Algorithms.Utils (awaitJust)+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)++import qualified Data.Conduit.Binary as CB+import System.Directory (copyFile, createDirectoryIfMissing, removeFile)+import Data.List (isPrefixOf)+import System.FilePath++import Output+import NGLess+import Version (versionStr)+import Utils.ProgressBar++isUrl :: FilePath -> Bool+isUrl p = any (`isPrefixOf` p) ["http://", "https://", "ftp://"]+{-# INLINE isUrl #-}++downloadOrCopyFile :: FilePath -> FilePath -> NGLessIO ()+downloadOrCopyFile src dest+    | isUrl src = downloadFile src dest+    | otherwise = liftIO $ copyFile src dest+++downloadFile :: String -> FilePath -> NGLessIO ()+downloadFile url destPath = do+    outputListLno' TraceOutput ["Downloading ", url]+    req <- HTTP.parseRequest url+    let req' = req { HTTP.decompress = const False,+                    HTTP.requestHeaders = [("User-Agent", B8.pack $ "NGLess/"++versionStr)]+                    }+    r <- liftIO $ HTTPSimple.withResponse req' $ \res ->+        case HTTPSimple.getResponseStatusCode res of+            200 -> do+                C.runConduitRes $+                    HTTP.responseBody res+                        .| case lookup "Content-Length" (HTTP.responseHeaders res) of+                            Nothing -> CL.map id+                            Just csize -> printProgress ("Downloading "++url) (read (B8.unpack csize))+                        .| CB.sinkFileCautious destPath+                return $ Right ()+            err -> return . throwSystemError $ "Could not connect to "++url++" (got error code: "++show err++")"+    runNGLess (r :: NGLess ())++-- | Download a tar.gz file and expand it onto 'destdir'+downloadExpandTar :: FilePath -> FilePath -> NGLessIO ()+downloadExpandTar url destdir = do+    let tarName = destdir <.> "tar.gz"++    liftIO $ createDirectoryIfMissing True destdir+    -- We could avoid creating the tar file by streaming directly to untarWithExceptions+    downloadOrCopyFile url tarName+    liftIO $ do+        void $ C.runConduitRes $+            conduitPossiblyCompressedFile tarName+                .| CTar.untarWithExceptions (CTar.restoreFileIntoLenient destdir)+        removeFile tarName+++printProgress :: MonadIO m => String -> Int -> C.ConduitT B.ByteString B.ByteString m ()+printProgress msg csize = liftIO (mkProgressBar msg 40) >>= loop 0+  where+    loop !len pbar = awaitJust $ \bs -> do+            let len' = len + B.length bs+                progress = fromIntegral len' / fromIntegral csize+            pbar' <- liftIO (updateProgressBar pbar progress)+            C.yield bs+            loop len' pbar'++
+ NGLess/Utils/Process.hs view
@@ -0,0 +1,79 @@+module Utils.Process+    ( runProcess+    ) where+import           System.Exit (ExitCode(..))+import           Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as BL8++import qualified Data.Conduit.Process.Typed as CPT+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import           Data.Conduit ((.|))+import qualified UnliftIO as U+import           Control.Concurrent (getNumCapabilities, setNumCapabilities)+import qualified Control.Monad.STM as STM++import Output+import NGLess+import Configuration+import NGLess.NGLEnvironment++-- | runProcess and check exit code+runProcess :: FilePath -- ^ executable+                -> [String] -- ^ command line arguments+                -> C.ConduitT () B.ByteString NGLessIO () -- ^ stdin+                -> Either a (C.ConduitT B.ByteString C.Void NGLessIO a) -- ^ stdout: 'Right sink' if it's a consumer, else always return the value given+                -> NGLessIO a+runProcess binPath args stdin stdout = do+    numCapabilities <- liftIO getNumCapabilities+    strictThreads <- nConfStrictThreads <$> nglConfiguration+    let with1Thread act+            | strictThreads = U.bracket_+                                (liftIO $ setNumCapabilities 1)+                                (liftIO $ setNumCapabilities numCapabilities)+                                act+            | otherwise = act+        stdout' = case stdout of+            Left _ -> fmap Left CL.consume+            Right sink -> fmap Right sink+    outputListLno' DebugOutput ["Will run process ", binPath, " ", unwords args]+    (exitCode, out, err) <- with1Thread $+        CPT.withProcessWait (+                        -- No need to keep these open+                        CPT.setCloseFds True+                        -- We need the Handle for stdin because we need to hClose it!+                        -- Therefore, we cannot use `CPT.setStdin CTP.createSink`+                        $ CPT.setStdin CPT.createPipe+                        $ CPT.setStderr CPT.byteStringOutput+                        $ CPT.setStdout CPT.createSource+                        $ CPT.proc binPath args) $ \p ->+            U.runConcurrently $ (,,)+                <$> U.Concurrently (CPT.waitExitCode p)+                <*  U.Concurrently (do+                                        let hin = CPT.getStdin p+                                        C.runConduit (stdin .| CC.sinkHandle hin)+                                        U.hClose hin)+                <*> U.Concurrently (C.runConduit (CPT.getStdout p .| stdout'))+                <*> U.Concurrently (liftIO $ STM.atomically (CPT.getStderr p))+    let err' = BL8.unpack err+    outputListLno' DebugOutput ["Stderr: ", err']+    (r, out') <- case out of+        Left str -> do+            outputListLno' DebugOutput ["Stdout: ", BL8.unpack $ BL8.fromChunks str]+            return $! case stdout of+                            Left f -> (f, BL8.unpack $ BL8.fromChunks str)+                            Right _ -> error "absurd"+        Right v -> return (v, "<captured by inner process>\n")+    case exitCode of+        ExitSuccess -> do+            outputListLno' InfoOutput ["Success"]+            return r+        ExitFailure code ->+            throwSystemError $ concat ["Failed command\n",+                            "Executable used::\t", binPath,"\n",+                            "Command line was::\n\t", unwords args, "\n",+                            "Error code was ", show code, ".\n",+                            "Stdout: ", out',+                            "Stderr: ", err']
+ NGLess/Utils/ProgressBar.hs view
@@ -0,0 +1,65 @@+{- Copyright 2014-2020 NGLess Authors+ - License: MIT+ -}++module Utils.ProgressBar+    ( mkProgressBar+    , updateProgressBar+    ) where++import qualified Text.Printf as TP+import           System.IO (stdout, hFlush, hIsTerminalDevice)+import qualified Data.Time as Time++data ProgressBarData = ProgressBarData+    { pbarName :: String+    , cur :: Rational+    , lastUpdated :: Time.UTCTime+    , width :: Int+    } deriving (Eq, Show)++type ProgressBar = Maybe ProgressBarData+++-- | Redraw progress bar+--+-- If the last update was less than 1 second ago, then nothing is updated+updateProgressBar :: ProgressBar -- ^ previous progressbar+                  -> Rational -- ^ current fractional progress+                  -> IO ProgressBar -- ^ new progressbar+updateProgressBar Nothing _ = return Nothing+updateProgressBar (Just bar) progress = do+    now <- Time.getCurrentTime+    if (now `Time.diffUTCTime` lastUpdated bar) > 1 && (percent progress /= percent (cur bar))+        then do+            let pmessage = drawProgressBar (width bar) progress ++ " " ++ printPercentage progress+                m = pbarName bar ++ pmessage ++ "\r"+            putStr m+            hFlush stdout+            return . Just $ bar { cur = progress, lastUpdated = now }+        else return (Just bar)++-- | create a new 'ProgressBar' object+--+-- This function also checks if 'stdout' is a terminal device. If it is not,+-- then it returns a null progress bar, one which does not draw on the screen.+mkProgressBar :: String -> Int -> IO ProgressBar+mkProgressBar name w = do+    isTerm <- hIsTerminalDevice stdout+    now <- Time.getCurrentTime+    return $! if isTerm+        then Just (ProgressBarData name (-1) now w)+        else Nothing++drawProgressBar :: Int -> Rational -> String+drawProgressBar w progress =+  "[" ++ replicate bars '=' ++ replicate spaces ' ' ++ "]"+  where bars = round (progress * fromIntegral w)+        spaces = w - bars++percent :: Rational -> Int+percent = round . (* 1000)++printPercentage :: Rational -> String+printPercentage progress = TP.printf "%6.1f%%" (fromRational (progress * 100) :: Double)+
+ NGLess/Utils/Samtools.hs view
@@ -0,0 +1,109 @@+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++module Utils.Samtools+    ( samBamConduit+    , convertSamToBam+    , convertBamToSam+    ) where++import Control.Monad+import System.Exit+import System.IO++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as C+import qualified Data.Conduit.Process as CP+import qualified Control.Concurrent.Async as A+import qualified UnliftIO as U+import           Data.Conduit ((.|))+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)+import           Control.Monad.Except+import           Control.Concurrent (getNumCapabilities, setNumCapabilities)+import           Data.List (isSuffixOf)+import           System.Process (proc)++import NGLess.NGLEnvironment+import Configuration+import Output+import FileManagement+import NGLess.NGError++-- | reads a SAM (possibly compressed) or BAM file (in the latter case by using+-- 'samtools view' under the hood)+samBamConduit :: FilePath -> C.ConduitT () B.ByteString NGLessIO ()+samBamConduit samfp+  | ".bam" `isSuffixOf` samfp = do+        lift $ outputListLno' TraceOutput ["Starting samtools view of ", samfp]+        samtoolsPath <- lift samtoolsBin+        (hout, herr, err, sp) <- liftIO $ do+            numCapabilities <- getNumCapabilities+            let cp = proc samtoolsPath ["view", "-h", "-@", show numCapabilities, samfp]+            (CP.ClosedStream+                ,hout+                ,herr+                ,sp) <- CP.streamingProcess cp+            err <- A.async $ C.runConduitRes (C.sourceHandle herr .| CL.consume)+            A.link err+            return (hout, herr, err, sp)+        C.sourceHandle hout+        exitCode <- CP.waitForStreamingProcess sp+        forM_ [hout, herr] (liftIO . hClose)+        errout <- liftIO $ BL8.unpack . BL8.fromChunks <$> A.wait err+        lift $ outputListLno' DebugOutput ["samtools stderr: ", errout]+        case exitCode of+          ExitSuccess -> return ()+          ExitFailure exitError -> throwSystemError ("Samtools view failed with errorcode '" ++ show exitError ++ "'.\nError message was:\n "++errout)+    | otherwise = conduitPossiblyCompressedFile samfp+++-- | Convert file types (SAM -> BAM)+-- The output is a newly created temporary file+convertSamToBam :: FilePath -> NGLessIO FilePath+convertSamToBam samfile = do+    samPath <- samtoolsBin+    strictThreads <- nConfStrictThreads <$> nglConfiguration+    (newfp, hout) <- openNGLTempFile samfile "converted_" "bam"+    -- We could probably change the code below to use `hout` directly+    liftIO $ hClose hout+    outputListLno' DebugOutput ["SAM->BAM Conversion start ('", samfile, "' -> '", newfp, "')"]+    numCapabilities <- liftIO getNumCapabilities+    let samtoolsthreads+            | strictThreads && numCapabilities > 1 = numCapabilities - 1+            | otherwise = numCapabilities+        with1Thread act+            | strictThreads = U.bracket_+                                (liftIO $ setNumCapabilities 1)+                                (liftIO $ setNumCapabilities numCapabilities)+                                act+            | otherwise = act+    (exitCode, outmsg, errmsg) <- with1Thread $+        CP.sourceProcessWithStreams (proc samPath ["view", "-@", show samtoolsthreads, "-bS", "-o", newfp])+            (samBamConduit samfile)+            CL.consume -- stdout+            CL.consume -- stderr+    if null errmsg+        then outputListLno' DebugOutput ["No output from samtools (stderr)."]+        else outputListLno' InfoOutput ["Message from samtools (stderr): ", concat (B8.unpack <$> errmsg)]+    if null outmsg+        then return ()+        else outputListLno' InfoOutput ["Message from samtools (stdout): ", concat (B8.unpack <$> outmsg)]+    case exitCode of+       ExitSuccess -> return newfp+       ExitFailure err -> throwSystemError ("Failure on converting sam to bam" ++ show err)++-- | Convert file types (BAM -> SAM)+-- The output is a newly created temporary file+convertBamToSam :: FilePath -> NGLessIO FilePath+convertBamToSam bamfile = do+    (newfp, hout) <- openNGLTempFile bamfile "converted_" "sam"+    outputListLno' DebugOutput ["BAM->SAM Conversion start ('", bamfile, "' -> '", newfp, "')"]+    C.runConduit $+        samBamConduit bamfile .| C.sinkHandle hout+    liftIO $ hClose hout+    return newfp
+ NGLess/Utils/Suggestion.hs view
@@ -0,0 +1,74 @@+{- Copyright 2016-2017 NGLess Authors+ - License: MIT+ -}++module Utils.Suggestion+    ( Suggestion(..)+    , findSuggestion+    , suggestionMessage+    , checkFileReadable+    ) where++import qualified Data.Text as T+import qualified Text.EditDistance as TED+import           Control.Monad (msum, guard)+import           Control.Applicative ((<|>))+import           System.IO.Error (catchIOError)+import           System.FilePath (takeDirectory)+import           System.Directory (doesFileExist, getDirectoryContents, getPermissions, readable)++data Suggestion = Suggestion+                        !T.Text+                        -- ^ Suggested text+                        !T.Text+                        -- ^ Reason for user+    deriving (Eq, Show)++-- | Given an erroneous legal input and a list of what the legal options were,+-- attempt to find a suggestion+--+-- See also: 'suggestionMessage'+findSuggestion :: T.Text+                    -- ^ What the user typed+                    -> [T.Text]+                    -- ^ List of legal options+                    -> Maybe Suggestion+                    -- ^ Suggestion if one is found, else Nothing+findSuggestion used possible = matchCase <|> bestMatch+    where+        matchCase = msum (map matchCase1 possible)+        matchCase1 s = do+            guard (T.toLower used == T.toLower s)+            return $! Suggestion s "note that ngless is case-sensitive"+        bestMatch = msum (map goodMatch1 possible)+        goodMatch1 s = do+            guard (dist used s <= 2)+            return $! Suggestion s "closest match"++dist :: T.Text -> T.Text -> Int+dist a b = TED.levenshteinDistance TED.defaultEditCosts (T.unpack a) (T.unpack b)++-- | Like 'findSuggestion': If there is a possible suggestion for the given+-- input, returns a possible message for the user (or empty if no suggestion is+-- found)+suggestionMessage :: T.Text -> [T.Text] -> T.Text+suggestionMessage used valid = case findSuggestion used valid of+      Nothing -> ""+      Just (Suggestion suggestion reason) -> T.concat ["Did you mean '", suggestion, "' (", reason, ")?"]+++-- | Check if the FilePath is readable, else return a suggestion+checkFileReadable :: FilePath -> IO (Maybe T.Text)+checkFileReadable fname = do+    let tfname = T.pack fname+    r <- doesFileExist fname+    if not r+        then do+            existing <- getDirectoryContents (takeDirectory fname)+                                    `catchIOError` (\_ -> return [])+            return . Just . T.concat $! ["File `", tfname, "` does not exist. ", suggestionMessage tfname (T.pack <$> existing)]+        else do+            p <- getPermissions fname+            return $! if not (readable p)+                        then Just (T.concat ["File `", tfname, "` is not readable (permissions problem)."])+                        else Nothing
+ NGLess/Utils/Utils.hs view
@@ -0,0 +1,103 @@+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++{-# LANGUAGE CPP #-}++module Utils.Utils+    ( lookupWithDefault+    , maybeM+    , mapMaybeM+    , fmapMaybeM+    , findM+    , uniq+    , allSame+    , passthrough+    , moveOrCopy+    , secondM+    , dropEnd+    , withOutputFile+    ) where++import System.Directory+import System.IO.Error+import Control.Exception+import GHC.IO.Exception (IOErrorType(..))++import Data.List (group)+import Data.Maybe (fromMaybe, catMaybes)+#ifdef WINDOWS+import           System.AtomicWrite.Internal (tempFileFor, closeAndRename)+#else+import           System.IO.SafeWrite (withOutputFile)+#endif++-- This module should not import from other NGLess modules++{- This module is a grab bag of utility functions+ -}++-- | lookup with a default if the key is not present in the association list+lookupWithDefault :: Eq b => a -> b -> [(b,a)] -> a+lookupWithDefault def key values = fromMaybe def $ lookup key values+{-# INLINE lookupWithDefault #-}++-- | equivalent to the Unix command 'uniq'+uniq :: Eq a => [a] -> [a]+uniq = map head . group++allSame :: Eq a => [a] -> Bool+allSame [] = True+allSame (e:es) = all (==e) es+{-# INLINE allSame #-}++maybeM :: (Monad m) => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)+maybeM ma f = ma >>= \case+    Nothing -> return Nothing+    Just a -> f a++mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f xs = catMaybes <$> mapM f xs++fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)+fmapMaybeM _ Nothing = return Nothing+fmapMaybeM f (Just v) = Just <$> f v+++-- | passthrough applies the function 'f' and then return its argument again+passthrough :: (Monad m) => (a -> m ()) -> a -> m a+passthrough f a = f a >> return a++-- | move a file if possible; otherwise copy+moveOrCopy :: FilePath -> FilePath -> IO ()+moveOrCopy oldfp newfp = renameFile oldfp newfp `catch` (\e -> case ioeGetErrorType e of+            UnsupportedOperation -> copyFile oldfp newfp+            _ -> ioError e)++-- | Monadic version of find: returns the result of the first application of+-- the argument which is not 'Nothing' or, if all applications fail, return+-- 'Nothing'+findM :: Monad m => [a] -> (a -> m (Maybe b)) -> m (Maybe b)+findM [] _ = return Nothing+findM (x:xs) f = f x >>= \case+    Nothing -> findM xs f+    val -> return val++secondM :: Monad m => (a -> m b) -> (c,a) -> m (c,b)+secondM f (a,c) = (a,) <$> f c+{-# INLINE secondM #-}++dropEnd :: Int -> [a] -> [a]+dropEnd v a = take (length a - v) a -- take of a negative is the empty sequence, which is correct in this case+{-# INLINE dropEnd #-}++#ifdef WINDOWS+-- Windows-compatible reimplementation of safeio's withOutputFile+-- (Note that this is not as complete as safeio as it does not sync the+-- directory).+withOutputFile :: FilePath -> (Handle -> IO a) -> IO a+withOutputFile fp act = do+    (fp', h) <- tempFileFor fp+    act h+    closeAndRename h fp' fp+#endif
+ NGLess/Utils/Vector.hs view
@@ -0,0 +1,111 @@+{- Copyright 2015-2019 NGLess Authors+ - License: MIT+ -}++module Utils.Vector+ ( unsafeIncrement+ , unsafeIncrement'++ , binarySearch+ , binarySearchBy+ , binarySearchByRange+ , binarySearchByExact++ , binaryFindBy++ , sortParallel++ , withVector+ ) where++import           Control.Monad (guard)+import           Control.Monad.Primitive (PrimMonad(..))+import           Control.Monad.IO.Class (MonadIO(..), liftIO)+import qualified Control.Concurrent.Async as A+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import qualified Data.Vector.Generic.Mutable as VGM+import           Data.Vector.Algorithms.Intro (sortByBounds)++-- | increment by 1+unsafeIncrement :: (Num a, PrimMonad m, VUM.Unbox a) => VUM.MVector (PrimState m) a -> Int -> m ()+unsafeIncrement v i = unsafeIncrement' v i 1+{-# INLINE unsafeIncrement #-}++-- | increment by given value+unsafeIncrement' :: (Num a, PrimMonad m, VUM.Unbox a) => VUM.MVector (PrimState m) a -> Int -> a -> m ()+unsafeIncrement' v i inc = VUM.unsafeModify v (+ inc) i+{-# INLINE unsafeIncrement' #-}++binarySearch :: (Ord a) => V.Vector a -> a -> Int+binarySearch v = binarySearchByRange 0 (V.length v) compare v++binarySearchByRange :: Int -> Int -> (a -> b -> Ordering) -> V.Vector a -> b -> Int+binarySearchByRange start end comp v target = loop start end+    where+        loop :: Int -> Int -> Int+        loop s e+            | s == e = s+            | otherwise = let mid = (s + e) `div` 2+                            in if comp (V.unsafeIndex v mid) target == LT+                                    then loop (mid + 1) e+                                    else loop s mid+binarySearchBy :: (a -> b -> Ordering) -> V.Vector a -> b -> Int+binarySearchBy comp v = binarySearchByRange 0 (V.length v) comp v++binarySearchByExact :: (a -> b -> Ordering) -> V.Vector a -> b -> Maybe Int+binarySearchByExact comp v target = do+    let ix = binarySearchBy comp v target+    guard (ix < V.length v)+    guard (comp (V.unsafeIndex v ix) target == EQ)+    return ix++binaryFindBy :: (a -> b -> Ordering) -> V.Vector a -> b -> Maybe a+binaryFindBy comp v target = do+    ix <- binarySearchByExact comp v target+    return $! V.unsafeIndex v ix+++-- sort a vector in parallel threads+sortParallel :: (Ord e) =>+                        Int -- ^ nr of threads+                        -> VM.IOVector e -- ^ vector+                        -> IO ()+sortParallel n v = sortPByBounds n v 0 (VM.length v)++sortPByBounds :: (Ord e) => Int -> VM.IOVector e -> Int -> Int -> IO ()+sortPByBounds 1 v start end = sortByBounds compare v start end+sortPByBounds threads v start end+    | end - start < 1024 = sortByBounds compare v start end+    | otherwise = do+        mid <- pivot v start end+        k <- unstablePartition (< mid) v start end+        let t1 :: Int+            t1+                | k - start < 1024 = 1+                | end - k < 1024 = threads - 1+                | otherwise = threads `div` 2+            t2 = threads - t1+        A.concurrently_+            (sortPByBounds t1 v start k)+            (sortPByBounds t2 v k end)++pivot v start end = do+        a <- VM.read v start+        b <- VM.read v (end - 1)+        c <- VM.read v ((start + end) `div` 2)+        return $! median a b c+    where+        median a b c = if a <= b+            then min b c+            else max a c++unstablePartition f v start end = (+ start) <$> VGM.unstablePartition f (VM.unsafeSlice start (end - start) v)+++withVector :: (MonadIO m, VUM.Unbox a) => VUM.IOVector a -> (VU.Vector a -> b) -> m b+withVector v f = liftIO $ do+    v' <- VU.unsafeFreeze v+    return $! f v'
+ NGLess/Validation.hs view
@@ -0,0 +1,359 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE FlexibleContexts #-}++module Validation+    ( validate+    , uses_STDOUT+    ) where++import qualified Data.Text as T+import qualified Data.Text.Read as T+import           Data.Either.Combinators (rightToMaybe)+import           Control.Monad.Extra (whenJust)+import           Control.Monad.Writer.Strict+import           Control.Monad.RWS+import           Data.List (find, isSuffixOf)+import           Data.Maybe+import           Data.Char (isUpper)+import           Data.Foldable (asum)++import Language+import Modules+import NGLess.NGError+import BuiltinFunctions (MethodInfo(..), builtinMethods, findFunction)+import Utils.Suggestion+++findMethod :: MethodName -> Maybe MethodInfo+findMethod m = find ((==m) . methodName) builtinMethods++-- | Returns either an error message if it finds any errors or the input script unscathed+validate :: [Module] -> Script -> NGLess Script+validate mods expr = case errors of+        [] -> Right expr+        _ -> throwScriptError . concat . addNL . map T.unpack $ errors+    where+        addNL [] = []+        addNL [e] = [e]+        addNL (e:es) = e:"\n":addNL es+        errors = concatMap (\f -> execWriter (f mods expr)) checks+        checks :: [[Module] -> Script -> Writer [T.Text] ()]+        checks =+            [validateVariables+            ,validateFunctionReqArgs -- check for the existence of required arguments in functions.+            ,validateSymbolInArgs+            ,validateSTDINusedOnce+            ,validateMapRef+            ,validateNoConstantAssignments+            ,validateNGLessVersionUses+            ,validatePureFunctions+            ,validateWriteOName+            ,validateBlockAssignments+            ]++{- Each checking function has the type+ -+ - Script -> Maybe T.Text+ -+ - If it finds an error, it returns a Just error; otherwise, Nothing.+ -+ - The validate function just runs all checks and either concatenates all the+ - error messages or passes the script unharmed on the Right side.+ -}+++-- | check whether results of calling pure functions are use+validatePureFunctions mods (Script h es) =+        forM_ es $ \(lno, expr) -> case expr of+            FunctionCall (FuncName "preprocess") _ _ _+                | not (version00 h) -> tell1lno lno ["Preprocess must be assigned to an output (behaviour changed from version 0.0)"]+                | otherwise -> return ()+            FunctionCall fname@(FuncName f) _ _ _+                | isPure fname -> tell1lno lno ["Result of calling function `",  f, "` should be assigned to a variable (this function has no effect otherwise)."]+            _ -> return ()++    where+        isPure f = FunctionCheckReturnAssigned `elem` (fromMaybe [] $ funcChecks <$> findFunction mods f)+        version00 (Just (Header "0.0" _)) = True+        version00 _ = False++validateFunctionReqArgs :: [Module] -> Script -> Writer [T.Text] ()+validateFunctionReqArgs mods = checkRecursiveScript validateFunctionReqArgs'+    where+        validateFunctionReqArgs' (FunctionCall f _ args _) = case findFunction mods f of+                Nothing -> Just (T.concat ["Function ", T.pack . show $ f, " not found."])+                Just finfo -> errors_from_list $ map has1 (funcKwArgs finfo)+                    where+                        used = map (\(Variable k, _) -> k) args+                        has1 ainfo = if not (argRequired ainfo) || argName ainfo `elem` used+                            then Nothing+                            else Just (T.concat ["Function ", T.pack . show $ f, " requires argument ", argName ainfo, "."])+        validateFunctionReqArgs' _ = Nothing++validateVariables :: [Module] -> Script -> Writer [T.Text] ()+validateVariables mods (Script _ es) = runChecker $ forM_ es $ \(_,e) -> case e of+        Assignment (Variable v) e' -> do+            vs <- get+            recursiveAnalyse checkVarUsage e'+            put (v:vs)+        _ -> recursiveAnalyse checkVarUsage e+    where+        runChecker :: RWS () [T.Text] [T.Text] () -> Writer [T.Text] ()+        runChecker c = tell . snd . evalRWS c () $ (fst <$> concatMap modConstants mods)+        checkVarUsage :: Expression -> RWS () [T.Text] [T.Text] ()+        checkVarUsage (Lookup _ (Variable v)) = do+                used <- get+                when (v `notElem` used) $+                    tell [T.concat ["Could not find variable `", T.pack . show $v, "`. ", suggestionMessage v used]]+        checkVarUsage (FunctionCall _ _ _ (Just block)) = do+            vs <- get+            let Variable v' = blockVariable block+            put (v':vs)+        checkVarUsage (Assignment (Variable v) _) = do+            vs <- get+            put (v:vs)+        checkVarUsage _ = return ()++validateSymbolInArgs :: [Module] -> Script -> Writer [T.Text] ()+validateSymbolInArgs mods = checkRecursiveScriptWriter validateSymbolInArgs'+    where+        validateSymbolInArgs' (FunctionCall f _ args _) = checkFunction f args+        validateSymbolInArgs' (MethodCall m _ arg0 args) = checkMethod m arg0 args+        validateSymbolInArgs' _ = return ()++        checkFunction :: FuncName -> [(Variable, Expression)]-> Writer [T.Text] ()+        checkFunction f args = case findFunction mods f of+                Nothing -> tell [T.concat ["Function '", T.pack . show $ f, "' not found"]]+                Just finfo -> mapM_ (check1 finfo) args+            where+                check1 finfo (Variable v, expr) = let legal = allowedFunction finfo v in case expr of+                        ConstSymbol s+                            | s `notElem` legal -> tell . (:[]) . T.concat $+                                case findSuggestion s legal of+                                    Nothing ->+                                        ["Argument: `", v, "` (for function ", T.pack (show f), ") expects one of ", showA legal, " but got {", s, "}"]+                                    Just (Suggestion valid reason) ->+                                        ["Argument `", v, "` for function ", T.pack (show f), ", got {", s, "}.\n\tDid you mean {", valid, "} (", reason, ")\n\n",+                                        "Legal arguments are: [", showA legal, "]\n"]+                        ListExpression es   -> mapM_ (\e -> check1 finfo (Variable v, e)) es+                        _                   -> return ()++        allowedFunction :: Function -> T.Text -> [T.Text]+        allowedFunction finfo v = fromMaybe [] $ do+            argInfo <- find ((==v) . argName) (funcKwArgs finfo)+            ArgCheckSymbol ss <- find (\case { ArgCheckSymbol{} -> True; _ -> False }) (argChecks argInfo)+            return ss+++        allowedMethod minfo v = fromMaybe [] $ do+            argInfo <- find ((==v) . argName) (methodKwargsInfo minfo)+            ArgCheckSymbol ss <- find (\case { ArgCheckSymbol{} -> True; _ -> False}) (argChecks argInfo)+            return ss++        checkMethod m (Just a) args = checkMethod m Nothing ((Variable "__0", a):args)+        checkMethod m Nothing args = case findMethod m of+                Nothing -> tell [T.concat ["Method'", T.pack . show $ m, "' not found"]]+                Just minfo -> mapM_ (check1m minfo) args+            where+                check1m minfo (Variable v, expr) = let legal = allowedMethod minfo v in case expr of+                    ConstSymbol s+                        | s `notElem` legal ->  tell . (:[]) . T.concat $+                            case findSuggestion s legal of+                                Nothing ->+                                    (if v /= "__0" then ["Argument `", v, "` "] else ["Unnamed argument "]) ++ ["(for method ", unwrapMethodName m, ") expects one of ", showA legal, " but got {", s, "}"]+                                Just (Suggestion valid reason) ->+                                    (if v /= "__0" then ["Argument `", v, "` "] else ["Unnamed argument "]) ++ ["(for method ", unwrapMethodName m, ") got {", s, "}"] +++                                        ["\n\tDid you mean {", valid, "} (", reason, ")\n\nAllowed arguments are: [", showA legal, "]"]+                    ListExpression es   -> mapM_ (\e -> check1m minfo (Variable v, e)) es+                    _                   -> return ()++        showA [] = ""+        showA [e] = T.concat ["{", e, "}"]+        showA (e:es) = T.concat ["{", e, "}, ", showA es]++++validateMapRef :: [Module] -> Script -> Writer [T.Text] ()+validateMapRef _ = checkRecursiveScript validateMapRef'+    where+        validateMapRef' (FunctionCall (FuncName "map") _ args _) =+            case (lookup (Variable "reference") args, lookup (Variable "fafile") args) of+                (Nothing, Nothing) -> Just "Either fafile or reference must be specified in argument to map function"+                (Just _, Just _) -> Just "You cannot specify both fafile and reference in arguments to map function"+                _ -> Nothing+        validateMapRef' _ = Nothing++validateWriteOName :: [Module] -> Script -> Writer [T.Text] ()+validateWriteOName _ = checkRecursiveScript $ validateWriteOName'+    where+        validateWriteOName' (FunctionCall (FuncName "write") (Lookup (Just t) _) args _) =+            lookup (Variable "oname") args >>= staticValue >>= \case+                NGOString oname -> case lookup (Variable "format") args of+                    Nothing -> checkType t (T.unpack oname)+                    Just _ -> Nothing+                _ -> Nothing+        validateWriteOName' _ = Nothing+        checkType NGLReadSet oname+            | isSuffixOf ".fa" oname = Just "Cannot save data in FASTA format."+            | isSuffixOf ".fq" oname = Nothing+            | isSuffixOf ".fq.gz" oname = Nothing+            | otherwise = Just . T.concat $ ["Cannot determine output format from filename '", T.pack oname, "'"]+        checkType _ _ = Nothing+++validateSTDINusedOnce :: [Module] -> Script -> Writer [T.Text] ()+validateSTDINusedOnce _ (Script _ code) = foldM_ validateSTDINusedOnce' Nothing code+    where+        validateSTDINusedOnce' :: Maybe Int -> (Int, Expression) -> Writer [T.Text] (Maybe Int)+        validateSTDINusedOnce' s (lno,e)+            | constant_used "STDIN" e = do+                whenJust s $ \prev ->+                    tell1lno lno ["STDIN can only be used once (previously used on line ", T.pack (show prev), ")."]+                return $ Just lno+            | otherwise = return s+++constant_used :: T.Text -> Expression -> Bool+constant_used k (BuiltinConstant (Variable k')) = k == k'+constant_used k (ListExpression es) = constant_used k `any` es+constant_used k (UnaryOp _ e) = constant_used k e+constant_used k (BinaryOp _ a b) = constant_used k a || constant_used k b+constant_used k (Condition a b c) = constant_used k a || constant_used k b || constant_used k c+constant_used k (IndexExpression a ix) = constant_used k a || constant_used_ix k ix+constant_used k (Assignment _ e) = constant_used k e+constant_used k (FunctionCall _ e args b) = constant_used k e || constant_used k `any` [e' | (_,e') <- args] || constant_used_block k b+constant_used k (Sequence es) = constant_used k `any` es+constant_used _ _ = False+constant_used_ix k (IndexOne a) = constant_used k a+constant_used_ix k (IndexTwo a b) = constant_used_maybe k a || constant_used_maybe k b+constant_used_maybe k (Just e) = constant_used k e+constant_used_maybe _ Nothing = False+constant_used_block k (Just (Block _ e)) = constant_used k e+constant_used_block _ _ = False++uses_STDOUT :: Expression -> Bool+uses_STDOUT = constant_used "STDOUT"++validateNoConstantAssignments :: [Module] -> Script -> Writer [T.Text] ()+validateNoConstantAssignments mods (Script _ es) = foldM_ checkAssign builtins es+    where+        checkAssign active (lno,e) = case e of+            Assignment (Variable v) _ -> do+                when (v `elem` active) $+                    tell1lno lno ["assignment to constant `", v, "` is illegal."]+                return $ if T.all isUpper v+                            then v:active+                            else active+            _ -> return active+        builtins = ["STDIN", "STDOUT"] ++ (fst <$> concatMap modConstants mods)+++addLno lno errs = [T.concat ["Error on line ", T.pack (show lno), ": ", e] | e <- errs]++checkRecursiveScriptWriter :: (Expression -> Writer [T.Text] ()) -> Script -> Writer [T.Text] ()+checkRecursiveScriptWriter f (Script _ es) = forM_ es $ \(lno, e) ->+        censor (addLno lno) $ recursiveAnalyse f e++checkRecursiveScript :: (Expression -> Maybe T.Text) -> Script -> Writer [T.Text] ()+checkRecursiveScript f (Script _ es) = forM_ es $ \(lno, e) ->+        censor (addLno lno) $ recursiveAnalyse f' e+    where+        f' :: Expression -> Writer [T.Text] ()+        f' e' = whenJust (f e') (tell . (:[]))++errors_from_list :: [Maybe T.Text] -> Maybe T.Text+errors_from_list errs = case catMaybes errs of+    [] -> Nothing+    errs' -> Just (T.concat errs')++tell1lno :: Int -> [T.Text] -> Writer [T.Text] ()+tell1lno lno err = tell [T.concat $ ["Line ", T.pack (show lno), ": "] ++ err]++validateNGLessVersionUses :: [Module] -> Script -> Writer [T.Text] ()+validateNGLessVersionUses mods sc = case nglVersion <$> nglHeader sc of+        Nothing -> return ()+        Just version -> forM_ (nglBody sc) $ \(lno, expr) ->+            recursiveAnalyse (check version lno) expr+    where+        check :: T.Text -> Int -> Expression -> Writer [T.Text] ()+        check version lno f = case f of+                FunctionCall fname@(FuncName fname') _ kwargs _ ->+                    whenJust (findFunction mods fname) $ \finfo -> do+                        checkVersion ["Function ", fname'] $ minVersionFunction finfo+                        checkVersionChanged ["Function ", fname'] $ minVersionFunctionChanged finfo+                        forM_ kwargs $ \(Variable name,_) ->+                            checkVersion ["Using argument ", name, " to function ", fname'] $ checkArg (funcKwArgs finfo) name+                MethodCall mname@(MethodName mname') _ _ kwargs ->+                    whenJust (findMethod mname) $ \minfo -> do+                        checkVersion ["Using method ", mname'] $ minVersionMethod minfo+                        forM_ kwargs $ \(Variable name, _) ->+                            checkVersion ["Using argument ", name, " to method ", mname'] $ checkArg (methodKwargsInfo minfo) name+                _ -> return ()+            where+                showV (a,b) = T.pack (show a ++ "." ++ show b)+                checkVersion _ Nothing = return ()+                checkVersion prefix (Just minV)+                    | versionLE minV version = return ()+                    | otherwise = tell1lno lno (prefix ++ [" requires ngless version ", showV minV, " (version '", version, "' is active)."])+                checkVersionChanged _ Nothing = return ()+                checkVersionChanged prefix (Just (minV, r))+                    | versionLE minV version = return ()+                    | otherwise = tell1lno lno (prefix +++                            [" changed behaviour in an incompatible fashion in version ", showV minV, " (version '", version, "' is active).\n", r,+                            "\n\nSee https://ngless.embl.de/whatsnew.html for details on changes."])+        minVersionFunction :: Function -> Maybe (Int, Int)+        minVersionFunction finfo =+            asum $ flip map (funcChecks finfo) $ \case+                            FunctionCheckMinNGLessVersion minV -> Just minV+                            _ -> Nothing++        minVersionFunctionChanged :: Function -> Maybe ((Int, Int), T.Text)+        minVersionFunctionChanged finfo =+            asum $ flip map (funcChecks finfo) $ \case+                            FunctionCheckNGLVersionIncompatibleChange minV r -> Just (minV, r)+                            _ -> Nothing++        minVersionMethod :: MethodInfo -> Maybe (Int, Int)+        minVersionMethod minfo =+            asum $ flip map (methodChecks minfo) $ \case+                            FunctionCheckMinNGLessVersion minV -> Just minV+                            _ -> Nothing++        checkArg :: [ArgInformation] -> T.Text -> Maybe (Int, Int)+        checkArg ainfos argname = do+            ainfo <- find ((== argname) . argName) ainfos+            minVersion (argChecks ainfo)++        minVersion [] = Nothing+        minVersion (ArgCheckMinVersion minV:_) = Just minV+        minVersion (_:rs) = minVersion rs+        versionLE (majV, minV) actual = case parseVersion actual of+            Just (aMaj, aMin) -> case aMaj `compare` majV of+                GT -> True+                EQ -> aMin >= minV+                LT -> False+            _ -> False+        parseVersion :: T.Text -> Maybe (Int, Int)+        parseVersion version = do+            (majV, rest) <- rightToMaybe $ T.decimal version+            guard $ not (T.null rest)+            (minV, _) <- rightToMaybe $ T.decimal (T.tail rest)+            return (majV, minV)+++-- Check that only block variables are assigned inside a block+validateBlockAssignments :: [Module] -> Script -> Writer [T.Text] ()+validateBlockAssignments _ (Script _ es) = forM_ es validateBlockAssignments1+validateBlockAssignments1 :: (Int, Expression) -> Writer [T.Text] ()+validateBlockAssignments1 (lno, e) = case e of+    Assignment _ e' -> validateBlockAssignments1 (lno, e')+    FunctionCall (FuncName fname)  _ _ (Just block) -> let var = blockVariable block+                                        in recursiveAnalyse (checkAssignmentOnlyTo fname lno var) (blockBody block)+    _ -> return ()+checkAssignmentOnlyTo fname lno v@(Variable n) e = case e of+    Assignment v' _+        | v /= v' -> tell1lno lno ["Inside blocks, only the block variable (in this case `", n, "`) can be assigned to",+                                    " (when analysing function `", fname, "`)."]+    _ -> return ()
+ NGLess/ValidationIO.hs view
@@ -0,0 +1,159 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}++module ValidationIO+    ( validateIO+    ) where++import System.Directory+import Data.Maybe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Trans.Writer+import qualified Data.Text as T+import           Control.Monad.Extra (whenJust, whenM)++import NGLess+import Output+import Modules+import Language+import BuiltinFunctions (findFunction)+import FileManagement+import Utils.Suggestion+import ReferenceDatabases+import BuiltinModules.Checks+import Interpretation.Count (executeCountCheck)+++-- validation functions live in this Monad, where error messages can be written+type ValidateIO = WriterT [T.Text] (ReaderT [Module] NGLessIO)+liftNGLessIO = lift . lift+tell1 = tell . (:[])++findFunctionIO :: FuncName -> ValidateIO Function+findFunctionIO fname = asks (flip findFunction fname) >>= \case+    Just finfo -> return finfo+    Nothing -> throwShouldNotOccur ("Cannot find information for function: " ++ show fname)++-- | Run as many checks as possible (including non-pure, IO consuming, checks)+validateIO :: [Module] -> Script -> NGLessIO (Maybe [T.Text])+validateIO mods sc = do+        err <- runReaderT (execWriterT (mapM ($sc) checks)) mods+        case err of+            [] -> return Nothing+            errors -> return (Just errors)+    where+        checks =+            [validateReadInputs+            ,validateOFile+            ,checkReferencesExist+            ,validateCount+            ]+++-- | check that necessary files exist+validateReadInputs :: Script -> ValidateIO ()+validateReadInputs (Script _ es) = checkRecursive validateReadInputs' es+    where+        validateReadInputs' :: Expression -> ValidateIO ()+        validateReadInputs' (FunctionCall f expr args _) = do+            finfo <- findFunctionIO f+            when (ArgCheckFileReadable `elem` funcArgChecks finfo) $+                validateStrVal checkFileReadable' es expr+            forM_ (funcKwArgs finfo) $ \ainfo ->+                when (ArgCheckFileReadable `elem` argChecks ainfo) $+                   validateStrArg checkFileReadable' (argName ainfo) args es+        validateReadInputs' _ = return ()++        checkFileReadable' :: T.Text -> ValidateIO ()+        checkFileReadable' fname =+            (liftNGLessIO . expandPath $ T.unpack fname) >>= \case+                Just p -> liftIO (checkFileReadable p) >>= flip whenJust tell1+                Nothing -> tell1 $ T.concat ["Could not find necessary input file ", fname]+++checkReferencesExist :: Script -> ValidateIO ()+checkReferencesExist (Script _ es) = flip checkRecursive es $ \case+        (FunctionCall (FuncName "map") _ args _) -> validateStrArg check1 "reference" args es+        _ -> return ()+    where+        check1 :: T.Text -> ValidateIO ()+        check1 r = do+            mods <- ask+            let refs = concatMap modReferences mods+                ename (ExternalPackagedReference er) = refName er+                ename er = erefName er+                allnames = (ename <$> refs) ++ (refName <$> builtinReferences) ++ mapMaybe refAlias builtinReferences+            unless (r `elem` allnames) $ do+                exists <- liftIO $ doesFileExist (T.unpack r)+                tell1 . T.concat $ [+                            "Could not find reference ", r, " (it is neither built in nor in any of the loaded modules).\n"+                            ] ++ (if exists+                                    then ["\n\tDid you mean to use the argument `fafile` to specify the FASTA file `", r, "`?\n",+                                          "\tmap() uses the argument `reference` for builtin references and `fafile` for a FASTA file path."]+                                    else [])+                            ++ [suggestionMessage r allnames,+                                "\n\tValid options are:"]+                            ++ [T.concat ["\n\t\t - ", v] | v <- allnames]++++validateStrArg :: (T.Text -> ValidateIO ()) -> T.Text -> [(Variable,Expression)] -> [(Int,Expression)] -> ValidateIO ()+validateStrArg f v args es = whenJust (lookup (Variable v) args) $ validateStrVal f es++validateStrVal :: (T.Text -> ValidateIO ()) -> [(Int,Expression)] -> Expression -> ValidateIO ()+validateStrVal f _ (ConstStr v) = f v+validateStrVal f es (Lookup _ v) = case tryConstValue v es of+    Just (NGOString t)  -> f t+    _ -> return ()+validateStrVal _ _ _ = return ()++tryConstValue :: Variable -> [(Int,Expression)] -> Maybe NGLessObject+tryConstValue var s = case mapMaybe (getAssignment . snd) s of+        [val] -> Just val+        _ -> Nothing+    where+        getAssignment :: Expression -> Maybe NGLessObject+        getAssignment (Assignment v val) | v == var = staticValue val+        getAssignment _ = Nothing+++checkRecursive :: (Expression -> ValidateIO ()) -> [(Int,Expression)] -> ValidateIO ()+checkRecursive f es = forM_ es $ \(lno, e) ->+        censor (addLno lno) (recursiveAnalyse f e)+    where+        addLno lno = map (addLno1 lno)+        addLno1 lno err = T.concat ["Line ", T.pack (show lno), ": ", err]+++validateOFile (Script _ es) = checkRecursive validateOFile' es+    where+        validateOFile' (FunctionCall f expr args _) = do+            finfo <- findFunctionIO f+            when (ArgCheckFileWritable `elem` funcArgChecks finfo) $+                validateStrVal checkOFileV es expr+            forM_ (funcKwArgs finfo) $ \ainfo ->+                when (ArgCheckFileWritable `elem` argChecks ainfo) $+                   validateStrArg checkOFileV (argName ainfo) args es+        validateOFile' _ = return ()++checkOFileV :: T.Text -> ValidateIO ()+checkOFileV ofile = do+    errors <- liftIO (checkOFile ofile)+    whenJust errors tell1+    let ofile' = T.unpack ofile+    whenM (liftIO $ doesFileExist ofile') $+        liftNGLessIO $ outputListLno' WarningOutput ["Writing to file '", ofile', "' will overwrite existing file."]++{- Attempt to run executeCountCheck in the validation stage+ -}+validateCount (Script _ es) = checkRecursive validateCount' es+    where+        validateCount' (FunctionCall (FuncName "count") _ kwargs Nothing) =+            whenJust (constantKWArgs kwargs) (void . liftNGLessIO . executeCountCheck NGOVoid)+        validateCount' _ = return ()+        constantKWArgs :: [(Variable, Expression)] -> Maybe KwArgsValues+        constantKWArgs = mapM $ \(Variable v, e) -> (v,) <$> staticValue e+
+ NGLess/Version.hs view
@@ -0,0 +1,31 @@+{- Copyright 2013-2022 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE CPP #-}+module Version+    ( versionStr+    , versionStrLong+    , dateStr+    , embeddedStr+    ) where++import Data.Version (showVersion)++import Paths_NGLess (version)++versionStr :: String+versionStr = showVersion version++versionStrLong :: String+versionStrLong = "1.4.0"++dateStr :: String+dateStr = "May 30 2022"++embeddedStr :: String+#ifdef NO_EMBED_SAMTOOLS_BWA+embeddedStr = "No"+#else+embeddedStr = "Yes"+#endif+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests-Src/Tests.hs view
@@ -0,0 +1,278 @@+{- Copyright 2013-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+-- | Unit tests are their own programme.+--+-- Unit tests written in Haskell have less overhead than full integration tests+-- in the tests/ directory, but are not always as convenient.++module Main where++import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.HUnit+import Text.Parsec (parse)+import Text.Parsec.Combinator (eof)++import System.Directory (removeDirectoryRecursive)+import qualified Data.Vector.Storable as VS+import qualified Data.ByteString.Char8 as B++import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import           Control.Monad.State.Strict (execState, modify')+import           Data.Convertible (convert)+import           Data.Conduit.Algorithms.Async (conduitPossiblyCompressedFile)++import Language+import Interpret+import Tokens+import FileManagement+import NGLess+import NGLess.NGLEnvironment (setupTestEnvironment)++import Interpretation.Unique++import Data.Sam+import Data.FastQ+import Utils.Conduit+import Utils.Samtools (samBamConduit)+import Utils.Here+import qualified Data.GFF as GFF++import Tests.Utils+import Tests.Count (tgroup_Count)+import Tests.FastQ (tgroup_FastQ)+import Tests.IntGroups (tgroup_IntGroups)+import Tests.Language (tgroup_Language)+import Tests.LoadFQDirectory (tgroup_LoadFQDirectory)+import Tests.NGLessAPI (tgroup_NGLessAPI)+import Tests.Parse (tgroup_Parse)+import Tests.Select (tgroup_Select)+import Tests.Types (tgroup_Types)+import Tests.Validation (tgroup_Validation)+import Tests.Vector (tgroup_Vector)+import Tests.Write (tgroup_Write)++test_FastQ      = [tgroup_FastQ]+test_Validation = [tgroup_Validation]+test_Count      = [tgroup_Count]+test_Parse      = [tgroup_Parse]+test_Types      = [tgroup_Types]+test_NGLessAPI  = [tgroup_NGLessAPI]+test_Vector     = [tgroup_Vector]+test_IntGroups  = [tgroup_IntGroups]+test_Select     = [tgroup_Select]+test_Language   = [tgroup_Language]+test_LoadFqDir  = [tgroup_LoadFQDirectory]+test_Write      = [tgroup_Write]++-- The main test driver sets up the config options then uses the automatically+-- generated function+main = do+    setupTestEnvironment+    $(defaultMainGenerator)+    removeDirectoryRecursive "testing_directory_tmp"++-- Test Tokens module+tokenize' fn t = map snd <$> (tokenize fn t)++case_tok_cr = TNewLine @=? (case parse (Tokens.eol <* eof) "test" "\r\n" of { Right t -> t; Left _ -> error "Parse failed"; })+case_tok_single_line_comment = tokenize' "test" with_comment @?= Right expected+    where+        with_comment = "a=0# comment\nb=1\n"+        expected = [TWord "a",TOperator '=',TExpr (ConstInt 0),TNewLine,TWord "b",TOperator '=',TExpr (ConstInt 1),TNewLine]++case_tok_single_line_comment_cstyle = tokenize' "test" with_comment @?= Right expected+    where+        with_comment = "a=0// comment\nb=1\n"+        expected = [TWord "a",TOperator '=',TExpr (ConstInt 0),TNewLine,TWord "b",TOperator '=',TExpr (ConstInt 1),TNewLine]++case_tok_multi_line_comment = tokenize' "test" with_comment @?= Right expected+    where+        with_comment = "a=0/* This\n\nwith\nlines*/\nb=1\n"+        expected = [TWord "a",TOperator '=',TExpr (ConstInt 0),TIndent 0,TNewLine,TWord "b",TOperator '=',TExpr (ConstInt 1),TNewLine]++case_tok_word_ = tokenize' "test" "word_with_underscore" @?= Right expected+    where+        expected = [TWord "word_with_underscore"]++++-- Test Types+case_indent_comment = isOk "ParseFailed" $ parsetest indent_comment+case_indent_space = isOk "ParseFailed" $ parsetest indent_space++indent_comment = "ngless '0.0'\n\+    \reads = fastq('input1.fq')\n\+    \reads = preprocess(reads) using |read|:\n\+    \    read = read[5:]\n\+    \    # comment \n"++indent_space  = "ngless '0.0'\n\+    \reads = fastq('input1.fq')\n\+    \reads = preprocess(reads) using |read|:\n\+    \    read = read[5:]\n\+    \    \n"+++-- Type Validate pre process operations+sr i s q = NGOShortRead (ShortRead i s $ VS.generate (B.length q) (convert . B.index q))++case_pre_process_indexation_1 = _evalIndex' (sr "@IRIS" "AGTACCAA" "aa`aaaaa") [Just (NGOInteger 5), Nothing] @?= (sr "@IRIS" "CAA" "aaa")+case_pre_process_indexation_2 = _evalIndex' (sr "@IRIS" "AGTACCAA" "aa`aaaaa") [Nothing, Just (NGOInteger 3)] @?= (sr "@IRIS" "AGT" "aa`")+case_pre_process_indexation_3 = _evalIndex' (sr "@IRIS" "AGTACCAA" "aa`aaaaa") [Just (NGOInteger 2), Just (NGOInteger 5)] @?= (sr "@IRIS" "TAC" "`aa")++_evalIndex' a b = case _evalIndex a b of+    Right v -> v+    Left err -> error (show err)++case_pre_process_length_1 = _evalUnary UOpLen (sr "@IRIS" "AGTACCAA" "aa`aaaaa") @?= Right (NGOInteger 8)++case_bop_gte_1 = evalBinary BOpGTE (NGOInteger 10) (NGOInteger 10) @?= Right (NGOBool True)+case_bop_gte_2 = evalBinary BOpGTE (NGOInteger 11) (NGOInteger 10) @?= Right (NGOBool True)+case_bop_gte_3 = evalBinary BOpGTE (NGOInteger 10) (NGOInteger 11) @?= Right (NGOBool False)++case_bop_gt_1 = evalBinary BOpGT (NGOInteger 10) (NGOInteger 10) @?= Right (NGOBool False)+case_bop_gt_2 = evalBinary BOpGT (NGOInteger 11) (NGOInteger 10) @?= Right (NGOBool True)+case_bop_gt_3 = evalBinary BOpGT (NGOInteger 10) (NGOInteger 11) @?= Right (NGOBool False)++case_bop_lt_1 = evalBinary BOpLT (NGOInteger 10) (NGOInteger 10) @?= Right (NGOBool False)+case_bop_lt_2 = evalBinary BOpLT (NGOInteger 11) (NGOInteger 10) @?= Right (NGOBool False)+case_bop_lt_3 = evalBinary BOpLT (NGOInteger 10) (NGOInteger 11) @?= Right (NGOBool True)++case_bop_lte_1 = evalBinary BOpLTE (NGOInteger 10) (NGOInteger 10) @?= Right (NGOBool True)+case_bop_lte_2 = evalBinary BOpLTE (NGOInteger 11) (NGOInteger 10) @?= Right (NGOBool False)+case_bop_lte_3 = evalBinary BOpLTE (NGOInteger 10) (NGOInteger 11) @?= Right (NGOBool True)++case_bop_eq_1 = evalBinary BOpEQ (NGOInteger 10) (NGOInteger 10) @?= Right (NGOBool True)+case_bop_eq_2 = evalBinary BOpEQ (NGOInteger 10) (NGOInteger 0) @?= Right (NGOBool False)++case_bop_neq_1 = evalBinary BOpNEQ (NGOInteger 0) (NGOInteger 10) @?= Right (NGOBool True)+case_bop_neq_2 = evalBinary BOpNEQ (NGOInteger 10) (NGOInteger 10) @?= Right (NGOBool False)++case_bop_add_1 = evalBinary BOpAdd (NGOInteger 0) (NGOInteger 10) @?= Right (NGOInteger 10)+case_bop_add_2 = evalBinary BOpAdd (NGOInteger 10) (NGOInteger 0) @?= Right (NGOInteger 10)+case_bop_add_3 = evalBinary BOpAdd (NGOInteger 10) (NGOInteger 10) @?= Right (NGOInteger 20)++case_bop_mul_1 = evalBinary BOpMul (NGOInteger 0) (NGOInteger 10) @?= Right (NGOInteger 0)+case_bop_mul_2 = evalBinary BOpMul (NGOInteger 10) (NGOInteger 0) @?= Right (NGOInteger 0)+case_bop_mul_3 = evalBinary BOpMul (NGOInteger 10) (NGOInteger 10) @?= Right (NGOInteger 100)++case_bop_add_path_1 = evalBinary BOpPathAppend (NGOString "dir") (NGOString "file") @?= Right (NGOString "dir/file")+case_bop_add_path_2 = evalBinary BOpPathAppend (NGOString "dir/subdir") (NGOString "file") @?= Right (NGOString "dir/subdir/file")+case_bop_add_path_3 = evalBinary BOpPathAppend (NGOString "dir/subdir/") (NGOString "file") @?= Right (NGOString "dir/subdir/file")+case_bop_add_path_4 = evalBinary BOpPathAppend (NGOString "../dir/subdir/") (NGOString "file") @?= Right (NGOString "../dir/subdir/file")+case_bop_add_path_5 = evalBinary BOpPathAppend (NGOString "/abs/dir/subdir/") (NGOString "file") @?= Right (NGOString "/abs/dir/subdir/file")++case_uop_minus_1 = _evalUnary UOpMinus (NGOInteger 10) @?= Right (NGOInteger (-10))+case_uop_minus_2 = _evalUnary UOpMinus (NGOInteger (-10)) @?= Right (NGOInteger 10)++--++case_template_id = takeBaseNameNoExtensions "a/B/c/d/xpto_1.fq" @?= takeBaseNameNoExtensions "a/B/c/d/xpto_1.fq"+case_template    = takeBaseNameNoExtensions "a/B/c/d/xpto_1.fq" @?= "xpto_1"++samStats :: FilePath -> NGLessIO (Int, Int, Int)+samStats fname = C.runConduit (samBamConduit fname .| linesVC 1024 .| samStatsC) >>= runNGLess++case_sam20 = do+        sam <- testNGLessIO $ asTempFile sam20 "sam"  >>= samStats+        sam @?= (5,0,0)+    where+        sam20 = [here|+@SQ	SN:I	LN:230218+@PG	ID:bwa	PN:bwa	VN:0.7.7-r441	CL:/home/luispedro/.local/share/ngless/bin/ngless-0.0.0-bwa mem -t 1 /home/luispedro/.local/share/ngless/data/sacCer3/Sequence/BWAIndex/reference.fa.gz /tmp/preprocessed_sample20.fq1804289383846930886.gz+IRIS:7:1:17:394#0	4	*	0	0	*	*	0	0	GTCAGGACAAGAAAGACAANTCCAATTNACATT	aaabaa`]baaaaa_aab]D^^`b`aYDW]aba	AS:i:0	XS:i:0+IRIS:7:1:17:800#0	4	*	0	0	*	*	0	0	GGAAACACTACTTAGGCTTATAAGATCNGGTTGCGG	ababbaaabaaaaa`]`ba`]`aaaaYD\\_a``XT	AS:i:0	XS:i:0+IRIS:7:1:17:1757#0	4	*	0	0	*	*	0	0	TTTTCTCGACGATTTCCACTCCTGGTCNAC	aaaaaa``aaa`aaaa_^a```]][Z[DY^	AS:i:0	XS:i:0+IRIS:7:1:17:1479#0	4	*	0	0	*	*	0	0	CATATTGTAGGGTGGATCTCGAAAGATATGAAAGAT	abaaaaa`a```^aaaaa`_]aaa`aaa__a_X]``	AS:i:0	XS:i:0+IRIS:7:1:17:150#0	4	*	0	0	*	*	0	0	TGATGTACTATGCATATGAACTTGTATGCAAAGTGG	abaabaa`aaaaaaa^ba_]]aaa^aaaaa_^][aa	AS:i:0	XS:i:0+|]+-- Parse GFF lines++++case_trim_attrs_1  = GFF._trimString " x = 10" @?= "x = 10"+case_trim_attrs_2  = GFF._trimString " x = 10 " @?= "x = 10"+case_trim_attrs_3  = GFF._trimString "x = 10 " @?= "x = 10"+case_trim_attrs_4  = GFF._trimString "x = 10" @?= "x = 10"+case_trim_attrs_5  = GFF._trimString "   X    " @?= "X"+++case_parse_gff_line = GFF.readGffLine gff_line @?= Right gff_structure+    where+        gff_line = "chrI\tunknown\texon\t4124\t4358\t.\t-\t.\tgene_id \"Y74C9A.3\"; transcript_id \"NM_058260\"; gene_name \"Y74C9A.3\"; p_id \"P23728\"; tss_id \"TSS14501\";"+        gff_structure  = GFF.GffLine "chrI" "unknown" "exon" 4124 4358 Nothing GFF.GffNegStrand (-1) attrsExpected+        attrsExpected = [("gene_id","Y74C9A.3"), ("transcript_id" ,"NM_058260"), ("gene_name", "Y74C9A.3"), ("p_id", "P23728"), ("tss_id", "TSS14501")]++-- _parseGffAttributes+case_parse_gff_atributes_normal_1 = GFF._parseGffAttributes "ID=chrI;dbxref=NCBI:NC_001133;Name=chrI" @?= [("ID","chrI"),("dbxref","NCBI:NC_001133"),("Name","chrI")]+case_parse_gff_atributes_normal_2 = GFF._parseGffAttributes "gene_id=chrI;dbxref=NCBI:NC_001133;Name=chrI" @?= [("gene_id","chrI"),("dbxref","NCBI:NC_001133"),("Name","chrI")]+case_parse_gff_atributes_trail_del = GFF._parseGffAttributes "gene_id=chrI;dbxref=NCBI:NC_001133;Name=chrI;" @?= [("gene_id","chrI"),("dbxref","NCBI:NC_001133"),("Name","chrI")]+case_parse_gff_atributes_trail_del_space = GFF._parseGffAttributes "gene_id=chrI;dbxref=NCBI:NC_001133;Name=chrI; " @?= [("gene_id","chrI"),("dbxref","NCBI:NC_001133"),("Name","chrI")]+++case_calc_sam_stats = testNGLessIO (samStats "test_samples/sample.sam.gz") >>= \r ->+  r @?=  (2772,1310,1299)++--- Unique.hs++--File "test_samples/data_set_repeated.fq" has 216 reads in which 54 are unique.++countC = loop (0 :: Int)+    where+        loop !n = C.await >>= maybe (return n) (const (loop $ n+1))+make_unique_test n = let enc = SolexaEncoding in do+    nuniq <- testNGLessIO $ do+        newfp <- performUnique "test_samples/data_set_repeated.fq" enc n+        C.runConduit $+            conduitPossiblyCompressedFile newfp+                .| linesC+                .| fqDecodeC "testing" enc+                .| countC+    let n' = min n 4+    nuniq @?=  (n' * 54)++case_unique_1 = make_unique_test 1+case_unique_2 = make_unique_test 2+case_unique_3 = make_unique_test 3+case_unique_4 = make_unique_test 4+case_unique_5 = make_unique_test 5+++case_recursiveAnalyze = execState (recursiveAnalyse countFcalls expr) 0 @?= (1 :: Int)+    where+        countFcalls (FunctionCall  _ _ _ _) = modify' (+1)+        countFcalls _ = return ()++        expr = Assignment+                    (Variable "varname")+                    (FunctionCall (FuncName "count")+                        (Lookup Nothing (Variable "mapped"))+                        [(Variable "features", ListExpression [ConstStr "seqname"])+                            ,(Variable "multiple", ConstSymbol "all1")]+                        Nothing)+++case_expand_path = do+    expandPath' "/nothing1/file.txt" [] @?=  ["/nothing1/file.txt"]+    expandPath' "/nothing2/file.txt" [undefined] @?=  ["/nothing2/file.txt"]+    expandPath' "/nothing3/file.txt" ["/home/luispedro/my-directory"] @?=  ["/nothing3/file.txt"]+    expandPath' "<>/nothing4/file.txt" ["/home/luispedro/my-directory1"] @?=  ["/home/luispedro/my-directory1/nothing4/file.txt"]+    expandPath' "<>/nothing4/file.txt" ["refs=/home/luispedro/my-directory1"] @?=  []+    expandPath' "<>/nothing/file.txt" ["/home/luispedro/my-directory"+                                      ,"/home/alternative/your-directory"] @?=  ["/home/luispedro/my-directory/nothing/file.txt"+                                                                                ,"/home/alternative/your-directory/nothing/file.txt"]+    expandPath' "<refs>/nothing/file.txt" ["/home/luispedro/my-directory"+                                      ,"/home/alternative/your-directory"] @?=  ["/home/luispedro/my-directory/nothing/file.txt"+                                                                                ,"/home/alternative/your-directory/nothing/file.txt"]+    expandPath' "<refs>/nothing/file.txt" ["refs=/home/luispedro/my-directory"+                                      ,"/home/alternative/your-directory"] @?=  ["/home/luispedro/my-directory/nothing/file.txt"+                                                                                ,"/home/alternative/your-directory/nothing/file.txt"]+    expandPath' "<refs>/nothing/file.txt" ["refs=/home/luispedro/my-directory"+                                      ,"nope=/home/alternative/your-directory"] @?=  ["/home/luispedro/my-directory/nothing/file.txt"]+    expandPath' "<refs>/nothing/file.txt" ["other=/home/luispedro/my-directory"+                                      ,"nope=/home/alternative/your-directory"] @?=  []+    expandPath' "<refs>/nothing/file.txt" [] @?= []
+ Tests-Src/Tests/Count.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.Count+    ( tgroup_Count+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit++import qualified Data.IntervalIntMap as IM+import qualified Data.Set as S+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Map as M++import qualified Data.Conduit.Combinators as C+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Conduit as C+import           Data.Conduit ((.|))+import Control.Monad.IO.Class (liftIO)+import Data.Maybe++import Interpretation.Count+import qualified Interpretation.Count.RefSeqInfoVector as RSV+import FileOrStream (FileOrStream(..))+import Tests.Utils+import Utils.Here+import NGLess+++tgroup_Count = $(testGroupGenerator)+++readCountFile :: FilePath -> IO (M.Map B.ByteString Double)+readCountFile fp =+    C.runConduitRes $+        C.sourceFile fp+            .| CB.lines+            .| (C.await >> (C.awaitForever C.yield)) -- skip first line+            .| CL.foldMap parseLine+    where+        parseLine line = case B8.split '\t' line of+            [h,val] -> M.singleton h (read $ B8.unpack val)+            _ -> error ("Could not parse line: " ++ show line)+++runSamGffAnnotation:: B.ByteString -> B.ByteString -> CountOpts -> NGLessIO (M.Map B.ByteString Double)+runSamGffAnnotation sam_content gff_content opts = do+    sam_fp <- asTempFile sam_content "sam"+    gff_fp <- asTempFile gff_content "gff"+    ann <- loadAnnotator (AnnotateGFF gff_fp) opts+    p <- performCount (File sam_fp) "testing" ann opts+    liftIO $ readCountFile p++listNub :: (Ord a) => [a] -> [a]+listNub = S.toList . S.fromList++defCountOpts =+    CountOpts+    { optFeatures = []+    , optSubFeatures = Nothing+    , optIntersectMode = annotationRule IntersectUnion+    , optAnnotationMode = AnnotateSeqName+    , optStrandMode = SMBoth+    , optMinCount = 0.0+    , optMMMethod = MMUniqueOnly+    , optDelim = "\t"+    , optNormMode = NMRaw+    , optIncludeMinus1 = False+    }+++extractIds :: [AnnotationInfo] -> [Int]+extractIds = map (\(AnnotationInfo _ ix) -> ix)++very_short_gff = "test_samples/very_short.gtf"+case_load_very_short = do+    [GFFAnnotator immap headers szmap] <- testNGLessIO+                $ loadAnnotator (AnnotateGFF very_short_gff) defCountOpts  { optFeatures = ["gene"] }+    let usedIDs = extractIds $ concatMap IM.elems $ M.elems immap+    length (listNub usedIDs) @?= V.length headers+    minimum usedIDs @?= 0+    maximum usedIDs @?= V.length headers - 1+    VU.length szmap @?= V.length headers+    let mix = do+            ix <- V.elemIndex "WBGene00010199" headers+            return $! szmap VU.! ix+    mix @?= Just (721-119+1)+++short3 :: B.ByteString+short3 = [here|+V	protein_coding	gene	7322	8892	.	-	.	gene_id "WBGene00008825"; gene_name "F14H3.6"; gene_source "ensembl"; gene_biotype "protein_coding";+X	protein_coding	gene	140	218	.	+	.	gene_id "WBGene00020330"; gene_name "T07H6.1"; gene_source "ensembl"; gene_biotype "protein_coding";+X	protein_coding	gene	632	733	.	+	.	gene_id "WBGene00000526"; gene_name "clc-5"; gene_source "ensembl"; gene_biotype "protein_coding";+|]++-- this is a regression test+case_load_gff_order = do+    fp <- testNGLessIO $ asTempFile short3 "gtf"+    [GFFAnnotator immap headers _] <- testNGLessIO+                $ loadAnnotator (AnnotateGFF fp) defCountOpts  { optFeatures = ["gene"] }+    let [h] = extractIds . IM.elems  . fromJust $ M.lookup "V" immap+    (headers V.! h) @?= "WBGene00008825"++short1 :: B.ByteString+short1 = [here|+X	protein_coding	gene	610	1473	.	+	.	gene_id "WBGene00002254"; gene_name "lbp-2"; gene_source "ensembl"; gene_biotype "protein_coding";+|]++short_sam :: B.ByteString+short_sam = [here|+@SQ	SN:X	LN:18942+SRR070372.1096	0	X	1174	60	62S75M1D37M46D58M10S	*	0	0	GTTCTACAACGTCCAGATCGGAAGCAAGTTCGAAGGAGAGGGTCTTGATAACACCAAGCACGAGGTTACCTTCACTCTCAAGGACGGACACTTGTTCGAACATCACAAGCCACTTGAAGAGGGAGAATCCAAGGAAGAACCTATGAGTATTACTTTGATGGAGATTTTCTTATTCAGAAGATGAGCTTCAACAATATCGAAGGCCGCAGATTCTACAAGAGACTCCCATAAAGTTAACTATC	IIIIIIF@@@CIIIIIIIIIIIIIIIIIIIIIHHIIIB=5669CIIIIIIIIIIIIIIIIIIIIIIIIIIHHHIHIIIIIIIIIIIIIIIIIIIHIIIIIIIIIIIIIIIHIH>>>FIIGBB@E??;75444<<:62///1>?BAAAD?AE;72217<AAAA;=/1117//7AADACDDGIEEEEEGGHGD@@@GGGGD@@@@DD@@@DDEBCBEBB@:566?6333;C@@=BAA:?E9911	NM:i:47	MD:Z:75^A37^CAGGTAAAATTTGGTCAATCTATTTGACATACATTTTTGTTAATTA58	AS:i:111	XS:i:19	SA:Z:X,1053,+,7M3D59M176S,60,3;+SRR070372.1096	2048	X	1053	60	7M3D59M176H	*	0	0	GTTCTACAACGTCCAGATCGGAAGCAAGTTCGAAGGAGAGGGTCTTGATAACACCAAGCACGAGGT	IIIIIIF@@@CIIIIIIIIIIIIIIIIIIIIIHHIIIB=5669CIIIIIIIIIIIIIIIIIIIIII	NM:i:3	MD:Z:7^AAA59	AS:i:59	XS:i:0	SA:Z:X,1174,+,62S75M1D37M46D58M10S,60,47;+SRR070372.1334	0	X	1174	60	61S75M1D16M1D10M1D9M46D55M1D7M1D6M1D10M1D5M2D25M2D11M2D16M	*	0	0	GTTCTACAACGTCCAGATCGGAAGCAAGTTCGAAGGAGAGGTCTTGATAACACCAAGCACGAGGTTACCTTCACTCTCAAGGACGGACACTTGTTCGAACATCACAAGCCACTTGAAGAGGGAGAATCCAAGGAAGAACCTATGAGTATTACTTGATGGAGATTTCTTATTCAGAAGATGAGCTTCAACAATATCGAAGGCCGCAGATTCTACAAGAGACTCCCATAAAGTTTAACTTATCTATTGAAATTTCTAAATTGCAATTCAATTTCATTTCCGAAAAATAAATTATTTCAAGCAATCTTC	IIIIIII???GIIIIIIIICCCCIIIIIIIIIIIIIIB?555?IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIICCCIIIICCBBBBB?;;6688EEEEGEIE:::?<<?CGEDDEEBBCC44:EIIIEEEIIIIGHGGGHGGIIIIIIEGCCCCEEIIIIICC?<?EEEG?AAEB1//5=<52.---,.=../,34A?CB<<<4777/222;;@@DDDAEEEEEBGA74496:,,,,,.,,,--.221326::477<BEE	NM:i:61	MD:Z:75^A16^T10^T9^CAGGTAAAATTTGGTCAATCTATTTGACATACATTTTTGTTAATTA55^A7^A6^T10^T5^TA2T22^AA11^TA0T15	AS:i:110	XS:i:20	SA:Z:X,1053,+,7M3D32M1D26M241S,60,4;+SRR070372.1334	2048	X	1053	60	7M3D32M1D26M241H	*	0	0	GTTCTACAACGTCCAGATCGGAAGCAAGTTCGAAGGAGAGGTCTTGATAACACCAAGCACGAGGT	IIIIIII???GIIIIIIIICCCCIIIIIIIIIIIIIIB?555?IIIIIIIIIIIIIIIIIIIIII	NM:i:4	MD:Z:7^AAA32^G26	AS:i:51	XS:i:0	SA:Z:X,1174,+,61S75M1D16M1D10M1D9M46D55M1D7M1D6M1D10M1D5M2D25M2D11M2D16M,60,61;+|]++case_count_two = do+    c <- testNGLessIO $ do+        let opts = defCountOpts { optFeatures = ["gene"] }+        gff <- asTempFile short1 "gff"+        samf <- asTempFile short_sam "sam"+        ann <- loadAnnotator (AnnotateGFF gff) opts+        cfp <- performCount (File samf) "testing" ann opts+        liftIO (readCountFile cfp)+    c @?= M.fromList [("WBGene00002254", 2)]++sam1 = [here|+@SQ	SN:X	LN:10000+Read1	0	X	200	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+|]+sam1neg = [here|+@SQ	SN:X	LN:10000+Read1	16	X	200	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+|]++samPartial = [here|+@SQ	SN:X	LN:10000+Read1	0	X	80	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+|]++samAmbiguous = [here|+@SQ	SN:X	LN:10000+Read1	0	X	280	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+|]++samAmbiguous2 = [here|+@SQ	SN:X	LN:10000+Read1	0	X	280	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+Read2	0	X	100	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+|]++samAmbiguous3 = [here|+@SQ	SN:X	LN:10000+Ambiguous	0	X	280	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+Match100.1	0	X	100	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+Match100.2	0	X	100	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+Match100.3	0	X	100	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+Match300.1	0	X	420	60	35M	*	0	0	CAATTGGAGTGCATCAAGTGGTGCGATAAGGTCCTA	22777449446411100.,,,1.11..0000,,,,	NM:i:51		AS:i:430	XS:i:19+|]++gff1 = [here|+X	protein_coding	gene	100	400	.	+	.	gene_id "Gene100"; gene_name "gene1"; gene_source "ensembl"; gene_biotype "protein_coding";+X	protein_coding	gene	300	600	.	+	.	gene_id "Gene300"; gene_name "gene2"; gene_source "ensembl"; gene_biotype "protein_coding";+|]++case_gff_match = do+    c <- testNGLessIO $ runSamGffAnnotation sam1 gff1 defCountOpts { optFeatures = ["gene"] }+    c @?= M.fromList [("Gene100", 1), ("Gene300", 0)]++case_gff_strand_check = do+    c <- testNGLessIO $ runSamGffAnnotation sam1 gff1 defCountOpts { optFeatures = ["gene"], optStrandMode = SMSense }+    c @?= M.fromList [("Gene100", 1), ("Gene300", 0)]++case_gff_strand_check_negstrand = do+    c <- testNGLessIO $ runSamGffAnnotation sam1neg gff1 defCountOpts { optFeatures = ["gene"], optStrandMode = SMSense }+    c @?= M.fromList [("Gene100", 0), ("Gene300", 0)]++case_gff_feature_mismatch = do+    c <- testNGLessIO $ runSamGffAnnotation sam1 gff1 defCountOpts { optFeatures  = ["CDS"] }+    c @?= M.fromList []++case_gff_feature_partial = do+    c <- testNGLessIO $ runSamGffAnnotation samPartial gff1 defCountOpts { optFeatures  = ["gene"] }+    c @?= M.fromList [("Gene100", 1), ("Gene300", 0)]++case_gff_feature_partial_intersect = do+    c <- testNGLessIO $ runSamGffAnnotation samPartial gff1 defCountOpts { optFeatures  = ["gene"], optIntersectMode = annotationRule IntersectUnion }+    c @?= M.fromList [("Gene100", 1), ("Gene300", 0)]++case_gff_feature_ambiguous = do+    c <- testNGLessIO $ runSamGffAnnotation samAmbiguous gff1 defCountOpts { optFeatures  = ["gene"], optMMMethod = MMCountAll }+    c @?= M.fromList [("Gene100", 1), ("Gene300", 1)]++case_gff_feature_ambiguous_discard = do+    c <- testNGLessIO $ runSamGffAnnotation samAmbiguous gff1 defCountOpts { optFeatures  = ["gene"] }+    c @?= M.fromList [("Gene100", 0), ("Gene300", 0)]++case_gff_1OverN = do+    c <- testNGLessIO $ runSamGffAnnotation samAmbiguous gff1 defCountOpts { optFeatures  = ["gene"], optMMMethod = MM1OverN }+    c @?= M.fromList [("Gene100", 0.5), ("Gene300", 0.5)]++case_gff_dist1_fallback = do+    c <- testNGLessIO $ runSamGffAnnotation samAmbiguous gff1 defCountOpts { optFeatures  = ["gene"], optMMMethod = MMDist1 }+    c @?= M.fromList [("Gene100", 0.5), ("Gene300", 0.5)]++case_gff_dist1_dist = do+    c <- testNGLessIO $ runSamGffAnnotation samAmbiguous2 gff1 defCountOpts { optFeatures  = ["gene"], optMMMethod = MMDist1 }+    c @?= M.fromList [("Gene100", 2.0), ("Gene300", 0.0)]++case_gff_dist1_dist1_to_4 = do+    c <- testNGLessIO $ runSamGffAnnotation samAmbiguous3 gff1 defCountOpts { optFeatures  = ["gene"], optMMMethod = MMDist1 }+    c @?= M.fromList [("Gene100", 3.75), ("Gene300", 1.25)]++case_rsv_1 = do+    v <- RSV.newRefSeqInfoVector+    RSV.insert v (B.take 5 "hello SLICE") 1.0 +    RSV.insert v "world" 2.0 +    RSV.sort v+    fv <- RSV.unsafeFreeze v+    RSV.length fv @?= 2+    RSV.lookup fv "hello" @?= Just 0+    RSV.lookup fv (B.take 5 "hello SLICE2") @?= Just 0+    RSV.retrieveSize fv 0 @?= 1.0+    RSV.lookup fv "world" @?= Just 1+++simple_map = [here|+#gene	cog	ko	module+gene1	NOG318324	NA	NA	NA+gene2	COG2813	K00564	NA+|]++case_load_map = do+    [GeneMapAnnotator tag nmap names] <- testNGLessIO $ do+        map_fp <- asTempFile simple_map "map"+        loadFunctionalMap map_fp ["ko"]+    let Just [ix] = M.lookup "gene1" nmap+    RSV.retrieveName names ix @?= "NA"+    tag @?= B.empty
+ Tests-Src/Tests/FastQ.hs view
@@ -0,0 +1,160 @@+{- Copyright 2013-2020 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.FastQ+    ( tgroup_FastQ+    ) where++import Test.Tasty.TH+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import qualified Data.ByteString.Lazy as BL+import qualified Data.Vector.Storable as VS+import           Data.Int+import           Data.Conduit ((.|))+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL++import Interpretation.FastQ+import Interpretation.Substrim+import Tests.Utils+import Data.FastQ+import Utils.Here+import Utils.Conduit+import NGLess.NGError++tgroup_FastQ = $(testGroupGenerator)++case_parse_encode_sanger = encodeRecover SangerEncoding @?= Right reads3+case_parse_encode_solexa = encodeRecover SolexaEncoding @?= Right reads3+++-- | reads a sequence of short reads.+-- returns an error if there are any problems.+--+-- Note that the result of this function is not lazy! It will consume the whole+-- input before it produces the first output (because it needs to determine+-- whether an error occurred).+fqDecode :: FastQEncoding -> BL.ByteString -> NGLess [ShortRead]+fqDecode enc s = C.runConduit $+    CL.sourceList (BL.toChunks s)+        .| linesC+        .| fqDecodeC "test" enc+        .| CL.consume++encodeRecover enc = fqDecode enc . BL.fromChunks $ map (fqEncode enc) reads3+reads3 =+    [ShortRead "x" "acttg" (VS.fromList [35,16,34,34,24])+    ,ShortRead "y" "catgt" (VS.fromList [33,17,25,37,18])+    ,ShortRead "z" "ccggg" (VS.fromList [32,16,20,32,17])+    ]++simpleStats f = testNGLessIO $ do+    enc <- encodingFor f+    qualityPercentiles <$> statsFromFastQ f enc++case_compatibleHeader = do+    assertBool "remove /[12]" $ compatibleHeader "@SRR4052021.40730 4073/1" "@SRR4052021.40730 4073/2"+    assertBool "equal headers" $ compatibleHeader "@SRR4052021.40730 4073" "@SRR4052021.40730 4073"+    assertBool "not equal " $ not $ compatibleHeader "@SRR4052021.40730 4073" "@SRR4052021.40730 4074"+    assertBool "suffix is not /[12]" $ not $ compatibleHeader "@SRR4052021.40730 4073 xa" "@SRR4052021.40730 4073 xb"++-- negative tests quality on value 60 char ';'. Value will be 60 - 64 which is -4+case_calc_statistics_negative = do+    lowQ <- testNGLessIO $ asTempFile low_quality "fq"+    s <- simpleStats lowQ+    head s @?= (-4,-4,-4,-4)++-- low positive tests quality on 65 char 'A'. Value will be 65-64 which is 1.+case_calc_statistics_low_positive = do+    lowQ <- testNGLessIO $ asTempFile low_quality "fq"+    s <- simpleStats lowQ+    last s @?= (1,1,1,1)+++low_quality = [here|+@IRIS:7:1:17:394#0/1+GTCAGGACAAT+++<=>?@ABCAWA+@IRIS:7:1:17:800#0/1+GGAAACACTA+++<=>?@ABCAA+|]++case_calc_statistics_normal = do+    s <- simpleStats "test_samples/data_set_repeated.fq"+    head s @?= (25,33,31,33)+++data Method = MSubstrim | MEndstrim EndstrimEnds+    deriving (Show)++instance Arbitrary Method where+    arbitrary = oneof+                    [return MSubstrim+                    , return $ MEndstrim EndstrimBoth+                    , return $ MEndstrim Endstrim3+                    , return $ MEndstrim Endstrim5+                    ]++genericTrimPos MSubstrim = subtrimPos+genericTrimPos (MEndstrim ends) = endstrimPos ends+++newtype VS8 = VS8 (VS.Vector Int8)+    deriving (Eq, Show)++instance Arbitrary VS8 where+    arbitrary = VS8 . VS.fromList <$> listOf1 (oneof (return <$> [-5 .. 40]))++-- Test SUBSTRIM/ENDSTRIM+--Property 1: For every s, the size must be always smaller than the input+prop_trim_maxsize m (VS8 s) = st >= 0 && e <= VS.length s+    where (st,e) = genericTrimPos m s 20++-- Property 2: substrim should be idempotent+prop_strim_idempotent m (VS8 s) = st == 0 && n == VS.length s1+    where+        (st0, n0) = genericTrimPos m s 20+        s1 = VS.slice st0 n0 s+        (st,n) = genericTrimPos m s1 20++data SplitVU8 = SplitVU8 (VS.Vector Int8) Int Int+    deriving (Show)++instance Arbitrary SplitVU8 where+    arbitrary = do+        qs <- VS.fromList <$> listOf1 arbitrary+        st <- elements [0 .. VS.length qs - 1]+        n <- elements [0 .. VS.length qs - st]+        return $! SplitVU8 qs st n++prop_substrim_no_better (SplitVU8 qs s n) = not valid || n' >= n+    where+        thr = 20+        valid = VS.all (> thr) (VS.slice s n qs)+        (_, n') = subtrimPos qs thr++case_substrim_normal_exec =  subtrimPos (VS.fromList [10,11,12,123,122,111,10,11,0]) 20 @?= (3,3)+case_substrim_empty_quals = subtrimPos VS.empty 20 @?= (0,0)++case_endstrim_quals_allbad = snd (endstrimPos EndstrimBoth (VS.fromList [1,2,2,2,2,1,2,2]) 10) @?= 0+case_endstrim_quals_allbad_tresh = snd (endstrimPos EndstrimBoth (VS.fromList [9,9,9,9]) 10) @?= 0+case_endstrim_quals_allOK_tresh = endstrimPos EndstrimBoth (VS.fromList [10,10,10,10]) 10 @?= (0,4)+case_endstrim_quals_one_OK = endstrimPos EndstrimBoth (VS.fromList [9,9,10,9]) 10 @?= (2,1)+case_endstrim_quals_one_OK_3 = endstrimPos Endstrim3 (VS.fromList [9,9,10,9]) 10 @?= (0,3)+case_endstrim_quals_one_OK_5 = endstrimPos Endstrim5 (VS.fromList [9,9,10,9]) 10 @?= (2,2)+case_endstrim_1 = endstrimPos EndstrimBoth (VS.fromList [9,9,10,9,9,10,9]) 10 @?= (2,4)++case_smoothtrim_empty_quals = smoothtrimPos 4 VS.empty 20 @?= (0,0)+case_smoothtrim_normal_exec =  smoothtrimPos 4 (VS.fromList [10,11,12,123,122,111,10,11,0]) 20 @?= (1,6)+case_smoothtrim_middle_bad = smoothtrimPos 4 (VS.fromList [32,32,14,32,32,14,14,2,14,14,32,32]) 20 @?= (0,5)+case_smoothtrim_isolated = smoothtrimPos 4 (VS.fromList [32,32,32,1,32,32,32]) 20 @?= (0,7)+case_smoothtrim_window_4 = smoothtrimPos 4 (VS.fromList [24,2,24,24,24,24,2,24,24,24,24,2,24]) 20 @?= (3,1)+case_smoothtrim_window_10 = smoothtrimPos 10 (VS.fromList [24,2,24,24,24,24,2,24,24,24,24,2,24]) 20 @?= (0,13)
+ Tests-Src/Tests/IntGroups.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, TupleSections #-}+module Tests.IntGroups+    ( tgroup_IntGroups+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import qualified Data.Vector.Unboxed as VU++import qualified Utils.IntGroups as IG++tgroup_IntGroups = $(testGroupGenerator)++case_basic = (IG.toList . IG.fromList $ vs) @?= (map VU.fromList vs)+    where+        vs = [[1],[2],[2,3,4]]++case_length = (IG.length . IG.fromList $ vs) @?= length vs+    where+        vs = [[1],[2],[2,3,4]]++prop_idem vs = (IG.toList . IG.fromList $ vs) == (map VU.fromList vs)+
+ Tests-Src/Tests/Language.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.Language+    ( tgroup_Language+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit++import Language++tgroup_Language = $(testGroupGenerator)++case_staticValue1 =+    staticValue (ListExpression [ConstStr "Hello"+                    , BinaryOp BOpPathAppend+                                (ConstStr "results-dir")+                                (ConstStr "output.txt")])+        @=? (Just $ NGOList [NGOString "Hello", NGOString "results-dir/output.txt"])++case_staticValue2 = do+    staticValue (ListExpression [ConstStr "Hello"+                    , BinaryOp BOpPathAppend+                                (ConstStr "results-dir")+                                (ConstStr "output.txt")+                    , Lookup Nothing (Variable "nope")])+        @=? Nothing
+ Tests-Src/Tests/LoadFQDirectory.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.LoadFQDirectory+    ( tgroup_LoadFQDirectory+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit++import Control.Monad (forM_)++import BuiltinModules.LoadDirectory (matchUp)+import Tests.Utils++tgroup_LoadFQDirectory = $(testGroupGenerator)++case_error_p1 = isError (matchUp ["sample/sample.pair.1.fq.bz2"])+case_error_p2 = isError (matchUp ["sample/sample.pair.2.fq.bz2"])++case_known_cases = forM_ known_cases check1++check1 expected@(s, p) = do+    let extract (Left (a,b)) = [a,b]+        extract (Right (a,b,c)) = [a,b,c]+        fqs = s ++ concatMap extract p+    fromRight (matchUp fqs) @?= expected++known_cases = +    --  Simple with ".single"+    [ ([], [Right ("sample/sample.pair.1.fq", "sample/sample.pair.2.fq", "sample/sample.single.fq")])++    -- basic uncompressed+    , (["sample/uncompressed.fq"], [])++    -- basic compressed I+    , (["sample/sample.fq.gz"], [])++    -- basic compressed II+    , (["sample/sample.fq.bz2"], [])++    -- Paired using "_[12].fastq"+    , ([], [Left ("sample/sample_1.fastq.gz","sample/sample_2.fastq.gz")])++    -- paired+singles compressed+    , ([], [Right ("sample/sample.pair.1.fq.gz", "sample/sample.pair.2.fq.gz", "sample/sample.single.fq.gz")])++    -- paired+singles compressed II (bz2 + deeper directory)+    , ([], [Right ("mocat_sample_bz2_paired/sample/sample.pair.1.fq.bz2", "mocat_sample_bz2_paired/sample/sample.pair.2.fq.bz2", "mocat_sample_bz2_paired/sample/sample.single.fq.bz2")])++    -- _[FR] pairing+single+    -- Arguably, the pairing is not the expected one, but this was what was done before+    , (["sample/sample.single.fq.gz"], [Left ("sample/sample.pair_F.fq.gz", "sample/sample.pair_R.fq.gz")])++    -- mixed+    , (["sample/sampleC.single.fq.bz2"],+            [Left  ("sample/sampleB.pair.1.fq.bz2", "sample/sampleB.pair.2.fq.bz2")+            ,Right ("sample/sampleA.pair.1.fq.bz2", "sample/sampleA.pair.2.fq.bz2", "sample/sampleA.single.fq.bz2")])+    ]+
+ Tests-Src/Tests/NGLessAPI.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, TupleSections #-}+module Tests.NGLessAPI+    ( tgroup_NGLessAPI+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit++import Language+import NGLess+import Tests.Utils+++tgroup_NGLessAPI = $(testGroupGenerator)++case_lookupStringError = isError (lookupStringOrScriptError "test" "no" [("yes", NGOString "test")])+case_lookupStringOk = isOk "lookup failed" (lookupStringOrScriptError "test" "yes" [("yes", NGOString "test")])+case_lookupStringDefOk = isOk "default failed" (lookupStringOrScriptErrorDef (return "ok") "test" "not" [("yes", NGOString "test")])
+ Tests-Src/Tests/Parse.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.Parse+    ( tgroup_Parse+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit++import Text.Parsec (SourcePos, parse)+import Text.ParserCombinators.Parsec.Prim (GenParser)+import Text.Parsec.Pos (newPos)+import qualified Data.Text as T++import Tests.Utils+import Parse+import Tokens+import Language+import Utils.Here++tgroup_Parse = $(testGroupGenerator)+--+-- Test Parsing Module+parseText :: GenParser (SourcePos,Token) () a -> T.Text -> a+parseText p t = fromRight . parse p "test" . _cleanupindents . fromRight . tokenize "test" $ t+parseBody = map snd . parseText _nglbody++case_parse_symbol = parseBody "{symbol}" @?= [ConstSymbol "symbol"]+case_parse_fastq = parseBody fastqcalls @?= fastqcall+    where+        fastqcalls = "fastq(\"input.fq\")"+        fastqcall  = [FunctionCall (FuncName "fastq") (ConstStr "input.fq") [] Nothing]++case_parse_paired = parseBody fastqcalls @?= fastqcall+    where+        fastqcalls = "paired(\"input.fq\", \"pair.fq\")"+        fastqcall  = [FunctionCall (FuncName "paired") (ConstStr "input.fq") [(Variable "second", ConstStr "pair.fq")] Nothing]++case_parse_count = parseBody countcalls @?= countcall+    where+        countcalls = "count(annotated, count={gene})"+        countcall  = [FunctionCall (FuncName "count") (Lookup Nothing (Variable "annotated")) [(Variable "count", ConstSymbol "gene")] Nothing]++case_parse_count_mult_counts = parseBody countcalls @?= countcall+    where+        countcalls = "count(annotated, count=[{gene},{cds}])"+        countcall  = [FunctionCall (FuncName "count") (Lookup Nothing (Variable "annotated")) [(Variable "count", ListExpression [ConstSymbol "gene", ConstSymbol "cds"])] Nothing]++case_parse_assignment =  parseBody "reads = \"something\"" @?=+        [Assignment (Variable "reads") (ConstStr "something")]++case_parse_sequence = parseBody seqs @?= seqr+    where+        seqs = "reads = 'something'\nreads = 'something'"+        seqr = [a,a]+        a    = Assignment (Variable "reads") (ConstStr "something")++case_parse_num = parseBody nums @?= num+    where+        nums = "a = 0x10"+        num  = [Assignment (Variable "a") (ConstInt 16)]++case_parse_double = parseBody double_a_s @?= double_a+    where+        double_a_s = "d = 1.2"+        double_a = [Assignment (Variable "d") (ConstDouble 1.2)]++case_parse_bool = parseBody bools @?= bool+    where+        bools = "a = true"+        bool  = [Assignment (Variable "a") (ConstBool True)]++case_parse_if_else = parseBody blocks @?= block+    where+        blocks = "if true:\n 0\n 1\nelse:\n 2\n"+        block  = [Condition (ConstBool True) (Sequence [ConstInt 0,ConstInt 1]) (Sequence [ConstInt 2])]++case_parse_if = parseBody blocks @?= block+    where+        blocks = "if true:\n 0\n 1\n"+        block  = [Condition (ConstBool True) (Sequence [ConstInt 0,ConstInt 1]) (Sequence [])]++case_parse_if_end = parseBody blocks @?= block+    where+        blocks = "if true:\n 0\n 1\n2\n"+        block  = [Condition (ConstBool True) (Sequence [ConstInt 0,ConstInt 1]) (Sequence []),ConstInt 2]++case_parse_ngless = parsengless "test" True ngs @?= Right ng+    where+        ngs = "ngless '0.0'\n"+        ng  = Script (Just $ Header "0.0" []) []++case_parse_import = parsengless "test" True ngs @?= Right ng+    where+        ngs = "ngless '0.0'\nimport 'testing' version '3.2-x'\n"+        ng  = Script (Just $ Header "0.0" [ModInfo "testing" "3.2-x"]) []++case_parse_comment_before_import = isOk "comments after ngless line should not fail (regression test)" $ parsengless "test" True [here|+ngless "0.0"+# This should not fail+import "parallel" version "0.0"++# This should not fail either+sample = lock1(readlines('input.txt'))+input = fastq(sample)+|]++case_parse_empty_line_before_import = isOk "empty lineafter ngless line should not fail (regression test)" $ parsengless "test" True [here|+ngless "0.0"++import "parallel" version "0.0"++sample = lock1(readlines('input.txt'))+input = fastq(sample)+|]++case_parse_list = parseText _listexpr "[a,b]" @?= ListExpression [Lookup Nothing (Variable "a"), Lookup Nothing (Variable "b")]++case_parse_indexexpr_11 = parseText _indexexpr "read[1:1]" @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexTwo j1 j1)+case_parse_indexexpr_10 = parseText _indexexpr "read[1:]"  @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexTwo j1 Nothing)+case_parse_indexexpr_01 = parseText _indexexpr "read[:1]"  @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexTwo Nothing j1)+case_parse_indexexpr_00 = parseText _indexexpr "read[:]"   @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexTwo Nothing Nothing)++case_parse_indexexprone_1 = parseText _indexexpr "read[1]" @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexOne (ConstInt 1))+case_parse_indexexprone_2 = parseText _indexexpr "read[2]" @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexOne (ConstInt 2))+case_parse_indexexprone_var = parseText _indexexpr "read[var]" @?= IndexExpression (Lookup Nothing (Variable "read")) (IndexOne (Lookup Nothing (Variable "var")))++case_parse_cleanupindents_0 = tokcleanupindents [TIndent 1] @?= []+case_parse_cleanupindents_1 = tokcleanupindents [TNewLine] @?= [TNewLine]+case_parse_cleanupindents_2 = tokcleanupindents [TIndent 1,TNewLine] @?= [TNewLine]+case_parse_cleanupindents_3 = tokcleanupindents [TOperator '(',TNewLine,TIndent 2,TOperator ')'] @?= [TOperator '(',TOperator ')']++case_parse_cleanupindents_4 = tokcleanupindents toks @?= toks'+    where+        toks  = [TWord "write",TOperator '(',TWord "A",TOperator ',',TNewLine,TIndent 16,TNewLine,TIndent 16,TWord "format",TOperator '=',TExpr (ConstSymbol "csv"),TOperator ')',TNewLine]+        toks' = [TWord "write",TOperator '(',TWord "A",TOperator ','                                        ,TWord "format",TOperator '=',TExpr (ConstSymbol "csv"),TOperator ')',TNewLine]+case_parse_cleanupindents_4' = tokcleanupindents toks @?= toks'+    where+        toks  = [TOperator '(',TOperator ',',TNewLine,TIndent 16,TNewLine,TIndent 16,TOperator ')',TNewLine]+        toks' = [TOperator '(',TOperator ','                                        ,TOperator ')',TNewLine]+case_parse_cleanupindents_4'' = tokcleanupindents toks @?= toks'+    where+        toks  = [TOperator '(',TNewLine,TIndent 16,TNewLine,TIndent 16,TOperator ')',TNewLine]+        toks' = [TOperator '('                                        ,TOperator ')',TNewLine]++j1 = Just (ConstInt 1)+tokcleanupindents = map snd . _cleanupindents . map (newPos "test" 0 0,)++case_parse_kwargs = parseBody "unique(reads,maxCopies=2)\n" @?= [FunctionCall (FuncName "unique") (Lookup Nothing (Variable "reads")) [(Variable "maxCopies", ConstInt 2)] Nothing]++case_parse_methods_kwargs_only = parseBody "sf.filter(min_identity_pc=90)\n" @?= [MethodCall (MethodName "filter") (Lookup Nothing (Variable "sf")) Nothing [(Variable "min_identity_pc", ConstInt 90)]]+
+ Tests-Src/Tests/Select.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.Select+    ( tgroup_Select+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB++import Interpretation.Select (fixCigar)+import Data.Sam+import Tests.Utils+import Utils.Here+++tgroup_Select = $(testGroupGenerator)+++samLineFlat = [here|IRIS:7:3:1046:1723#0	4	*	0	0	40M	*	0	0	AAAAAAAAAAAAAAAAAAAATTTAAA	aaaaaaaaaaaaaaaaaa`abbba`^	AS:i:0	XS:i:0	NM:i:1|]+samLine = SamLine+            { samQName = "IRIS:7:3:1046:1723#0"+            , samFlag = 4+            , samRName = "*"+            , samPos = 0+            , samMapq = 0+            , samCigar = "40M"+            , samRNext = "*"+            , samPNext = 0+            , samTLen = 0+            , samSeq = "AAAAAAAAAAAAAAAAAAAATTTAAA"+            , samQual = "aaaaaaaaaaaaaaaaaa`abbba`^"+            , samExtra = "AS:i:0\tXS:i:0\tNM:i:1"+            }+simple = [here|+simulated:1:1:38:663#0	0	Ref1	1018	3	69M16S	=	1018	0	TTCGAGAAGATGGGTATCGTGGGAAATAACGGAACGGGGAAGTCTACCTTCATCAAGATGCTGCTGGGCTTGGTGAAACCCGACA	IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII	NM:i:5	MD:Z:17T5T14A2A2G24	AS:i:44	XS:i:40|]++complex = [here|+SRR070372.3	16	V	7198336	21	26M3D9M3D6M6D8M2D21M	*	0	0	CCCTTATGCAGGTCTTAACACAATTCTTGTATGTTCCATCGTTCTCCAGAATGAATATCAATGATACCAA	014<<BBBBDDFFFDDDDFHHFFD?@??DBBBB5555::?=BBBBDDF@BBFHHHHHHHFFFFFD@@@@@	NM:i:14	MD:Z:26^TTT9^TTC6^TTTTTT8^AA21	AS:i:3	XS:i:0|]++refinsert = [here|+SRR6028238.2619770	417	X	1319005	0	5M1I40M54H	=	2019245	700291	TTTTCCGCTGAATATGCCCAAAGTGCAACAACGACGACCGCCGCCA	@DDDEDDDDBDDDEEECDDDDDCAACCCCBBDDDBBBBBB<@BBDB	NM:i:1	MD:Z:45	MC:Z:51M50H	AS:i:40|]++case_read_one_Sam_Line = readSamLine samLineFlat @?= Right samLine+case_encode = (BL.toStrict . BB.toLazyByteString . encodeSamLine $ samLine) @?= samLineFlat++case_isAligned_raw = isAligned (fromRight . readSamLine $ complex) @? "Should be aligned"+case_match_identity_soft = fromRight (matchIdentity True samLine) == 0.975 @? "Soft clipped read (low identity)"++case_matchSize1 = fromRight (matchSize True =<< readSamLine complex) @?= (26+  9+  6+  8+  21)+                                                                   --26M3D9M3D6M6D8M2D21M+case_matchSize2 = fromRight (matchSize True =<< readSamLine simple) @?= 69+case_matchSize3 = fromRight (matchSize True =<< readSamLine refinsert) @?= 46++case_cigarOK = fixCigar "9M" 9 @?= Right "9M"+case_cigarH = fixCigar "4H5M" 9 @?= Right "4S5M"+case_cigarH2 = fixCigar "4H5M2H" 11 @?= Right "4S5M2S"+case_cigarH3 = fixCigar "5M1I40M54H" 46 @?= Right "5M1I40M54H"+case_cigarH4 = fixCigar "5M1I40M54H" 100 @?= Right "5M1I40M54S"
+ Tests-Src/Tests/Types.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE TemplateHaskell #-}+module Tests.Types+    ( tgroup_Types+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit+import qualified Data.Text as T++import Tests.Utils+import Types+import Language+import BuiltinFunctions (builtinModule)+import NGLess.NGLEnvironment (NGLVersion(..))++tgroup_Types = $(testGroupGenerator)+++mods = [builtinModule (NGLVersion 1 3)]++isOkTypes :: Script -> IO ()+isOkTypes script = case checktypes mods script of+    (Right _) -> return ()+    (Left err) -> assertFailure ("Type error on good code (error was '"++show err++"'")++isOkTypesText scriptText = case parsetest scriptText >>= checktypes mods of+    (Right _) -> return ()+    (Left err) -> assertFailure ("Type error on good code (error was '"++show err++"') for script: '"++T.unpack scriptText++"'")++isErrorText scriptText = isError $ parsetest scriptText>>= checktypes mods+++case_bad_type_fastq = isError $ checktypes mods (Script Nothing [(0,FunctionCall (FuncName "fastq") (ConstInt 3) [] Nothing)])+case_good_type_fastq = isOkTypes (Script Nothing [(0,FunctionCall (FuncName "fastq") (ConstStr "fastq.fq") [] Nothing)])++case_type_complete = isOkTypesText+    "ngless '0.0'\n\+    \reads = fastq('input1.fq')\n\+    \reads = unique(reads,max_copies=2)\n\+    \preprocess(reads) using |read|:\n\+    \    read = read[5:]\n\+    \    read = substrim(read, min_quality=24)\n\+    \    if len(read) < 30:\n\+    \        discard\n"++case_indent_empty_line = isOkTypesText+    "ngless '0.0'\n\+    \reads = fastq('input1.fq')\n\+    \preprocess(reads) using |read|:\n\+    \    read = read[5:]\n\+    \    \n\+    \    if len(read) < 24:\n\+    \        discard\n"+++case_invalid_func_fastq = isError $ checktypes mods $+    Script Nothing [(0,FunctionCall (FuncName "fastq") (ConstStr "fastq.fq") [(Variable "fname", ConstInt 10)] Nothing)]++-- unique++case_valid_funique_mc = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \unique(x, max_copies=10)\n"++case_invalid_funique_mc = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \unique(x, max_copies='test')\n"+++-- substrim++case_valid_fsubstrim_mq = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \preprocess(x) using |read|:\n\+    \    read = read[5:]\n\+    \    read = substrim(read, min_quality=2)\n"++case_invalid_fsubstrim_mq = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \preprocess(x) using |read|:\n\+    \    read = read[5:]\n\+    \    read = substrim(read, min_quality='2')\n"++case_invalid_fmap_ref = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \map(x, reference=10)\n"+++case_valid_fmap_ref = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \map(x, reference='xpto')\n"++-- count+case_valid_fannot_gff = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \count(y, gff_file='xpto')"++case_invalid_fannot_gff = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \count(y, gff_file={xpto})"++case_valid_fannot_mode = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \count(y, mode={union})"++case_invalid_fannot_mode = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \count(y, mode='union')"++case_valid_fannot_features = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \count(y, features=['gene'])"++case_invalid_fannot_features = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \count(y, features={gene})"++case_valid_fcount_min = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \z = count(y, features=['gene'], min=10)"+++-- write+++case_valid_fwrite_format = isOkTypesText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \z = count(y, features=['gene'])\n\+    \write(z, format={tsv})"++case_invalid_fwrite_format = isErrorText+    "ngless '0.0'\n\+    \x = fastq('fq')\n\+    \y = map(x, reference='xpto')\n\+    \z = count(y, features=[{gene}])\n\+    \write(count(z), format='tsv')"++case_mixed_addition = isErrorText+    "ngless '0.0'\n\+    \nglessIsNotJS = 1 + '2'\n"
+ Tests-Src/Tests/Utils.hs view
@@ -0,0 +1,50 @@+module Tests.Utils+    ( isError+    , isErrorMsg+    , isOk+    , isOkMsg+    , parsetest+    , fromRight+    , asTempFile+    , testNGLessIO+    ) where+import Test.Tasty.HUnit+import qualified Data.Text as T+import qualified Data.ByteString as B+import Control.Monad.IO.Class (liftIO)+import System.IO++import Language+import Parse+import FileManagement+import NGLess++isError :: Either a b -> Assertion+isError = isErrorMsg "Error not caught"++isErrorMsg :: String -> Either a b -> Assertion+isErrorMsg m (Right _) = assertFailure m+isErrorMsg _ (Left _) = return ()++isOk :: String -> Either a b -> Assertion+isOk m (Left _) = assertFailure m+isOk _ (Right _) = return ()++isOkMsg = isOk++parsetest :: T.Text -> NGLess Script+parsetest = parsengless "test" True++fromRight (Right r) = r+fromRight (Left e) = error ("Unexpected Left: " ++ show e)++asTempFile :: B.ByteString -> FilePath -> NGLessIO FilePath+asTempFile sf ext = do+    (fp, h) <- openNGLTempFile "testing" "heredoc" ext+    liftIO $ do+        B.hPut h sf+        hClose h+    return fp+++
+ Tests-Src/Tests/Validation.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Tests.Validation+    ( tgroup_Validation+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit+import Control.Monad+import Data.Either.Combinators (isRight)+import qualified Data.Text as T++import Tests.Utils+import Validation+import ValidationIO+import Utils.Here+import BuiltinFunctions (builtinModule)+import NGLess.NGLEnvironment (NGLVersion(..))++tgroup_Validation = $(testGroupGenerator)++-- Pure Validation++mods = [builtinModule (NGLVersion 1 3)]++isValidateOk ftext = case parsetest ftext >>= validate mods of+    Right _ -> return ()+    Left err -> assertFailure ("Validation should have passed for script "++T.unpack ftext++"; instead picked up error: '"++show err++"'")+isValidateError ftext = isErrorMsg ("Validation should have picked error for script '"++T.unpack ftext++"'") (parsetest ftext >>= validate mods)++case_bad_function_attr_count = isValidateError+    "ngless '0.0'\n\+    \count(annotated, features='gene')\n"++case_map_not_assigned = isValidateError+    [here|+ngless '0.0'+input = fasq('input.fq.gz')+map(input,reference='sacCer3')+|]++case_good_function_attr_map = isValidateOk+    [here|+ngless '0.0'+input = fastq('input.fq.gz')+write(+    map(input, reference='sacCer3'),+            ofile='result.sam',+            format={sam})+|]+++-- Validate IO++validateIO_Ok script = do+    err <- testNGLessIO $ validateIO mods (fromRight . parsetest $ script)+    case err of+        Nothing -> assertBool "" True+        Just errmsg -> assertFailure (concat ["Expected no errors in validation, got ", show errmsg, ".\nScript was::\n\n", show script])++validateIO_error script = do+    err <- testNGLessIO $ validateIO mods (fromRight . parsetest $ script)+    case err of+        Nothing -> assertFailure (concat ["ValidateIO should have detected an error on the script ", show script])+        Just _ -> return ()++validate_Error script =+    when (isRight $ parsetest script >>= validate []) $+        assertFailure (concat ["Validate (pure) should have detected an error on the script ", show script])++case_fastq_inexistence_file = validateIO_error+    "ngless '0.0'\n\+    \fastq('THIS_FILE_DOES_NOT_EXIST_SURELY.fq')\n"++case_invalid_not_pure_fp_fastq_lit = validateIO_Ok+    "ngless '0.0'\n\+    \fastq('Makefile')\n" --File Makefile exists++case_build_path = validateIO_Ok [here|+ngless '0.0'+part1 = 'Make'+part2 = 'file'+fastq(part1 + part2)+|]++case_valid_not_pure_fp_fastq_const = validateIO_error+    "ngless '0.0'\n\+    \x = 'fq'\n\+    \fastq(x)\n"++case_invalid_not_pure_fp_fastq_const = validateIO_Ok+    "ngless '0.0'\n\+    \x = 'Makefile'\n\+    \fastq(x)\n" --When run in source directory, Makefile exists+++case_valid_not_pure_map_reference_lit = validateIO_Ok+    "ngless '0.0'\n\+    \map(x, fafile='Makefile')\n"++case_invalid_not_pure_map_def_reference_lit = validateIO_Ok+    "ngless '0.0'\n\+    \map(x, reference='sacCer3')\n"++case_invalid_not_pure_map_reference_lit = validateIO_error+    "ngless '0.0'\n\+    \map(x, fafile='THIS_FILE_DOES_NOT_EXIST_SURELY.fa')\n"++case_inexistent_reference = validateIO_error+    "ngless '0.0'\n\+    \map(x, reference='UNKNOWN_REFERENCE')\n"+++case_fafile_through_variable = validateIO_Ok+    "ngless '0.0'\n\+    \v = 'Makefile'\n\+    \map(x, fafile=v)\n"++case_invalid_not_pure_map_def_reference_const = validateIO_Ok+    "ngless '0.0'\n\+    \v = 'sacCer3'\n\+    \map(x, reference=v)\n"++case_invalid_not_pure_map_reference_const = validateIO_error+    "ngless '0.0'\n\+    \v = 'THIS_FILE_DOES_NOT_EXIST_SURELY.fa'\n\+    \map(x, reference=v)\n"+++case_valid_not_pure_annotate_gff_lit = validateIO_Ok+    "ngless '0.0'\n\+    \count(x, gff_file='Makefile')\n"++case_invalid_not_pure_annotate_gff_lit = validateIO_error [here|+ngless '0.0'+count(x, gff_file='THIS_FILE_DOES_NOT_EXIST_SURELY.gff')+|]++case_samfile_check_file = validateIO_error [here|+ngless '0.0'+mapped = samfile('THIS_FILE_DOES_NOT_EXIST_SURELY.sam')+write(mapped, ofile='copy.sam')+|]++case_valid_not_pure_annotate_gff_const = validateIO_Ok+    "ngless '0.0'\n\+    \v = 'Makefile'\n\+    \count(x, gff_file=v)\n"++case_invalid_not_pure_annotate_gff_const = validateIO_error+    "ngless '0.0'\n\+    \v = 'THIS_FILE_DOES_NOT_EXIST_SURELY.gff'\n\+    \count(x, gff_file=v)\n"+++case_valid_not_pure_annotate_gff_const2 = validateIO_Ok+    "ngless '0.0'\n\+    \v = 'fq'\n\+    \v = 'Makefile'\n\+    \count(x, gff_file=v)\n"++case_validate_internal_call = validate_Error+    "ngless '0.0'\n\+    \write(select(samfile('f.sam'), keep_if=[{matched}]), ofile=STDOUT)\n"++case_validate_no_assign_constant = isValidateError [here|+ngless '0.0'+CONST = 1+CONST = 2+|]++case_validate_assign_variable = isValidateOk [here|+ngless '0.0'+notConst = 1+notConst = 2+|]
+ Tests-Src/Tests/Vector.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, TupleSections #-}+module Tests.Vector+    ( tgroup_Vector+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import qualified Data.Vector as V+import System.IO.Unsafe (unsafePerformIO)++import Utils.Vector++tgroup_Vector = $(testGroupGenerator)++-- Pure Validation++case_binarySearch1 = binarySearch (V.fromList [1,2,5]) ( 1 :: Int) @?= 0+case_binarySearch2 = binarySearch (V.fromList [1,2,5]) ( 2 :: Int) @?= 1+case_binarySearch3 = binarySearch (V.fromList [1,2,5]) ( 4 :: Int) @?= 2+case_binarySearch4 = binarySearch (V.fromList [1,2,5]) ( 5 :: Int) @?= 2+case_binarySearch5 = binarySearch (V.fromList [1,2,5]) ( 5 :: Int) @?= 2+case_binarySearch6 = binarySearch (V.fromList [1,2,5]) (15 :: Int) @?= 3+case_binarySearch7 = binarySearch (V.fromList [1,2,5]) (-1 :: Int) @?= 0++isSorted :: [Int] -> Bool+isSorted [] = True+isSorted [_] = True+isSorted (a:b:rs) = a <= b && isSorted (b:rs)++sortList :: [Int] -> [Int]+sortList vs = unsafePerformIO $ do+        v <- V.unsafeThaw (V.fromList vs)+        sortParallel 4 v+        V.toList <$> V.unsafeFreeze v++newtype BigList = BigList [Int]+    deriving (Eq, Show)+instance Arbitrary BigList where+    arbitrary = BigList <$> resize (1024*16) arbitrary++prop_sortP (BigList vs) = isSorted (sortList vs)++case_pivot_extreme = assertBool "sort list pivot" (isSorted . sortList $ [10] ++ [0 | _ <- [0 :: Int ..10000]] ++ [1 :: Int])+
+ Tests-Src/Tests/Write.hs view
@@ -0,0 +1,22 @@+{- Copyright 2015-2021 NGLess Authors+ - License: MIT+ -}+{-# LANGUAGE TemplateHaskell #-}+module Tests.Write+    ( tgroup_Write+    ) where++import Test.Tasty.TH+import Test.Tasty.HUnit++import Interpretation.Write+++tgroup_Write = $(testGroupGenerator)++case_format_index = _formatFQOname "test.{index}.fq.gz" "pair.1" @?= Right "test.pair.1.fq.gz"+case_format_index_first = _formatFQOname "{index}.fq.gz" "pair.2" @?= Right "pair.2.fq.gz"+case_format_no_index = _formatFQOname "filename.fq.gz" "singles" @?= Right "filename.singles.fq.gz"+case_format_no_index_dots = _formatFQOname "filename.with.dots.fq.gz" "singles" @?= Right "filename.with.dots.singles.fq.gz"+case_format_no_index_dots_rep = _formatFQOname "filename.with.dots.fq" "pair.1" @?= Right "filename.with.dots.pair.1.fq"+