BiobaseXNA 0.9.3.1 → 0.10.0.0

raw patch · 12 files changed

+418/−259 lines, 12 filesdep +BiobaseTypesdep +ForestStructuresdep +attoparsecdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: BiobaseTypes, ForestStructures, attoparsec, mtl

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• Biobase/Primary/Nuc/Conversion.hs +85/−56
• Biobase/Primary/Nuc/DNA.hs +9/−1
• Biobase/Primary/Nuc/RNA.hs +10/−2
• Biobase/Secondary.hs +5/−5
• Biobase/Secondary/Basepair.hs +88/−142
• Biobase/Secondary/Convert.hs +91/−0
• Biobase/Secondary/Diagrams.hs +2/−0
• Biobase/Secondary/Isostericity.hs +4/−4
• Biobase/Secondary/New.hs +101/−0
• Biobase/Secondary/Vienna.hs +3/−46
• BiobaseXNA.cabal +15/−3
• changelog.md +5/−0

@@ -9,8 +9,11 @@  module Biobase.Primary.Nuc.Conversion where +import           Control.Lens (iso, from) import qualified Data.Vector.Unboxed as VU +import           Biobase.Types.Sequence (Transcribe(..))+ import           Biobase.Primary.Letter (Letter(..), Primary) import qualified Biobase.Primary.Nuc.DNA as D import qualified Biobase.Primary.Nuc.RNA as R@@ -84,67 +87,93 @@   --- * Reverse-complement of characters.+-- ** Transcription between RNA and DNA. Both on the individual sequence level,+-- and on the level of primary sequence data. --- | Produce the complement of a RNA or DNA sequence. Does intentionally--- not work for XNA sequences as it is not possible to uniquely translate--- @A@ into either @U@ or @T@.+instance Transcribe (Letter R.RNA) where+  type TranscribeTo (Letter R.RNA) = Letter D.DNA+  transcribe = iso rnaTdna dnaTrna+  {-# Inline transcribe #-} -class Complement s t where-    complement :: s -> t+instance Transcribe (Letter D.DNA) where+  type TranscribeTo (Letter D.DNA) = Letter R.RNA+  transcribe = from transcribe+  {-# Inline transcribe #-} --- | To 'transcribe' a DNA sequence into RNA we reverse the complement of--- the sequence.+instance Transcribe (Primary R.RNA) where+  type TranscribeTo (Primary R.RNA) = Primary D.DNA+  transcribe = iso (VU.map rnaTdna) (VU.map dnaTrna)+  {-# Inline transcribe #-} -transcribe :: Primary D.DNA -> Primary R.RNA-transcribe = VU.reverse . complement+instance Transcribe (Primary D.DNA) where+  type TranscribeTo (Primary D.DNA) = Primary R.RNA+  transcribe = iso (VU.map dnaTrna) (VU.map rnaTdna)+  {-# Inline transcribe #-} -instance Complement (Letter R.RNA) (Letter R.RNA) where-    complement = \case-      R.A -> R.U-      R.C -> R.G-      R.G -> R.C-      R.U -> R.A-      R.N -> R.N -instance Complement (Letter D.DNA) (Letter D.DNA) where-    complement = \case-      D.A -> D.T-      D.C -> D.G-      D.G -> D.C-      D.T -> D.A-      D.N -> D.N--instance Complement (Letter D.DNA) (Letter R.RNA) where-    complement = \case-      D.A -> R.U-      D.C -> R.G-      D.G -> R.C-      D.T -> R.A-      D.N -> R.N--instance Complement (Letter R.RNA) (Letter D.DNA) where-    complement = \case-      R.A -> D.T-      R.C -> D.G-      R.G -> D.C-      R.U -> D.A-      R.N -> D.N--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-}-#else-instance-#endif-  ( Complement s t, VU.Unbox s, VU.Unbox t)-  => Complement (VU.Vector s) (VU.Vector t)-  where complement = VU.map complement+-- TODO to be removed soon -#if __GLASGOW_HASKELL__ >= 710-instance {-# Overlappable #-}-#else-instance-#endif-  ( Complement s t, Functor f) => Complement (f s) (f t)-  where complement = fmap complement+---- * Reverse-complement of characters.+--+---- | Produce the complement of a RNA or DNA sequence. Does intentionally+---- not work for XNA sequences as it is not possible to uniquely translate+---- @A@ into either @U@ or @T@.+--+--class Complement s t where+--    complement :: s -> t+--+---- | To 'transcribe' a DNA sequence into RNA we reverse the complement of+---- the sequence.+--+--transcribe :: Primary D.DNA -> Primary R.RNA+--transcribe = VU.reverse . complement+--+--instance Complement (Letter R.RNA) (Letter R.RNA) where+--    complement = \case+--      R.A -> R.U+--      R.C -> R.G+--      R.G -> R.C+--      R.U -> R.A+--      R.N -> R.N+--+--instance Complement (Letter D.DNA) (Letter D.DNA) where+--    complement = \case+--      D.A -> D.T+--      D.C -> D.G+--      D.G -> D.C+--      D.T -> D.A+--      D.N -> D.N+--+--instance Complement (Letter D.DNA) (Letter R.RNA) where+--    complement = \case+--      D.A -> R.U+--      D.C -> R.G+--      D.G -> R.C+--      D.T -> R.A+--      D.N -> R.N+--+--instance Complement (Letter R.RNA) (Letter D.DNA) where+--    complement = \case+--      R.A -> D.T+--      R.C -> D.G+--      R.G -> D.C+--      R.U -> D.A+--      R.N -> D.N+--+-- #if __GLASGOW_HASKELL__ >= 710+-- instance {-# OVERLAPPING #-}+-- #else+-- instance+-- #endif+--   ( Complement s t, VU.Unbox s, VU.Unbox t)+--   => Complement (VU.Vector s) (VU.Vector t)+--   where complement = VU.map complement+-- +-- #if __GLASGOW_HASKELL__ >= 710+-- instance {-# Overlappable #-}+-- #else+-- instance+-- #endif+--   ( Complement s t, Functor f) => Complement (f s) (f t)+--   where complement = fmap complement 

@@ -1,6 +1,8 @@  module Biobase.Primary.Nuc.DNA where +import           Control.Category ((>>>))+import           Control.Lens (Iso', iso) import           Data.Aeson import           Data.Char (toUpper) import           Data.Ix (Ix(..))@@ -14,7 +16,6 @@ import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VGM import qualified Data.Vector.Unboxed as VU-import           Control.Category ((>>>))  import           Biobase.Primary.Bounds import           Biobase.Primary.Letter@@ -70,6 +71,13 @@   T -> 'T'   N -> 'N' {-# INLINE dnaChar #-}++-- | An isomorphism from 'Char' to 'Letter DNA'. This assumes that the+-- underlying @Char@s actually represent a DNA sequence. This allows typesafe+-- modification of DNA sequences since only @[A,C,G,T,N]@ are allowed.++cdna ∷ Iso' Char (Letter DNA)+cdna = iso charDNA dnaChar  instance Show (Letter DNA) where     show c = [dnaChar c]

@@ -1,12 +1,15 @@  module Biobase.Primary.Nuc.RNA where +import           Control.Category ((>>>))+import           Control.Lens (Iso', iso) import           Data.Aeson import           Data.Char (toUpper) import           Data.Ix (Ix(..)) import           Data.Primitive.Types import           Data.String import           Data.Tuple (swap)+import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T@@ -14,8 +17,6 @@ import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VGM import qualified Data.Vector.Unboxed as VU-import           Control.Category ((>>>))-import qualified Data.ByteString.Builder as BB  import           Biobase.Primary.Bounds import           Biobase.Primary.Letter@@ -84,6 +85,13 @@   U -> 'U'   N -> 'N' {-# INLINE rnaChar #-}            ++-- | An isomorphism from 'Char' to 'Letter RNA'. This assumes that the+-- underlying @Char@s actually represent an RNA sequence. This allows typesafe+-- modification of RNA sequences since only @[A,C,G,U,N]@ are allowed.++crna ∷ Iso' Char (Letter RNA)+crna = iso charRNA rnaChar  instance Show (Letter RNA) where     show c = [rnaChar c]

@@ -1,19 +1,19 @@  module Biobase.Secondary-  ( module Biobase.Secondary.Basepair-  , module Biobase.Secondary.Constraint+--  ( module Biobase.Secondary.Basepair+  ( module Biobase.Secondary.Constraint   , module Biobase.Secondary.Diagrams   , module Biobase.Secondary.Isostericity   , module Biobase.Secondary.Pseudoknots   , module Biobase.Secondary.Structure-  , module Biobase.Secondary.Vienna+--  , module Biobase.Secondary.Vienna   ) where -import Biobase.Secondary.Basepair+--import Biobase.Secondary.Basepair import Biobase.Secondary.Constraint import Biobase.Secondary.Diagrams import Biobase.Secondary.Isostericity import Biobase.Secondary.Pseudoknots import Biobase.Secondary.Structure-import Biobase.Secondary.Vienna+--import Biobase.Secondary.Vienna 

@@ -1,12 +1,11 @@ -{-# LANGUAGE FunctionalDependencies #-}---- {-# LANGUAGE OverlappingInstances #-}- -- | Secondary structure: define basepairs as Int-tuples, the three edges, a -- nucleotide can use for pairing and the cis/trans isomerism. Both edges and -- cis/trans come with a tag for "unknown". --+-- Since we often want to make "pairedness" explicit, we have a newtype for+-- this as well.+-- -- TODO set ext-annotations to be (isomerism,edge,edge) and have a asString -- instance to read "cWW" "tSH" and other notation. @@ -18,8 +17,9 @@ import           Data.Ix (Ix(..)) import           Data.List as L import           Data.Primitive.Types-import           Data.Serialize+import           Data.Serialize (Serialize) import           Data.Tuple (swap)+import           Data.Vector.Fusion.Stream.Monadic (map,Step(..)) import           Data.Vector.Unboxed.Deriving import           GHC.Base (remInt,quotInt) import           GHC.Generics@@ -28,10 +28,93 @@ import qualified Data.Vector.Unboxed as VU import           Text.Read +import           Data.PrimitiveArray hiding (Complement(..),map)+ import           Biobase.Primary+import           Biobase.Primary.Nuc.RNA+import           Biobase.Primary.Nuc   +-- * Newtype for efficient basepair encoding.++-- | Encode a base pair as a single @Int@.++newtype Basepair = BP { getBP :: Int }+  deriving (Eq,Ord,Ix,Generic)++derivingUnbox "Basepair"+  [t| Basepair -> Int |] [| getBP |] [| BP |]++instance Binary    Basepair+instance Serialize Basepair+instance FromJSON  Basepair+instance ToJSON    Basepair++deriving instance Index Basepair++instance IndexStream z => IndexStream (z:.Basepair) where+  streamUp (ls:.BP l) (hs:.BP h) = flatten mk step $ streamUp ls hs+    where mk z = return (z,l)+          step (z,k)+            | k > h     = return $ Done+            | otherwise = return $ Yield (z:.BP k) (z,k+1)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline streamUp #-}+  streamDown (ls:.BP l) (hs:.BP h) = flatten mk step $ streamDown ls hs+    where mk z = return (z,h)+          step (z,k)+            | k < l     = return $ Done+            | otherwise = return $ Yield (z:.BP k) (z,k-1)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline streamDown #-}++instance IndexStream Basepair++pattern AA   = BP  0+pattern AC   = BP  1+pattern AG   = BP  2+pattern AU   = BP  3+pattern CA   = BP  4+pattern CC   = BP  5+pattern CG   = BP  6+pattern CU   = BP  7+pattern GA   = BP  8+pattern GC   = BP  9+pattern GG   = BP 10+pattern GU   = BP 11+pattern UA   = BP 12+pattern UC   = BP 13+pattern UG   = BP 14+pattern UU   = BP 15+pattern NS   = BP 16+pattern NoBP = BP 17++{-+class MkBasepair a where+  mkBasepair :: a -> Basepair+  fromBasepair :: Basepair -> a++-- | If we get a "legal" base pair, we just create it, all other+-- combinations yield 'NoBP'. Non-standard base pairs have to be created+-- explicitly using @NS@. When going back to @a@, non-standard and no pair+-- yield @(N,N)@.++instance MkBasepair (Letter RNA,Letter RNA) where+  mkBasepair (l,r)+    | l >= A && l <= U && r >= A && r <= U+    = BP $ 4 * getLetter l + getLetter r+    | otherwise = NoBP+  fromBasepair k+    | k == NoBP || k == NS = (N,N)+    | otherwise = let (l,r) = getBP k `divMod` 4 in (Letter l, Letter r)+  {-# Inline mkBasepair #-}+  {-# Inline fromBasepair #-}+-}++ -- * Newtypes for extended secondary structures  -- ** Encode which of three edges is engaged in base pairing@@ -51,41 +134,7 @@ instance FromJSON  Edge instance ToJSON    Edge --- TODO Index instances! -{--instance (Shape sh,Show sh) => Shape (sh :. Edge) where-  rank (sh:._) = rank sh + 1-  zeroDim = zeroDim:.Edge 0-  unitDim = unitDim:.Edge 1 -- TODO does this one make sense?-  intersectDim (sh1:.n1) (sh2:.n2) = intersectDim sh1 sh2 :. min n1 n2-  addDim (sh1:.Edge n1) (sh2:.Edge n2) = addDim sh1 sh2 :. Edge (n1+n2) -- TODO will not necessarily yield a valid Edge-  size (sh1:.Edge n) = size sh1 * n-  sizeIsValid (sh1:.Edge n) = sizeIsValid (sh1:.n)-  toIndex (sh1:.Edge sh2) (sh1':.Edge sh2') = toIndex (sh1:.sh2) (sh1':.sh2')-  fromIndex (ds:.Edge d) n = fromIndex ds (n `quotInt` d) :. Edge r where-                              r | rank ds == 0 = n-                                | otherwise    = n `remInt` d-  inShapeRange (sh1:.n1) (sh2:.n2) (idx:.i) = i>=n1 && i<n2 && inShapeRange sh1 sh2 idx-  listOfShape (sh:.Edge n) = n : listOfShape sh-  shapeOfList xx = case xx of-    []   -> error "empty list in shapeOfList/Primary"-    x:xs -> shapeOfList xs :. Edge x-  deepSeq (sh:.n) x = deepSeq sh (n `seq` x)-  {-# INLINE rank #-}-  {-# INLINE zeroDim #-}-  {-# INLINE unitDim #-}-  {-# INLINE intersectDim #-}-  {-# INLINE addDim #-}-  {-# INLINE size #-}-  {-# INLINE sizeIsValid #-}-  {-# INLINE toIndex #-}-  {-# INLINE fromIndex #-}-  {-# INLINE inShapeRange #-}-  {-# INLINE listOfShape #-}-  {-# INLINE shapeOfList #-}-  {-# INLINE deepSeq #-}--}  -- | Human-readable Show instance. @@ -131,42 +180,7 @@ instance FromJSON  CTisomerism instance ToJSON    CTisomerism --- TODO Index instances -{--instance (Shape sh,Show sh) => Shape (sh :. CTisomerism) where-  rank (sh:._) = rank sh + 1-  zeroDim = zeroDim:.CT 0-  unitDim = unitDim:.CT 1 -- TODO does this one make sense?-  intersectDim (sh1:.n1) (sh2:.n2) = intersectDim sh1 sh2 :. min n1 n2-  addDim (sh1:.CT n1) (sh2:.CT n2) = addDim sh1 sh2 :. CT (n1+n2) -- TODO will not necessarily yield a valid CT-  size (sh1:.CT n) = size sh1 * n-  sizeIsValid (sh1:.CT n) = sizeIsValid (sh1:.n)-  toIndex (sh1:.CT sh2) (sh1':.CT sh2') = toIndex (sh1:.sh2) (sh1':.sh2')-  fromIndex (ds:.CT d) n = fromIndex ds (n `quotInt` d) :. CT r where-                              r | rank ds == 0 = n-                                | otherwise    = n `remInt` d-  inShapeRange (sh1:.n1) (sh2:.n2) (idx:.i) = i>=n1 && i<n2 && inShapeRange sh1 sh2 idx-  listOfShape (sh:.CT n) = n : listOfShape sh-  shapeOfList xx = case xx of-    []   -> error "empty list in shapeOfList/Primary"-    x:xs -> shapeOfList xs :. CT x-  deepSeq (sh:.n) x = deepSeq sh (n `seq` x)-  {-# INLINE rank #-}-  {-# INLINE zeroDim #-}-  {-# INLINE unitDim #-}-  {-# INLINE intersectDim #-}-  {-# INLINE addDim #-}-  {-# INLINE size #-}-  {-# INLINE sizeIsValid #-}-  {-# INLINE toIndex #-}-  {-# INLINE fromIndex #-}-  {-# INLINE inShapeRange #-}-  {-# INLINE listOfShape #-}-  {-# INLINE shapeOfList #-}-  {-# INLINE deepSeq #-}--}- -- | Human-readable Show instance.  instance Show CTisomerism where@@ -241,72 +255,4 @@ pattern TWH = (Trn,W,H) pattern TWS = (Trn,W,S) pattern TWW = (Trn,W,W)------ * tuple-like selection------ the 'lens' library provides combinators that should make this--- superfluous.---- | Selection of nucleotides and/or type classes independent of which type we--- are looking at.--class BaseSelect a b | a -> b where-  -- |  select first index or nucleotide-  baseL :: a -> b-  -- | select second index or nucleotide-  baseR :: a -> b-  -- | select both nucleotides as pair-  baseP :: a -> (b,b)-  -- | select basepair type if existing or return default cWW-  baseT :: a -> ExtPairAnnotation-  -- | update first index or nucleotide-  updL :: b -> a -> a-  -- | update second index or nucleotide-  updR :: b -> a -> a-  -- | update complete pair-  updP :: (b,b) -> a -> a-  -- | update basepair type, error if not possible due to type a-  updT :: ExtPairAnnotation -> a -> a---- | extended pairtype annotation given--instance BaseSelect ((a,a),ExtPairAnnotation) a where-  baseL ((a,_),_) = a-  baseR ((_,b),_) = b-  baseP (lr   ,_) = lr-  baseT (_,t) = t-  updL n ((_,y),t) = ((n,y),t)-  updR n ((x,_),t) = ((x,n),t)-  updP n (_,t)     = (n,t)-  updT n (xy,_) = (xy,n)-  {-# INLINE baseL #-}-  {-# INLINE baseR #-}-  {-# INLINE baseP #-}-  {-# INLINE baseT #-}-  {-# INLINE updL #-}-  {-# INLINE updR #-}-  {-# INLINE updP #-}-  {-# INLINE updT #-}---- | simple cis/wc-wc basepairs--instance BaseSelect (a,a) a where-  baseL (a,_) = a-  baseR (_,a) = a-  baseP = id-  baseT _ = CWW-  updL n (_,y) = (n,y)-  updR n (x,_) = (x,n)-  updP n _     = n-  updT n xy = if n==CWW then xy else error $ "updT on standard pairs can not update to: " ++ show n-  {-# INLINE baseL #-}-  {-# INLINE baseR #-}-  {-# INLINE baseP #-}-  {-# INLINE baseT #-}-  {-# INLINE updL #-}-  {-# INLINE updR #-}-  {-# INLINE updP #-}-  {-# INLINE updT #-} 

@@ -0,0 +1,91 @@++-- | This module gives functionality to convert between different variants+-- of secondary structure elements.++module Biobase.Secondary.Convert where++import           Biobase.Primary.Letter+import           Biobase.Primary.Nuc.RNA+import           Biobase.Secondary.Basepair+import           Biobase.Secondary.Vienna (ViennaPair(..))+import qualified Biobase.Secondary.Vienna as SV+import qualified Biobase.Secondary.Basepair as SB++++-- | @basepairConvert@ converts between different secondary structure base+-- pair representations. In general, the conversion is lossy, in particular+-- when "downsizing", say to @ViennaPair@.++class BasepairConvert a b where+  basepairConvert :: a -> b++++-- ** @(RNA,RNA) <-> Basepair@++instance BasepairConvert (Letter RNA,Letter RNA) Basepair where+  basepairConvert (l,r)+    | l >= A && l <= U && r >= A && r <= U+    = BP $ 4 * getLetter l + getLetter r+    | otherwise = NoBP+  {-# Inline basepairConvert #-}++instance BasepairConvert Basepair (Letter RNA, Letter RNA) where+  basepairConvert k+    | k == NoBP || k == NS = (N,N)+    | otherwise = let (l,r) = getBP k `divMod` 4 in (Letter l, Letter r)+  {-# Inline basepairConvert #-}++++-- ** @(RNA,RNA) <-> ViennaPair@++instance BasepairConvert (Letter RNA, Letter RNA) ViennaPair where+  basepairConvert = \case+    (C,G) -> SV.CG+    (G,C) -> SV.GC+    (G,U) -> SV.GU+    (U,G) -> SV.UG+    (A,U) -> SV.AU+    (U,A) -> SV.UA+    _     -> SV.NS+  {-# Inline basepairConvert #-}++instance BasepairConvert ViennaPair (Letter RNA, Letter RNA) where+  basepairConvert = \case+    SV.CG -> (C,G)+    SV.GC -> (G,C)+    SV.GU -> (G,U)+    SV.UG -> (U,G)+    SV.AU -> (A,U)+    SV.UA -> (U,A)+    SV.NS -> (N,N)+  {-# Inline basepairConvert #-}++++-- ** @Basepair <-> ViennaPair@++instance BasepairConvert Basepair ViennaPair where+  basepairConvert = \case+    SB.AU -> SV.AU+    SB.CG -> SV.CG+    SB.GC -> SV.GC+    SB.GU -> SV.GU+    SB.UA -> SV.UA+    SB.UG -> SV.UG+    _     -> SV.NS+  {-# Inline basepairConvert #-}++instance BasepairConvert ViennaPair Basepair where+  basepairConvert = \case+    SV.AU -> SB.AU+    SV.CG -> SB.CG+    SV.GC -> SB.GC+    SV.GU -> SB.GU+    SV.UA -> SB.UA+    SV.UG -> SB.UG+    _     -> SB.NS+  {-# Inline basepairConvert #-}+

@@ -30,6 +30,8 @@ -- | RNA secondary structure with 1-diagrams. Each nucleotide is paired with at -- most one other nucleotide. A nucleotide with index @k@ in @[0..len-1]@ is -- paired if @unD1S VU.! k >=0 0@ Unpaired status is @-1@.+--+-- TODO Provide @iso@ between @D1Secondary@ and @RNAss@.  newtype D1Secondary = D1S {unD1S :: VU.Vector Int}   deriving (Read,Show,Eq,Generic,NFData)

@@ -16,6 +16,7 @@ import           Data.FileEmbed (embedFile) import           Data.Function (on) import           Data.List+import           Data.Tuple.Select import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M import           Text.CSV@@ -58,11 +59,10 @@     | Just cs <- M.lookup (p,CWW) defaultIsostericityMap     = cs     | otherwise = []-  inClass x = map (baseP.fst) -- remove extended information-            . filter ((CWW==).baseT.fst) -- keep only cWW pairs (baseT-ype)-            . filter ((x `elem`).snd) -- select based on class+  inClass x = map (sel1 . fst)            -- remove extended information+            . filter ((CWW==). snd . fst) -- keep only cWW pairs (baseT-ype)+            . filter ((x `elem`).snd)     -- select based on class             $ M.assocs defaultIsostericityMap-   -- ** default data

@@ -0,0 +1,101 @@++-- | New parsers and structures for secondary structures. The structures here a strict.+--+-- TODO Parser should check if a @#Vienna Secondary Structure@ or @#Extended Secondary Structure@ precedes the entries.++module Biobase.Secondary.New where++import Control.Applicative+import Control.Lens+import Control.Monad.Except+import Data.Attoparsec.ByteString.Char8+import Data.ByteString.Char8 (ByteString,pack)+import Data.Functor+import Data.Tree+import Data.Vector (Vector, fromList)+import GHC.Generics (Generic)++++-- | A completely closed sub-structure. An unpaired region @.@ is closed. A+-- paired region @(r)@ is closed, where @r@ contains arbitrarily many unpaired+-- and paired elements.+--+-- TODO Should be extended with @Extended@, but this requires knowing which of+-- the ends overlap with paired: left, right, or both.++data SubStructure (t ∷ k) a+  = Unpaired { _label ∷ !a }+  | Paired   { _label ∷ !a, _subStructures ∷ !(Vector (SubStructure t a)) }+  deriving (Show, Read, Functor, Traversable, Foldable, Generic, Eq, Ord)+makeLenses ''SubStructure+makePrisms ''SubStructure++-- | A full structure is composed of a number of sub-structures. The empty+-- structure is a full structure.++newtype FullStructure (t ∷ k) a+  = FullStructure { _fullStructure ∷ Vector (SubStructure t a) }+  deriving (Show, Read, Functor, Traversable, Foldable, Generic, Eq, Ord)+makeLenses ''FullStructure++++-- ** Parses a ViennaRNA secondary structure string.++pUnpaired ∷ Parser (SubStructure () ())+pUnpaired = Unpaired () <$ char '.'+{-# Inlinable pUnpaired #-}++pPaired ∷ Parser (SubStructure () ())+pPaired = Paired () <$ char '(' <*> (fromList <$> many pSubStructure) <* char ')'+{-# Inlinable pPaired #-}++pSubStructure ∷ Parser (SubStructure () ())+pSubStructure = pUnpaired <|> pPaired+{-# Inlinable pSubStructure #-}++pFullStructure ∷ Parser (FullStructure () ())+pFullStructure = FullStructure <$> fromList <$> many pSubStructure <* endOfInput+{-# Inlinable pFullStructure #-}++newtype StructureParseError = StructureParseError String+  deriving (Show)++parseVienna ∷ MonadError StructureParseError m ⇒ ByteString → m (FullStructure () ())+parseVienna = either (throwError . StructureParseError) return . parseOnly pFullStructure+{-# Inlinable parseVienna #-}++++-- ** Transform into a @Tree@.++-- | Transform a 'FullStructure' into a 'Tree'.+--+-- Given a full structure generated like this:+-- @+-- s = either (error . show) id $ parseVienna $ pack ".()(())."+-- @+--+-- a tree of just the base paired can be created with+-- @+-- toTree (preview (_Paired._1)) () s+-- @++toTree+  ∷ (SubStructure t a → Maybe b)+  -- ^ how to handle substructure elements? @Nothing@ means discard this+  -- substructure and all children.+  → b+  -- ^ The root label+  → FullStructure (t ∷ k) a+  -- ^ The @FullStructure@ to transform into a @Tree@.+  → Tree b+toTree f r (FullStructure ts) = Node r $ fmap go ts ^.. traverse . _Just+  where+    go u@Unpaired{} = (`Node` []) <$> f u+    go p@Paired{}   = case f p of+      Nothing  → Nothing+      Just lbl → Just $ Node lbl $ (fmap go $ p^.subStructures) ^.. traverse . _Just+{-# Inlinable toTree #-}+

@@ -75,52 +75,6 @@   -{--instance (Shape sh,Show sh) => Shape (sh :. ViennaPair) where-  rank (sh:._) = rank sh + 1-  zeroDim = zeroDim:.ViennaPair 0-  unitDim = unitDim:.ViennaPair 1 -- TODO does this one make sense?-  intersectDim (sh1:.n1) (sh2:.n2) = intersectDim sh1 sh2 :. min n1 n2-  addDim (sh1:.ViennaPair n1) (sh2:.ViennaPair n2) = addDim sh1 sh2 :. ViennaPair (n1+n2) -- TODO will not necessarily yield a valid ViennaPair-  size (sh1:.ViennaPair n) = size sh1 * n-  sizeIsValid (sh1:.ViennaPair n) = sizeIsValid (sh1:.n)-  toIndex (sh1:.ViennaPair sh2) (sh1':.ViennaPair sh2') = toIndex (sh1:.sh2) (sh1':.sh2')-  fromIndex (ds:.ViennaPair d) n = fromIndex ds (n `quotInt` d) :. ViennaPair r where-                              r | rank ds == 0 = n-                                | otherwise    = n `remInt` d-  inShapeRange (sh1:.n1) (sh2:.n2) (idx:.i) = i>=n1 && i<n2 && inShapeRange sh1 sh2 idx-  listOfShape (sh:.ViennaPair n) = n : listOfShape sh-  shapeOfList xx = case xx of-    []   -> error "empty list in shapeOfList/Primary"-    x:xs -> shapeOfList xs :. ViennaPair x-  deepSeq (sh:.n) x = deepSeq sh (n `seq` x)-  {-# INLINE rank #-}-  {-# INLINE zeroDim #-}-  {-# INLINE unitDim #-}-  {-# INLINE intersectDim #-}-  {-# INLINE addDim #-}-  {-# INLINE size #-}-  {-# INLINE sizeIsValid #-}-  {-# INLINE toIndex #-}-  {-# INLINE fromIndex #-}-  {-# INLINE inShapeRange #-}-  {-# INLINE listOfShape #-}-  {-# INLINE shapeOfList #-}-  {-# INLINE deepSeq #-}--instance (Eq sh, Shape sh, Show sh, ExtShape sh) => ExtShape (sh :. ViennaPair) where-  subDim (sh1:.ViennaPair n1) (sh2:.ViennaPair n2) = subDim sh1 sh2 :. (ViennaPair $ n1-n2)-  rangeList (sh1:.ViennaPair n1) (sh2:.ViennaPair n2) = [sh:.ViennaPair n | sh <- rangeList sh1 sh2, n <- [n1 .. (n1+n2)]]-  rangeStream (fs:.ViennaPair f) (ts:.ViennaPair t) = VM.flatten mk step Unknown $ rangeStream fs ts where-    mk sh = return (sh :. f)-    step (sh :. k)-      | k>t       = return $ VM.Done-      | otherwise = return $ VM.Yield (sh :. ViennaPair k) (sh :. k +1)-    {-# INLINE [1] mk #-}-    {-# INLINE [1] step #-}-  {-# INLINE rangeStream #-}--}- pattern    NP = ViennaPair 0 :: ViennaPair pattern    CG = ViennaPair 1 :: ViennaPair pattern    GC = ViennaPair 2 :: ViennaPair@@ -128,9 +82,11 @@ pattern    UG = ViennaPair 4 :: ViennaPair pattern    AU = ViennaPair 5 :: ViennaPair pattern    UA = ViennaPair 6 :: ViennaPair+-- | Non-standard base pair pattern    NS = ViennaPair 7 :: ViennaPair pattern Undef = ViennaPair 8 :: ViennaPair +{- class MkViennaPair a where   mkViennaPair :: a -> ViennaPair   fromViennaPair :: ViennaPair -> a@@ -154,6 +110,7 @@     UA -> (U,A)     _  -> error "non-standard pairs can't be backcasted"   {-# INLINE fromViennaPair #-}+-}  isViennaPair :: Letter RNA -> Letter RNA -> Bool isViennaPair l r =  l==C && r==G

@@ -1,12 +1,12 @@ name:           BiobaseXNA-version:        0.9.3.1+version:        0.10.0.0 author:         Christian Hoener zu Siederdissen maintainer:     choener@bioinf.uni-leipzig.de homepage:       https://github.com/choener/BiobaseXNA bug-reports:    https://github.com/choener/BiobaseXNA/issues copyright:      Christian Hoener zu Siederdissen, 2011 - 2017 category:       Bioinformatics-synopsis:       Efficient RNA/DNA representations+synopsis:       Efficient RNA/DNA/Protein Primary/Secondary Structure license:        GPL-3 license-file:   LICENSE build-type:     Simple@@ -48,7 +48,8 @@  library   build-depends: base                     >= 4.7      &&  < 5.0-               , aeson                    >= 0.8+               , aeson                    >= 1.0+               , attoparsec               >= 0.13                , binary                   >= 0.7                , bytes                    >= 0.15                , bytestring               >= 0.10@@ -60,6 +61,7 @@                , file-embed               >= 0.0.8                , hashable                 >= 1.2                , lens                     >= 4.0+               , mtl                      >= 2.0                , primitive                >= 0.5                , QuickCheck               >= 2.7                , split                    >= 0.2@@ -70,6 +72,8 @@                , vector-th-unbox          >= 0.2                --                , bimaps                   == 0.1.0.*+               , BiobaseTypes             == 0.1.3.*+               , ForestStructures         == 0.0.0.*                , PrimitiveArray           == 0.8.0.*   exposed-modules:     Biobase.Primary@@ -87,8 +91,10 @@     Biobase.Primary.Trans     Biobase.Primary.Unknown     Biobase.Secondary+    Biobase.Secondary.New     Biobase.Secondary.Basepair     Biobase.Secondary.Constraint+    Biobase.Secondary.Convert     Biobase.Secondary.Diagrams     Biobase.Secondary.Isostericity     Biobase.Secondary.Pseudoknots@@ -101,13 +107,19 @@                     , FlexibleInstances                     , GeneralizedNewtypeDeriving                     , LambdaCase+                    , PolyKinds+                    , DeriveFunctor+                    , DeriveTraversable+                    , DeriveGeneric                     , MultiParamTypeClasses                     , PatternSynonyms                     , ScopedTypeVariables+                    , StandaloneDeriving                     , TemplateHaskell                     , TypeFamilies                     , TypeOperators                     , UndecidableInstances+                    , UnicodeSyntax                     , ViewPatterns   default-language:     Haskell2010

@@ -1,3 +1,8 @@+0.10.0.0+--------++- redesigned Biobase.Secondary.Basepair+ 0.9.3.1 -------