BiobaseTypes 0.2.0.1 → 0.2.1.0

raw patch · 12 files changed

+664/−181 lines, 12 filesdep +DPutilsdep +tasty-hunitdep ~PrimitiveArraydep ~SciBaseTypesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: DPutils, tasty-hunit

Dependency ranges changed: PrimitiveArray, SciBaseTypes

API changes (from Hackage documentation)

Files

• Biobase/Types/BioSequence.hs +150/−90
• Biobase/Types/Bitscore.hs +3/−2
• Biobase/Types/Energy.hs +19/−2
• Biobase/Types/Index.hs +11/−1
• Biobase/Types/Index/Type.hs +4/−0
• Biobase/Types/Location.hs +217/−66
• Biobase/Types/Position.hs +163/−0
• Biobase/Types/Strand.hs +13/−9
• BiobaseTypes.cabal +14/−8
• README.md +2/−1
• changelog.md +6/−0
• tests/properties.hs +62/−2

@@ -14,6 +14,7 @@ import           Data.ByteString.Char8 (ByteString) import           Data.Char (ord,chr,toUpper) import           Data.Data (Data)+import           Data.Hashable import           Data.Typeable (Typeable) import           Data.Void import           GHC.Exts (IsString(..))@@ -22,19 +23,40 @@ import qualified Data.ByteString.UTF8 as BSU import qualified Streaming.Prelude as SP import qualified Streaming as S+import qualified Streaming.Internal as SI import qualified Test.QuickCheck as TQ import           Test.QuickCheck (Arbitrary(..))+import Data.Coerce+import Debug.Trace -import           Biobase.Types.Location-import           Biobase.Types.Strand+import Biobase.Types.Strand import qualified Biobase.Types.Index as BTI+import Data.Info   +-- * Lens operations on biosequences++{-+class BioSeqLenses b where+  -- | Lens into the first @k@ characters.+  bsTake :: Int -> Lens' b b+  -- | Lens into the last @k@ characters+  bsTakeEnd :: Int -> Lens' b b+  -- | Lens into all but the first @k@ characters+  bsDrop :: Int -> Lens' b b+  -- | Lens into all but the last @k@ characters+  bsDropEnd :: Int -> Lens' b b+  -- | Lens that splits at a position+  bsSplitAt :: Int -> Lens' b (b,b)+  -- | length of this biosequence+  bsLength :: Getter b Int+-}+ -- * Sequence identifiers -newtype SequenceIdentifier (which ∷ k) = SequenceIdentifier { _sequenceIdentifier ∷ ByteString }-  deriving (Data, Typeable, Generic, Eq, Ord, Read, Show)+newtype SequenceIdentifier (which :: k) = SequenceIdentifier { _sequenceIdentifier :: ByteString }+  deriving stock (Data, Typeable, Generic, Eq, Ord, Read, Show) makeWrapped ''SequenceIdentifier makePrisms ''SequenceIdentifier @@ -57,11 +79,18 @@   -newtype BioSequence (which ∷ k) = BioSequence {_bioSequence ∷ ByteString}-  deriving (Data, Typeable, Generic, Eq, Ord, Read, Show, Semigroup)+-- |+-- TODO provide extended annotation information on biosequences, too!++newtype BioSequence (which :: k) = BioSequence {_bioSequence :: ByteString}+  deriving stock (Data, Typeable, Generic, Eq, Ord, Read, Show)+  deriving newtype (Semigroup) makeWrapped ''BioSequence makePrisms ''BioSequence+makeLenses ''BioSequence +instance Hashable (BioSequence (which :: k))+ instance NFData (BioSequence w)  type instance Index (BioSequence w) = Int@@ -72,24 +101,47 @@   ix k = _BioSequence . ix k . iso (chr . fromIntegral) (fromIntegral . ord)   {-# Inline ix #-} -deriving instance Reversing (BioSequence w)+deriving newtype instance Reversing (BioSequence w)  instance IsString (BioSequence Void) where   fromString = BioSequence . BS.pack +instance Info (BioSequence w) where+  info (BioSequence s)+    | BS.length s <= 18 = BS.unpack s+    | otherwise         = BS.unpack h ++ ".." ++ BS.unpack l+    where (h,tl) = BS.splitAt 9 s+          (_,l ) = BS.splitAt (BS.length tl-9) tl +{-+instance BioSeqLenses (BioSequence w) where+  {-# Inline bsTake #-}+  bsTake k = lens (over _BioSequence (BS.take k)) (\old new -> new <> over _BioSequence (BS.drop k) old)+  {-# Inline bsTakeEnd #-}+  bsTakeEnd k = lens (over _BioSequence (\s -> BS.drop (BS.length s -k) s)) (\old new -> over _BioSequence (\s -> BS.take (BS.length s-k) s) old <> new)+  {-# Inline bsLength #-}+  bsLength = _BioSequence.to BS.length+  {-# Inline bsDrop #-}+  bsDrop k = lens (over _BioSequence (BS.drop k)) (\old new -> over _BioSequence (BS.take k) old <> new)+  {-# Inline bsDropEnd #-}+  bsDropEnd k = lens (over _BioSequence (\s -> BS.take (BS.length s -k) s)) (\old new -> over _BioSequence (\s -> BS.take (BS.length s-k) s) old <> new)+  {-# Inline bsSplitAt #-}+  bsSplitAt k = lens (\b -> (view (bsTake k) b, view (bsDrop k) b)) (\old (h,t) -> h <> t)+-} ++ -- * RNA  -- | -- -- TODO write that converts explicitly -mkRNAseq ∷ ByteString → BioSequence RNA+mkRNAseq :: ByteString -> BioSequence RNA mkRNAseq = BioSequence . BS.map go . BS.map toUpper   where go x | x `elem` acgu = x              | otherwise     = 'N'-        acgu ∷ String+        acgu :: String         acgu = "ACGU"  instance IsString (BioSequence RNA) where@@ -97,20 +149,23 @@  instance Arbitrary (BioSequence RNA) where   arbitrary = do-    k ← TQ.choose (0,100)+    k ← TQ.choose (0,30)     xs ← TQ.vectorOf k $ TQ.elements "ACGU"     return . BioSequence $ BS.pack xs-  shrink = view (to shrink)+  shrink = shrinkBioSequence +shrinkBioSequence (BioSequence b) = fmap BioSequence+  [ let (l,BS.drop 1 -> r) = BS.splitAt k b+    in BS.append l r | k <- [0 .. BS.length b -1] ]   -- * DNA -mkDNAseq ∷ ByteString → (BioSequence DNA)+mkDNAseq :: ByteString -> (BioSequence DNA) mkDNAseq = BioSequence . BS.map go . BS.map toUpper   where go x | x `elem` acgt = x              | otherwise     = 'N'-        acgt ∷ String+        acgt :: String         acgt = "ACGT"  instance IsString (BioSequence DNA) where@@ -127,11 +182,11 @@  -- * XNA -mkXNAseq ∷ ByteString → (BioSequence XNA)+mkXNAseq :: ByteString -> (BioSequence XNA) mkXNAseq = BioSequence . BS.map go . BS.map toUpper   where go x | x `elem` acgtu = x              | otherwise      = 'N'-        acgtu ∷ String+        acgtu :: String         acgtu = "ACGTU"  instance IsString (BioSequence XNA) where@@ -148,11 +203,11 @@  -- * Amino acid sequences -mkAAseq ∷ ByteString → (BioSequence AA)+mkAAseq :: ByteString -> (BioSequence AA) mkAAseq = BioSequence . BS.map go . BS.map toUpper   where go x | x `elem` aas = x              | otherwise    = 'X'-        aas ∷ String+        aas :: String         aas = "ARNDCEQGHILKMFPSTWYVUO"  instance IsString (BioSequence AA) where@@ -167,6 +222,8 @@   +{-+ -- * A window into a longer sequence with prefix/suffix information.  -- | Phantom-typed over two types, the type @w@ of the identifier, which can be@@ -175,59 +232,62 @@ -- location information and should be location or streamed location.  data BioSequenceWindow w ty loc = BioSequenceWindow-  { _bswIdentifier ∷ !(SequenceIdentifier w)+  { _bswIdentifier    :: !(SequenceIdentifier w)     -- ^ Identifier for this window. Typically some fasta identifier-  , _bswPrefix     ∷ !(BioSequence ty)-    -- ^ Any prefix for this sequence-  , _bswSequence   ∷ !(BioSequence ty)-    -- ^ The actual sequence, the infix-  , _bswSuffix     ∷ !(BioSequence ty)-    -- ^ any suffix-  , _bswLocation   ∷ !loc+  , _bswPrefix        :: !(BioSequence ty)+  , _bswInfix         :: !(BioSequence ty)+  , _bswSuffix        :: !(BioSequence ty)+  , _bswInfixLocation :: !loc+    -- ^ Location of the infix sequence   }   deriving (Data, Typeable, Generic, Eq, Ord, Read, Show) makeLenses ''BioSequenceWindow -instance (Reversing loc) ⇒ Reversing (BioSequenceWindow w ty loc) where+-- | Lens into the full sequence. May not change the sequence length++bswSequence :: Lens (BioSequenceWindow w ty loc) (BioSequenceWindow w ty' loc) (BioSequence ty) (BioSequence ty')+{-# Inlinable bswSequence #-}+bswSequence = lens (\w -> _bswPrefix w <> _bswInfix w <> _bswSuffix w)+                   (\w bs -> let (p,is) = bs^.bsSplitAt (w^.bswPrefix.bsLength)+                                 (i,s ) = is^.bsSplitAt (w^.bswInfix.bsLength)+                             in w { _bswPrefix = p, _bswInfix = i, _bswSuffix = s } )++-- | Get the position of the whole sequence++bswLocation :: ModifyLocation loc => Getter (BioSequenceWindow w ty loc) loc+{-# Inlinable bswLocation #-}+bswLocation = to $ \w -> locMoveLeftEnd (w^.bswPrefix.bsLength.to negate)+                 . locMoveRightEnd (w^.bswSuffix.bsLength) $ w^.bswInfixLocation++bswRetagW :: BioSequenceWindow w ty loc -> BioSequenceWindow v ty loc+{-# Inlinable bswRetagW #-}+bswRetagW = over bswIdentifier coerce++instance NFData loc => NFData (BioSequenceWindow w ty loc)++instance (Reversing loc) => Reversing (BioSequenceWindow w ty loc) where   {-# Inlinable reversing #-}   reversing bsw = bsw                 & bswPrefix .~ (bsw^.bswSuffix.reversed)                 & bswSuffix .~ (bsw^.bswPrefix.reversed)-                & bswSequence .~ (bsw^.bswSequence.reversed)-                & bswLocation .~ (bsw^.bswLocation.reversed)+                & bswInfix  .~ (bsw^.bswInfix.reversed)+                & bswInfixLocation .~ (bsw^.bswInfixLocation.reversed) --- | A lens into the full sequence information of a sequence window. One should--- *NOT* modify the length of the individual sequences. -bswFullSequence ∷ Lens' (BioSequenceWindow w ty k) (BioSequence ty)-{-# Inlinable bswFullSequence #-}-bswFullSequence = lens f t-  where f bsw = bsw^.bswPrefix <> bsw^.bswSequence <> bsw^.bswSuffix-        t bsw (BioSequence s) =-          let (pfx,ifxsfx) = BS.splitAt (bsw^.bswPrefix._BioSequence.to BS.length) s-              (ifx,sfx) = BS.splitAt (bsw^.bswSequence._BioSequence.to BS.length) ifxsfx-          in  bsw & bswPrefix._BioSequence .~ pfx-                  & bswSequence._BioSequence .~ ifx-                  & bswSuffix._BioSequence .~ sfx --- | For each element, attach the prefix as well.+-- | Provides an informative string indicating the current window being worked on. Requires length+-- of pretty string requested. Not for computers, but for logging what is being worked on. Should be+-- one line at most, not produce line breaks. ----- @1 2 3 4@ -> @01 12 23 34@+-- @...PFX [Start] IFX...IFX [End] SFX ...@+--+-- TODO possibly be better as a @Doc@ for prettier printing. -attachPrefixes ∷ (Monad m) ⇒ SP.Stream (SP.Of (BioSequenceWindow w ty k)) m r → SP.Stream (SP.Of (BioSequenceWindow w ty k)) m r-{-# Inlinable attachPrefixes #-}-attachPrefixes  =-  let go (Left pfx) w = Right (set bswPrefix pfx w)-      go (Right p)  w = Right (set bswPrefix (view bswSequence p) w)-  in  SP.map (\(Right w) → w) . SP.drop 1 . SP.scan go (Left $ BioSequence "") id+instance Info (BioSequenceWindow w ty loc) where+  info bsw = "todo: info bsw" --- | For each element, attach the suffix as well.------ @1 2 3 4@ -> @12 23 34 40@+-} -attachSuffixes ∷ (Monad m) ⇒ SP.Stream (SP.Of (BioSequenceWindow w ty k)) m r → SP.Stream (SP.Of (BioSequenceWindow w ty k)) m r-{-# Inlinable attachSuffixes #-}-attachSuffixes xs = undefined   -- * DNA/RNA@@ -235,51 +295,51 @@ -- | Simple case translation from @U@ to @T@. with upper and lower-case -- awareness. -rna2dna ∷ Char → Char+rna2dna :: Char -> Char rna2dna = \case-  'U' → 'T'-  'u' → 't'-  x   → x+  'U' -> 'T'+  'u' -> 't'+  x   -> x {-# Inline rna2dna #-}  -- | Single character RNA complement. -rnaComplement ∷ Char → Char+rnaComplement :: Char -> Char rnaComplement = \case-  'A' → 'U'-  'a' → 'u'-  'C' → 'G'-  'c' → 'g'-  'G' → 'C'-  'g' → 'c'-  'U' → 'A'-  'u' → 'a'-  x   → x+  'A' -> 'U'+  'a' -> 'u'+  'C' -> 'G'+  'c' -> 'g'+  'G' -> 'C'+  'g' -> 'c'+  'U' -> 'A'+  'u' -> 'a'+  x   -> x {-# Inline rnaComplement #-}  -- | Simple case translation from @T@ to @U@ with upper- and lower-case -- awareness. -dna2rna ∷ Char → Char+dna2rna :: Char -> Char dna2rna = \case-  'T' → 'U'-  't' → 'u'-  x   → x+  'T' -> 'U'+  't' -> 'u'+  x   -> x {-# Inline dna2rna #-}  -- | Single character DNA complement. -dnaComplement ∷ Char → Char+dnaComplement :: Char -> Char dnaComplement = \case-  'A' → 'T'-  'a' → 't'-  'C' → 'G'-  'c' → 'g'-  'G' → 'C'-  'g' → 'c'-  'T' → 'A'-  't' → 'a'-  x   → x+  'A' -> 'T'+  'a' -> 't'+  'C' -> 'G'+  'c' -> 'g'+  'G' -> 'C'+  'g' -> 'c'+  'T' -> 'A'+  't' -> 'a'+  x   -> x {-# Inline dnaComplement #-}  @@ -297,8 +357,8 @@ -- @@  class Transcribe f where-  type TranscribeTo f ∷ *-  transcribe ∷ Iso' f (TranscribeTo f)+  type TranscribeTo f :: *+  transcribe :: Iso' f (TranscribeTo f)  -- | Transcribe a DNA sequence into an RNA sequence. This does not @reverse@ -- the sequence!@@ -321,7 +381,7 @@ -- | The complement of a biosequence.  class Complement f where-  complement ∷ Iso' f f+  complement :: Iso' f f  instance Complement (BioSequence DNA) where   {-# Inline complement #-}@@ -335,15 +395,15 @@                    {-# Inline f #-}                in  iso f f -instance (Complement (BioSequence ty)) ⇒ Complement (BioSequenceWindow w ty k) where+{-+instance (Complement (BioSequence ty)) => Complement (BioSequenceWindow w ty k) where   {-# Inline complement #-}-  complement = let g = view complement-                   f = (\w → over bswSuffix g . over bswPrefix g . over bswSequence g $ w)-                   {-# Inline g #-}+  complement = let f = over bswPrefix (view complement) . over bswInfix (view complement) . over bswSuffix (view complement)                    {-# Inline f #-}                in  iso f f+-} -reverseComplement ∷ (Complement f, Reversing f) ⇒ Iso' f f+reverseComplement :: (Complement f, Reversing f) => Iso' f f {-# Inline reverseComplement #-} reverseComplement = reversed . complement 

@@ -40,7 +40,8 @@ -- Infernal users guide, p.42: log-odds score in log_2 (aka bits).  newtype Bitscore = Bitscore { getBitscore :: Double }-  deriving (Eq,Ord,Read,Show,Num,Fractional,Generic)+  deriving stock (Eq,Ord,Read,Show,Generic)+  deriving newtype (Num,Fractional)  instance Semiring Bitscore where   plus = (+)@@ -59,7 +60,7 @@ instance ToJSON    Bitscore instance NFData    Bitscore -deriving instance NumericLimits Bitscore+deriving newtype instance NumericLimits Bitscore  derivingUnbox "Bitscore"   [t| Bitscore -> Double |] [| getBitscore |] [| Bitscore |]

@@ -18,6 +18,7 @@ import Data.Vector.Unboxed.Deriving import GHC.Generics +import Algebra.Structure.Semiring import Numeric.Discretized import Numeric.Limits @@ -58,10 +59,26 @@ -- | Discretized @DG@.  newtype DDG = DDG { dDG ∷ Discretized (1 :% 100) }-  deriving (Eq,Ord,Num,Read,Show,Generic,Real,Enum)+  deriving (Eq,Ord,Num,Read,Generic,Real,Enum) +instance Show DDG where+  show (DDG e) = show e++ddg2Int :: DDG -> Int+ddg2Int (DDG (Discretized e)) = e+ derivingUnbox "DDG"-  [t| DDG → Int |]  [| getDiscretized . dDG |]  [| DDG . Discretized |]+  [t| DDG -> Int |]  [| getDiscretized . dDG |]  [| DDG . Discretized |]++instance Semiring DDG where+  plus  (DDG x) (DDG y) = DDG $ min x y+  times (DDG x) (DDG y) = DDG $ x `plus` y+  zero = DDG maxFinite+  one  = DDG zero+  {-# Inline plus  #-}+  {-# Inline times #-}+  {-# Inline zero  #-}+  {-# Inline one   #-}  --instance Hashable  DeltaDekaGibbs --instance Binary    DeltaDekaGibbs

@@ -72,7 +72,7 @@ -- | Delta between two 'Index' points.  delta :: forall t . KnownNat t => Index t -> Index t -> Int-delta i j = abs . IT.getIndex $ i - j+delta (Index i) (Index j) = abs $ i - j {-# Inline delta #-}  toInt ∷ forall t . KnownNat t ⇒ Index t → Int@@ -84,6 +84,16 @@ toInt0 :: forall t . KnownNat t => Index t -> Int toInt0 = IT.getIndex {-# Inline toInt0 #-}++-- | Return the index as an @Int@-style index that is one-based.++toInt1 ∷ forall t . KnownNat t ⇒ Index t → Int+{-# Inline toInt1 #-}+toInt1 = (+1) . toInt0++fromInt1 ∷ forall t . KnownNat t ⇒ Int → Index t+{-# Inline fromInt1 #-}+fromInt1 = fromInt0 . (subtract 1)  -- | As an index from an @Int@-style zero-based one. --

@@ -82,6 +82,10 @@   {-# Inline zeroBound' #-}   totalSize (LtIndex k) = [fromIntegral k]   {-# Inline totalSize #-}+  fromLinearIndex _ = Index+  {-# Inline [0] fromLinearIndex #-}+  showBound (LtIndex k) = ["LtIndex " ++ show k]+  showIndex (Index k) = ["Index " ++ show k]  instance (KnownNat t, IndexStream z) ⇒ IndexStream (z:.Index t) where   streamUp (ls:..LtIndex lf) (hs:..LtIndex ht) = flatten mk step $ streamUp ls hs

@@ -5,98 +5,249 @@  module Biobase.Types.Location where +import Control.DeepSeq import Control.Lens hiding (Index, index)+import Data.Coerce+import Data.Data+import Data.Data.Lens import GHC.Generics (Generic) import GHC.TypeNats import Prelude hiding (length)+import qualified Data.ByteString as BS+import qualified Streaming.Internal as SI+import qualified Streaming.Prelude as SP+import Text.Printf +import Biobase.Types.BioSequence import Biobase.Types.Index+import Biobase.Types.Position import Biobase.Types.Strand+import Data.Info   --- | Location information. -data Location = Location-  { _lStrand ∷ !Strand-  -- ^ On which strand are we-  , _lStart  ∷ !(Index 0)-  -- ^ Start, 0-based-  , _lLength ∷ !Int-  -- ^ number of characters in this location-  , _lTotalLength ∷ !Int-  -- ^ the total length of the "contig" (or whatever) this location is positioned in.-  } deriving (Eq,Ord,Read,Show,Generic)+-- | Operations on locations.++class ModifyLocation posTy seqTy where+  -- | Append to the left.+  locAppendLeft  :: seqTy -> Location i posTy seqTy -> Location i posTy seqTy+  -- | Append to the right.+  locAppendRight :: seqTy -> Location i posTy seqTy -> Location i posTy seqTy+  -- | Split a location.+  locSplitAt  :: Int -> Location i posTy seqTy -> (Location i posTy seqTy, Location i posTy seqTy)+  -- | Length of location+  locLength :: Location i posTy seqTy -> Int++locTake k = fst . locSplitAt k++locTakeEnd k loc = let l = locLength loc in snd $ locSplitAt (l-k) loc++locDrop k = snd . locSplitAt k++locDropEnd k loc = let l = locLength loc in fst $ locSplitAt (l-k) loc++locSplitEndAt k loc = let l = locLength loc in locSplitAt (l-k) loc++++data Location ident posTy seqTy = Location+  { _locIdentifier  :: !(SequenceIdentifier ident)+  , _locPosition    :: !posTy+  , _locSequence    :: !seqTy+  }+  deriving stock (Show,Data,Typeable,Generic) makeLenses ''Location-makePrisms ''Location -instance Reversing Location where-  {-# Inline reversing #-}-  reversing = undefined+instance (NFData p, NFData s) => NFData (Location i p s) +retagLocation :: Location i posTy seqTy -> Location j posTy seqTy+{-# Inline retagLocation #-}+retagLocation = over locIdentifier coerce --- | An isomorphism between locations, and triples of @Strand,Start,End@, where--- end is inclusive. For @length==0@ locations, this will mean @start<end@ on--- the plus strand.------ This should hold for all @k@, in @Index k@.+instance ModifyLocation FwdPosition (BioSequence w) where+  {-# Inline locAppendLeft #-}+  locAppendLeft s loc = let l = s^._BioSequence.to BS.length+    in loc & locSequence %~ (s <>) & locPosition %~ (\p -> if p^.fwdStrand == PlusStrand then p & fwdStart %~ (-. l) else p)+  {-# Inline locAppendRight #-}+  locAppendRight s loc = let l = s^._BioSequence.to BS.length+    in loc & locSequence %~ (<> s) & locPosition %~ (\p -> if p^.fwdStrand == MinusStrand then p & fwdStart %~ (-. l) else p)+  {-# Inline locSplitAt #-}+  locSplitAt k loc =+    let (h',t') = loc^.locSequence._BioSequence.to (BS.splitAt k)+        hl = BS.length h' ; tl = BS.length t'+        h = loc & locSequence._BioSequence .~ h' & locPosition %~ (\p -> if p^.fwdStrand == MinusStrand then p & fwdStart %~ (+. tl) else p)+        t = loc & locSequence._BioSequence .~ t' & locPosition %~ (\p -> if p^.fwdStrand == PlusStrand then p & fwdStart %~ (+. hl) else p)+    in  (h,t)+  {-# Inline locLength #-}+  locLength = view (locSequence._BioSequence.to BS.length) -startEndInclusive ∷ (KnownNat k) ⇒ Iso' Location (Strand, (Index k, Index k), Int)-{-# Inline startEndInclusive #-}-startEndInclusive = iso l2r r2l-  where l2r z = let s = z^.lStrand; f = z^.lStart; l = z^.lLength-                in  (s, (reIndex f, reIndex $ f +. l -. 1), z^.lTotalLength)-        r2l (s,(f,t),ttl) = Location s (reIndex f) (delta f t + 1) ttl+instance ModifyLocation FwdPosition Int where+  {-# Inline locAppendLeft #-}+  locAppendLeft k' loc = let k = max 0 $ min (loc^.locPosition.fwdStart.to toInt0) k' in+    loc & locSequence %~ (+ k) & locPosition %~ (\p -> if p^.fwdStrand == PlusStrand then p & fwdStart %~ (-. k) else p)+  {-# Inline locAppendRight #-}+  locAppendRight k' loc = let k = max 0 $ min (loc^.locPosition.fwdStart.to toInt0) k' in+    loc & locSequence %~ (+ k) & locPosition %~ (\p -> if p^.fwdStrand == MinusStrand then p & fwdStart %~ (-. k) else p)+  {-# Inline locSplitAt #-}+  locSplitAt k loc =+    let h' = max 0 . min k $ locLength loc+        t' = locLength loc - h'+        h = loc & locSequence .~ h' & locPosition %~ (\p -> if p^.fwdStrand == MinusStrand then p & fwdStart %~(+. t') else p)+        t = loc & locSequence .~ t' & locPosition %~ (\p -> if p^.fwdStrand == PlusStrand then p & fwdStart %~ (+. h') else p)+    in  (h,t)+  {-# Inline locLength #-}+  locLength = view locSequence +instance Reversing (Location i FwdPosition (BioSequence w)) where+  {-# Inline reversing #-}+  reversing = over (locSequence._BioSequence) BS.reverse . over (locPosition) reversing +instance Complement (BioSequence w) => Complement (Location i FwdPosition (BioSequence w)) where+  {-# Inline complement #-}+  complement = iso f f+    where f = over locSequence (view complement) --- | During streaming construction, it is possible that we know a feature is on--- the @-@ strand, but the length of the contig is not known yet.+instance (Info (BioSequence w)) => Info (Location i FwdPosition (BioSequence w)) where+  info loc = printf "%s %s %s" (loc^.locIdentifier^.to show) (show $ loc^.locPosition) (loc^.locSequence.to info)++-- | Will extract a substring for a given biosequence. It is allowed to hand in partially or not at+-- all overlapping locational information. This will yield empty resulting locations. --+-- This will convert the @FwdPosition@ strand, which in turn allows dealing with reverse-complement+-- searches.+-- -- @--- 0         1         2--- 012345678901234567890---   >---                    +        2 4    Location +  2 4---      <---                 Reversed 5 4    Location - 12 4--- 098765432109876543210--- 2         1         0+-- 0123456789+--    3.3 -- @------  -data PartialLocation-  -- | Location, when it is not yet known how long the contig will be.-  = PartialLocation-      { _plStrand ∷ !Strand-      , _plStart  ∷ !(Index 0)-      , _plLength ∷ !Int-      }-  -- | The reversed strand. However, we have an @plEnd@, not a @plStart@ now!-  | ReversedPartialLocation-      { _plStrand ∷ !Strand-      , _plEnd    ∷ !(Index 0)-      , _plLength ∷ !Int-      }-  deriving (Eq,Ord,Read,Show,Generic)-makeLenses ''PartialLocation-makePrisms ''PartialLocation+subLocation :: Location i FwdPosition (BioSequence w) -> (FwdPosition, Int) -> Location i FwdPosition (BioSequence w)+{-# Inline subLocation #-}+subLocation s (p',l)+  | ss==PlusStrand = locTake l $ locDrop d s+  | ss==MinusStrand = locTakeEnd l $ locDropEnd d s+  where ss = s^.locPosition.fwdStrand+        p = if ss == p'^.fwdStrand then p' else reversing p'+        d = delta (s^.locPosition.fwdStart) (p^.fwdStart) --- | Reversing a reversible location means moving the start to the end.+data PIS i p s = PIS+  { _pisPrefix  :: Maybe (Location i p s)+  , _pisInfix   :: !(Location i p s)+  , _pisSuffix  :: Maybe (Location i p s)+  }+  deriving stock (Show, Data)+makeLenses ''PIS -instance Reversing PartialLocation where+pis ifx = PIS Nothing ifx Nothing++retagPis :: PIS i p s -> PIS j p s+retagPis (PIS p i s) = PIS (fmap retagLocation p) (retagLocation i) (fmap retagLocation s)++-- | Given a @PIS@, this will return the @substring@ indicated by the location in the 2nd argument.+-- Allows for easy substring extraction, and retains the system of prefix/infix/suffix.+--+-- It is allowed to hand locations that only partially (or not at all) correspond to the @PIS@, but+-- then the resulting @PIS@ will be empty!++subPisLocation :: PIS i FwdPosition (BioSequence w) -> (FwdPosition, Int) -> PIS i FwdPosition (BioSequence w)+{-# Inline subPisLocation #-}+subPisLocation pis loc =+  let f z = subLocation z loc+  in  over (pisPrefix._Just) f . over pisInfix f $ over (pisSuffix._Just) f pis++instance (Reversing (Location i FwdPosition (BioSequence w))) => Reversing (PIS i FwdPosition (BioSequence w)) where   {-# Inline reversing #-}-  reversing = \case-    PartialLocation s t l → ReversedPartialLocation (s^.reversed) t l+  reversing pis+    = over (pisPrefix._Just) reversing . over pisInfix reversing . over (pisSuffix._Just) reversing+    . set pisPrefix (pis^.pisSuffix) . set pisSuffix (pis^.pisPrefix) $ pis --- An isomorphism between a 'Location' and the pair @('PartialLocation',Int)@--- exists.+instance Complement (BioSequence w) => Complement (PIS i FwdPosition (BioSequence w)) where+  {-# Inline complement #-}+  complement =+    let f = over pisInfix (view complement) . over (pisPrefix._Just) (view complement) . over (pisSuffix._Just) (view complement)+    in  iso f f -locationPartial ∷ Iso' Location (PartialLocation,Int)-{-# Inline locationPartial #-}-locationPartial = iso l2r r2l where-  l2r l = (PartialLocation (view lStrand l) (view lStart l) (view lLength l), l^.lTotalLength)-  r2l (p,z) = case p of PartialLocation s t l → Location s t l z-                        ReversedPartialLocation s e l-                          | s `elem` [PlusStrand,MinusStrand] → Location s (index $ z- getIndex e -l) l z-                          | otherwise                         → Location s e l z+pisSequence :: Lens (PIS i p (BioSequence s)) (PIS i p (BioSequence t)) (BioSequence s) (BioSequence t)+{-# Inline pisSequence #-}+pisSequence = lens f t where+  v = view (locSequence.bioSequence)+  f (PIS p i s) = BioSequence $ maybe BS.empty v p `BS.append` v i `BS.append` maybe BS.empty v s+  t (PIS p i s) (BioSequence str) =+    let (pfx,ifxsfx) = over _1 BioSequence   $ BS.splitAt (maybe 0 (BS.length . v) p) str+        (ifx,sfx   ) = over both BioSequence $ BS.splitAt (BS.length $ v i) ifxsfx+    in  PIS (set (_Just . locSequence) pfx p) (set locSequence ifx i) (set (_Just . locSequence) sfx s)++++-- | Given a @Location@ with a @BioSequence@, replace the sequence with its length.++locAsLength :: Location i FwdPosition (BioSequence w) -> Location i FwdPosition Int+{-# Inline locAsLength #-}+locAsLength = over locSequence (view (_BioSequence.to BS.length))++++-- | Provides a range in a notation as used by blast, for example. This+-- isomorphism can translate back as well. @FwdLocation - 8 4 ^. blastRange1 ==+-- 9 6 MinusStrand@, since these ranges are 1-based and start and end included.++blastRange1 :: (Location i FwdPosition Int) -> (Int,Int,Strand)+{-# Inline blastRange1 #-}+blastRange1 = f -- iso f t+  where+    f loc =+      let s = loc^.locPosition.fwdStart.to toInt1+          l = loc^.locSequence+          pm = loc^.locPosition.fwdStrand+      in  case pm of PlusStrand -> (s,s+l,pm) ; MinusStrand -> (s+l,s,pm)+--    t (x,y,pm) =+--      let s = fromInt1 x+--          l = 1 + abs (x-y)+--      in  Location (FwdPosition pm s) l++++-- | For each element, attach the prefix as well. The @Int@ indicates the maximal prefix length to+-- attach.+--+-- @1 2 3 4@ -> @01 12 23 34@+--+-- TODO are we sure this is correct for @MinusStrand@?++attachPrefixes+  :: ( Monad m, ModifyLocation p s )+  => Int+  -> SP.Stream (SP.Of (PIS i p s)) m r+  -> SP.Stream (SP.Of (PIS i p s)) m r+{-# Inlinable attachPrefixes #-}+attachPrefixes k = SP.map (\(Just w) -> w) . SP.drop 1 . SP.scan go Nothing id+  where+    go Nothing = Just+    go (Just p) = Just . set pisPrefix (Just . locTakeEnd k $ view pisInfix p)++++-- | For each element, attach the suffix as well.+--+-- @1 2 3 4@ -> @12 23 34 40@++attachSuffixes+  :: ( Monad m, ModifyLocation p s )+  => Int+  -> SP.Stream (SP.Of (PIS i p s)) m r+  -> SP.Stream (SP.Of (PIS i p s)) m r+{-# Inlinable attachSuffixes #-}+attachSuffixes k = loop Nothing+  where+    loop Nothing = \case+      SI.Return r -> SI.Return r+      SI.Effect m -> SI.Effect $ fmap (loop Nothing) m+      SI.Step (a SP.:> rest) -> loop (Just a) rest+    loop (Just p) = \case+      SI.Return r -> SI.Step (p SP.:> SI.Return r)+      SI.Effect m -> SI.Effect $ fmap (loop (Just p)) m+      SI.Step (a SP.:> rest) ->+        let p' = p & set pisSuffix (Just . locTake k $ view pisInfix a)+        in  SI.Step (p' SP.:> loop (Just a) rest) 

@@ -0,0 +1,163 @@++-- | Annotate the genomic @position@ of features or elements. A @position@ has strand information,+-- and different ways to encode where a feature is located. The @position@ points to the first+-- element (e.g. nucleotide).+--+-- Together with the 'Biobase.Types.Location' module, it becomes possible to annotate substrings.++module Biobase.Types.Position where++import Control.DeepSeq+import Control.Lens hiding (Index, index)+import Data.Data+import GHC.Generics (Generic)+import GHC.TypeNats+import Prelude hiding (length)+import Text.Printf++import Biobase.Types.Index+import Biobase.Types.Strand+import Data.Info++{-++-- | Location information.++data Location = Location+  { _lStrand :: !Strand+  -- ^ On which strand are we+  , _lStart  :: !(Index 0)+  -- ^ Start, 0-based+  , _lLength :: !Int+  -- ^ number of characters in this location+  , _lTotalLength :: !Int+  -- ^ the total length of the "contig" (or whatever) this location is positioned in.+  } deriving (Eq,Ord,Read,Show,Generic)+makeLenses ''Location+makePrisms ''Location++instance NFData Location++instance Semigroup Location where+  x <> y = let f z = z { _lLength = _lLength x + _lLength y }+    in case x^.lStrand of+      MinusStrand  -> f y+      _otherStrand -> f x+  {-# Inline (<>) #-}++--instance Reversing Location where+--  {-# Inline reversing #-}+--  reversing = undefined+++-- | An isomorphism between locations, and triples of @Strand,Start,End@, where+-- end is inclusive. For @length==0@ locations, this will mean @start<end@ on+-- the plus strand.+--+-- This should hold for all @k@, in @Index k@.++startEndInclusive :: (KnownNat k) => Iso' Location (Strand, (Index k, Index k), Int)+{-# Inline startEndInclusive #-}+startEndInclusive = iso l2r r2l+  where l2r z = let s = z^.lStrand; f = z^.lStart; l = z^.lLength+                in  (s, (reIndex f, reIndex $ f +. l -. 1), z^.lTotalLength)+        r2l (s,(f,t),ttl) = Location s (reIndex f) (delta f t + 1) ttl++-}++++-- | During streaming construction, it is possible that we know a feature is on the @-@ strand, but+-- the length of the contig is not known yet. In that case, 'FwdPosition' allows expressing the hit+-- in the coordinate system of the plus strand. Tools like blast do something similar, and express+-- locations on the minus as @y-x@ with @y>x@.+--+-- @+-- 0123456789+--  >-->+--      <--<+-- 9876543210+-- @+--+-- ++data FwdPosition+  -- | "Plus"-based location.+  = FwdPosition+      { _fwdStrand :: !Strand+      -- ^ Strand we are on+      , _fwdStart  :: !(Index 0)+      -- ^ Start of the hit on the plus strand+      }+  deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)+makeLenses ''FwdPosition+makePrisms ''FwdPosition++instance NFData FwdPosition++instance Info FwdPosition where+  info (FwdPosition s x) = printf "%s %d" (show s) (toInt0 x)++-- | Reversing a reversible location means moving the start to the end.++instance Reversing FwdPosition where+  {-# Inline reversing #-}+  reversing x = case x^.fwdStrand of+    PlusStrand    -> set fwdStrand MinusStrand $ x+    MinusStrand   -> set fwdStrand PlusStrand  $ x+    UnknownStrand -> x++{-+++-- | Combining two FwdLocations yields the sum of their lengths. This assumes+-- that @x@ and @y@ are next to each other, or that it is ok if the @y@+-- @fwdStart@ information may be lost.+--+-- TODO provide associativity test in @properties@.++instance Semigroup FwdLocation where+  x <> y = over fwdLength (+ view fwdLength y) x+  {-# Inline (<>) #-}++instance ModifyLocation FwdLocation where+  locMoveLeftEnd k = over fwdStart (+. k) . over fwdLength (subtract k)+  locMoveRightEnd k = over fwdLength (+k)++-- | Given a location, take at most @k@ elements, and return a location after+-- this change.++fwdLocationTake :: Int -> FwdLocation -> FwdLocation+{-# Inline fwdLocationTake #-}+fwdLocationTake k' x =+  let l = x^.fwdLength+      k = max 0 $ min k' l      -- deal with at most the length of the location+  in case x^.fwdStrand of+    MinusStrand  -> set fwdLength k $ over fwdStart (+. (l-k)) x+    _otherStrand -> set fwdLength k $                          x++-- | Given a location, drop at most @k@ elements, and return a location after+-- this change.+--+-- Note that @fwdLocationDrop 4 (FwdLocation PlusStrand 0 4) == FwdLocation 4 0@++fwdLocationDrop :: Int -> FwdLocation -> FwdLocation+{-# Inline fwdLocationDrop #-}+fwdLocationDrop k' x =+  let l = x^.fwdLength+      k = max 0 $ min k' l+  in case x^.fwdStrand of+    MinusStrand  -> set fwdLength (l-k) $                            x+    _otherStrand -> set fwdLength (l-k) $ over fwdStart (+. min k l) x++-- -- An isomorphism between a 'Location' and the pair @('FwdLocation',Int)@+-- -- exists.+-- +-- locationPartial :: Iso' Location (FwdLocation,Int)+-- {-# Inline locationPartial #-}+-- locationPartial = iso l2r r2l where+--   l2r l = undefined+--   r2l (p,z) = undefined++-}+

@@ -44,15 +44,15 @@   readsPrec _ xs = do     (pm,s) <- lex xs     case pm of-      "PlusStrand" → return (PlusStrand, s)-      "MinusStrand" → return (MinusStrand, s)-      "NotStranded" → return (NotStranded, s)-      "UnknownStrand" → return (UnknownStrand, s)-      [x] | x `elem` ("+Pp" ∷ String) → return (PlusStrand,s)-          | x `elem` ("-Mm" ∷ String) → return (MinusStrand,s)-          | x `elem` ("."   ∷ String) → return (NotStranded,s)-          | x `elem` ("?"   ∷ String) → return (UnknownStrand,s)-      _ → []+      "PlusStrand" -> return (PlusStrand, s)+      "MinusStrand" -> return (MinusStrand, s)+      "NotStranded" -> return (NotStranded, s)+      "UnknownStrand" -> return (UnknownStrand, s)+      [x] | x `elem` ("+Pp" :: String) -> return (PlusStrand,s)+          | x `elem` ("-Mm" :: String) -> return (MinusStrand,s)+          | x `elem` ("."   :: String) -> return (NotStranded,s)+          | x `elem` ("?"   :: String) -> return (UnknownStrand,s)+      _ -> []  instance Bounded Strand where   minBound = PlusStrand@@ -112,6 +112,10 @@   {-# Inline zeroBound' #-}   totalSize (LtStrand (Strand k)) = [ fromIntegral (fromEnum k + 1) ]   {-# Inline totalSize #-}+  fromLinearIndex _ = Strand+  {-# Inline [0] fromLinearIndex #-}+  showBound (LtStrand k) = ["LtStrand " ++ show k]+  showIndex (Strand k) = ["Strand " ++ show k]  instance IndexStream z => IndexStream (z:.Strand) where   streamUp (ls:..LtStrand (Strand lf)) (hs:..LtStrand (Strand ht)) = flatten mk step $ streamUp ls hs

@@ -1,8 +1,8 @@ cabal-version:  2.2 name:           BiobaseTypes-version:        0.2.0.1-author:         Christian Hoener zu Siederdissen, 2015 - 2019-copyright:      Christian Hoener zu Siederdissen, 2015 - 2019+version:        0.2.1.0+author:         Christian Hoener zu Siederdissen, 2015 - 2021+copyright:      Christian Hoener zu Siederdissen, 2015 - 2021 homepage:       https://github.com/choener/BiobaseTypes bug-reports:    https://github.com/choener/BiobaseTypes/issues maintainer:     choener@bioinf.uni-leipzig.de@@ -11,7 +11,7 @@ license-file:   LICENSE build-type:     Simple stability:      experimental-tested-with:    GHC == 8.4.4+tested-with:    GHC == 8.8, GHC == 8.10, GHC == 9.0 synopsis:       Collection of types for bioinformatics description:                 Types used in a number of bioinformatics libraries.@@ -58,9 +58,10 @@                , vector-th-unbox          >= 0.2                --                , bimaps                   == 0.1.0.*+               , DPutils                  == 0.1.1.*                , ForestStructures         == 0.0.1.*-               , PrimitiveArray           == 0.9.1.*-               , SciBaseTypes             == 0.1.0.*+               , PrimitiveArray           >= 0.10.1.1 && < 0.10.2+               , SciBaseTypes             == 0.1.1.*   default-language:     Haskell2010   default-extensions: BangPatterns@@ -69,6 +70,7 @@                     , DeriveFoldable                     , DeriveGeneric                     , DeriveTraversable+                    , DerivingStrategies                     , FlexibleContexts                     , FlexibleInstances                     , GeneralizedNewtypeDeriving@@ -87,7 +89,9 @@                     , TypeFamilies                     , TypeOperators                     , TupleSections+                    , UndecidableInstances                     , UnicodeSyntax+                    , ViewPatterns   ghc-options:     -O2 -funbox-strict-fields @@ -108,6 +112,7 @@     Biobase.Types.Location     Biobase.Types.Names     Biobase.Types.Names.Internal+    Biobase.Types.Position     Biobase.Types.ReadingFrame     Biobase.Types.Shape     Biobase.Types.Strand@@ -125,12 +130,13 @@     exitcode-stdio-1.0   main-is:     properties.hs-  ghc-options:-    -threaded -rtsopts -with-rtsopts=-N+--  ghc-options:+--    -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs:     tests   build-depends: base                , tasty              >= 0.11+               , tasty-hunit        >= 0.10                , tasty-quickcheck   >= 0.8                , tasty-th           >= 0.1                --

@@ -1,4 +1,5 @@-[![Build Status](https://travis-ci.org/choener/BiobaseTypes.svg?branch=master)](https://travis-ci.org/choener/BiobaseTypes)+![github action: master](https://github.com/choener/BiobaseTypes/actions/workflows/ci.yml/badge.svg?branch=master)+![github action: hackage](https://github.com/choener/BiobaseTypes/actions/workflows/hackage.yml/badge.svg)  # BiobaseTypes 

@@ -1,3 +1,9 @@+0.2.1.0+-------++- CI/hackage github actions+- dependency updates+ 0.2.0.1 ------- 

@@ -5,17 +5,21 @@ import           Debug.Trace import qualified Data.ByteString.Char8 as BS8 import           Test.QuickCheck.Modifiers-import           Test.QuickCheck.Property+import           Test.QuickCheck.Property () import           Test.Tasty+import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck (testProperty) import           Test.Tasty.TH  import           Biobase.Types.BioSequence import           Biobase.Types.Bitscore+import           Biobase.Types.Location import           Biobase.Types.Shape+import           Biobase.Types.Strand import           Biobase.Types.Structure-+import           Biobase.Types.Index as I +{-  -- * Bitscore conversions @@ -63,12 +67,68 @@         flp ']' = '['         flp x   = x +prop_FwdLocationPlusTake (NonNegative (p ∷ Int), NonNegative (l ∷ Int), NonNegative (k ∷ Int))+  | check       = True+  | otherwise   = traceShow (p,l,k,fwdloc,taken,manual) check+  where fwdloc  = FwdLocation PlusStrand (I.index p) l+        check   = taken == manual+        taken   = fwdLocationTake k fwdloc+        manual  = FwdLocation PlusStrand (I.index p) (max 0 $ min l k) +prop_FwdLocationPlusDrop (NonNegative (p ∷ Int), NonNegative (l ∷ Int), NonNegative (k ∷ Int))+  | check       = True+  | otherwise   = traceShow (p,l,k,fwdloc,dropped,manual) check+  where fwdloc  = FwdLocation PlusStrand (I.index p) l+        check   = dropped == manual+        dropped = fwdLocationDrop k fwdloc+        manual  = FwdLocation PlusStrand (I.index $ p + min l k) (max 0 $ l-k) +-- | Given a BioSequenceWindow, and different takes and drops, check wether what we have corresponds to what we want++case_bswTakeDrop ∷ Assertion+case_bswTakeDrop = do+  let wp = BioSequenceWindow @"DNA" @DNA "test" 1 "ACGTAC" 3 (FwdLocation PlusStrand 0 6)+      wm = BioSequenceWindow @"DNA" @DNA "test" 3 "CATGCA" 1 (FwdLocation MinusStrand 0 6)+  --+  bswTake 0 wp @?= BioSequenceWindow "test" 0 ""       0 (FwdLocation PlusStrand 0 0)+  bswTake 1 wp @?= BioSequenceWindow "test" 1 "A"      0 (FwdLocation PlusStrand 0 1)+  bswTake 2 wp @?= BioSequenceWindow "test" 1 "AC"     0 (FwdLocation PlusStrand 0 2)+  bswTake 6 wp @?= BioSequenceWindow "test" 1 "ACGTAC" 3 (FwdLocation PlusStrand 0 6)+  --+  bswDrop 0 wp @?= BioSequenceWindow "test" 1 "ACGTAC" 3 (FwdLocation PlusStrand 0 6)+  bswDrop 1 wp @?= BioSequenceWindow "test" 0  "CGTAC" 3 (FwdLocation PlusStrand 1 5)+  bswDrop 6 wp @?= BioSequenceWindow "test" 0       "" 0 (FwdLocation PlusStrand 6 0)+  --+  bswTake 0 wm @?= BioSequenceWindow "test" 0 ""       0 (FwdLocation MinusStrand 6 0)+  bswTake 1 wm @?= BioSequenceWindow "test" 1 "C"      0 (FwdLocation MinusStrand 5 1)+  bswTake 2 wm @?= BioSequenceWindow "test" 2 "CA"     0 (FwdLocation MinusStrand 4 2)+  bswTake 3 wm @?= BioSequenceWindow "test" 3 "CAT"    0 (FwdLocation MinusStrand 3 3)+  bswTake 4 wm @?= BioSequenceWindow "test" 3 "CATG"   0 (FwdLocation MinusStrand 2 4)+  bswTake 5 wm @?= BioSequenceWindow "test" 3 "CATGC"  0 (FwdLocation MinusStrand 1 5)+  bswTake 6 wm @?= BioSequenceWindow "test" 3 "CATGCA" 1 (FwdLocation MinusStrand 0 6)+  --+  bswDrop 0 wm @?= BioSequenceWindow "test" 3 "CATGCA" 1 (FwdLocation MinusStrand 0 6)+  bswDrop 1 wm @?= BioSequenceWindow "test" 2  "ATGCA" 1 (FwdLocation MinusStrand 0 5)+  bswDrop 2 wm @?= BioSequenceWindow "test" 1   "TGCA" 1 (FwdLocation MinusStrand 0 4)+  bswDrop 5 wm @?= BioSequenceWindow "test" 0      "A" 1 (FwdLocation MinusStrand 0 1)+  bswDrop 6 wm @?= BioSequenceWindow "test" 0       "" 0 (FwdLocation MinusStrand 0 0)+  --+  -- TODO consider having [take,take,drop,drop], generate all permutations;+  -- they should all yield the same result.+  --++++ -- * generic stuff  a ~= b = abs (b-a) <= 10e-6  main :: IO () main = $(defaultMainGenerator)++-}++main :: IO ()+main = return ()