FormalGrammars 0.3.1.2 → 0.4.0.0

raw patch · 18 files changed

+227/−1122 lines, 18 filesdep −HaTeXdep −QuickCheckdep −cmdargsdep ~ADPfusiondep ~PrimitiveArraydep ~ansi-wl-pprintPVP ok

version bump matches the API change (PVP)

Dependencies removed: HaTeX, QuickCheck, cmdargs, smallcheck, tasty, tasty-quickcheck, tasty-smallcheck, tasty-th

Dependency ranges changed: ADPfusion, PrimitiveArray, ansi-wl-pprint, base, parsers, trifecta, vector

API changes (from Hackage documentation)

Files

• FormalGrammars.cabal +94/−207
• FormalLanguage/CFG/Grammar/Types.hs +39/−13
• FormalLanguage/CFG/Grammar/Util.hs +1/−1
• FormalLanguage/CFG/Outside.hs +2/−2
• FormalLanguage/CFG/Parser.hs +13/−355
• FormalLanguage/CFG/PrettyPrint.hs +2/−2
• FormalLanguage/CFG/PrettyPrint/ANSI.hs +1/−1
• FormalLanguage/CFG/PrettyPrint/LaTeX.hs +0/−69
• FormalLanguage/CFG/QQ.hs +16/−9
• FormalLanguage/CFG/TH.hs +46/−23
• FormalLanguage/CFG/TH/Internal.hs +4/−1
• README.md +1/−1
• changelog.md +7/−0
• src/GrammarPP.hs +0/−67
• src/NeedlemanWunsch.hs +0/−104
• src/Nussinov.hs +0/−122
• src/TriNeedle.hs +0/−138
• tests/properties.hs +1/−7

@@ -1,49 +1,44 @@+cabal-version:  2.2 name:           FormalGrammars-version:        0.3.1.2-author:         Christian Hoener zu Siederdissen, 2013-2017-copyright:      Christian Hoener zu Siederdissen, 2013-2017+version:        0.4.0.0+author:         Christian Hoener zu Siederdissen, 2013-2019+copyright:      Christian Hoener zu Siederdissen, 2013-2019 homepage:       https://github.com/choener/FormalGrammars bug-reports:    https://github.com/choener/FormalGrammars/issues maintainer:     choener@bioinf.uni-leipzig.de category:       Formal Languages, Bioinformatics-license:        GPL-3+license:        GPL-3.0-only license-file:   LICENSE build-type:     Simple stability:      experimental-cabal-version:  >= 1.10.0-tested-with:    GHC == 7.10.3, GHC == 8.0.2+tested-with:    GHC == 8.6.4 synopsis:       (Context-free) grammars in formal language theory description:                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>                 .-                Context-free grammars in formal language theory are sets of-                production rules, non-terminal and terminal symbols. This-                library provides basic data types and functions to manipulate-                such grammars.+                Context-free grammars in formal language theory are sets of production rules,+                non-terminal and terminal symbols. This library provides basic data types and+                functions to manipulate such grammars.                 .-                Grammars can be defined in a small domain-specific language-                that is very close to typical CFG notation. The DSL parser can-                easily be extended. Grammar products, for example, are-                implemented as a single additional sub-parser.+                Grammars can be defined in a small domain-specific language that is very close to+                typical CFG notation. The DSL parser can easily be extended. Grammar products, for+                example, are implemented as a single additional sub-parser.                 .-                This library also provides the machinery that transforms an-                Inside grammar into the corresponding Outside grammar.+                This library also provides the machinery that transforms an Inside grammar into the+                corresponding Outside grammar.                 .-                Starting with version 0.2.1 it is possible to write multiple-                context-free grammars within this framework.+                Starting with version 0.2.1 it is possible to write multiple context-free grammars+                within this framework.                 .-                In addition, TemplateHaskell and QuasiQuoting functionality-                allow embedding thusly defined grammars in Haskell programs.-                ADPfusion then turns such a grammar into an efficient dynamic-                program. It is also possible to generate Haskell modules that+                In addition, TemplateHaskell and QuasiQuoting functionality allow embedding thusly+                defined grammars in Haskell programs. ADPfusion then turns such a grammar into an+                efficient dynamic program. It is also possible to generate Haskell modules that                 contain the resulting grammar, signature and algebra product.                 .-                Alternatives are ansi- or LaTeX-based pretty-printing for users-                that want to implement their CFG in another language than-                Haskell.+                Alternatives are ansi- or LaTeX-based pretty-printing for users that want to+                implement their CFG in another language than Haskell.                 .-                Formal background can be found in a number of papers which are-                given in the README.+                Formal background can be found in a number of papers which are given in the README.                 .  @@ -60,54 +55,46 @@   default:      False   manual:       True -flag debug+flag debugdump   description:  dump intermediate Core files   default:      False   manual:       True +flag llvm+  description:  use llvm+  default:      False+  manual:       True  -library++common deps   build-depends: base                  >= 4.7     && < 5.0                , ansi-wl-pprint        >= 0.6.7                , bytestring            >= 0.10                , containers                , data-default          >= 0.5-               , HaTeX                 >= 3.16+--               , HaTeX                 >= 3.16                , lens                  >= 4.0                , mtl                   >= 2.0-               , parsers               >= 0.12+               , parsers               >= 0.12.5                , semigroups            >= 0.16                , template-haskell                , text                  >= 1.0                , transformers          >= 0.3-               , trifecta              >= 1.6+-- trifecta switches from ansi-wl-pprint to pretty in v.2.1+               , trifecta              >= 1.7.1.1   && < 2.1                , unordered-containers  >= 0.2                , vector                >= 0.10                ---               , ADPfusion             == 0.5.2.*-               , PrimitiveArray        == 0.8.0.*-  exposed-modules:-    FormalLanguage-    FormalLanguage.CFG-    FormalLanguage.CFG.Grammar-    FormalLanguage.CFG.Grammar.Types-    FormalLanguage.CFG.Grammar.Util-    FormalLanguage.CFG.Outside-    FormalLanguage.CFG.Parser-    FormalLanguage.CFG.PrettyPrint-    FormalLanguage.CFG.PrettyPrint.ANSI-    FormalLanguage.CFG.PrettyPrint.Haskell-    FormalLanguage.CFG.PrettyPrint.LaTeX-    FormalLanguage.CFG.QQ-    FormalLanguage.CFG.TH-    FormalLanguage.CFG.TH.Internal+               , ADPfusion             == 0.6.0.*+               , PrimitiveArray        == 0.10.0.*   default-language:     Haskell2010   default-extensions: BangPatterns                     , CPP-                    , DeriveDataTypeable                     , DataKinds+                    , DeriveDataTypeable+                    , DerivingStrategies                     , FlexibleContexts                     , FlexibleInstances                     , GeneralizedNewtypeDeriving@@ -115,7 +102,9 @@                     , MultiParamTypeClasses                     , NamedFieldPuns                     , NoMonomorphismRestriction+                    , PartialTypeSignatures                     , PatternGuards+                    , PolyKinds                     , QuasiQuotes                     , RankNTypes                     , RecordWildCards@@ -123,168 +112,76 @@                     , StandaloneDeriving                     , TemplateHaskell                     , TupleSections+                    , TypeApplications                     , TypeFamilies                     , TypeOperators+                    , UnicodeSyntax                     , ViewPatterns   ghc-options:     -O2 -funbox-strict-fields   --- A Simple pretty-printer for formal grammars.--executable GrammarPP-  build-depends: base-               , ansi-wl-pprint-               , cmdargs          >= 0.10-               , trifecta-               ---               , FormalGrammars-  hs-source-dirs:-    src-  default-language:-    Haskell2010-  default-extensions: DeriveDataTypeable-                    , RecordWildCards-  main-is:-    GrammarPP.hs----executable NussinovFG-  if flag(examples)-    buildable:-      True-    build-depends: base-                 , template-haskell-                 , vector-                 ---                 , ADPfusion-                 , FormalGrammars-                 , PrimitiveArray-  else-    buildable:-      False-  hs-source-dirs:-    src-  main-is:-    Nussinov.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , QuasiQuotes-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-  ghc-options:-    -O2-    -fcpr-off-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -ddump-stg-      -dsuppress-all----executable NeedlemanWunschFG-  if flag(examples)-    buildable:-      True-    build-depends: base-                 , containers-                 , template-haskell-                 , vector-                 ---                 , ADPfusion-                 , FormalGrammars-                 , PrimitiveArray-  else-    buildable:-      False-  hs-source-dirs:-    src-  main-is:-    NeedlemanWunsch.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , QuasiQuotes-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-  ghc-options:-    -O2-    -fcpr-off-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-    -rtsopts-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -ddump-stg-      -dsuppress-all+library+  import:+    deps+  exposed-modules:+    FormalLanguage+    FormalLanguage.CFG+    FormalLanguage.CFG.Grammar+    FormalLanguage.CFG.Grammar.Types+    FormalLanguage.CFG.Grammar.Util+    FormalLanguage.CFG.Outside+    FormalLanguage.CFG.Parser+    FormalLanguage.CFG.PrettyPrint+    FormalLanguage.CFG.PrettyPrint.ANSI+    FormalLanguage.CFG.PrettyPrint.Haskell+--    FormalLanguage.CFG.PrettyPrint.LaTeX+    FormalLanguage.CFG.QQ+    FormalLanguage.CFG.TH+    FormalLanguage.CFG.TH.Internal   -executable TriNeedleFG-  if flag(examples)-    buildable:-      True-    build-depends: base-                 , containers-                 , template-haskell-                 , vector-                 ---                 , ADPfusion-                 , FormalGrammars-                 , PrimitiveArray-  else-    buildable:-      False-  hs-source-dirs:-    src-  main-is:-    TriNeedle.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , QuasiQuotes-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-  ghc-options:-    -O2-    -fcpr-off-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-    -rtsopts-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -ddump-stg-      -dsuppress-all+--executable NeedlemanWunschFG+--  import:+--    deps+--  if flag(examples)+--    buildable:+--      True+--    build-depends: base+--                 --+--                 , FormalGrammars+--  else+--    buildable:+--      False+--  hs-source-dirs:+--    src+--  main-is:+--    NeedlemanWunsch.hs+--  ghc-options:+--    -funfolding-use-threshold1000+--    -funfolding-keeness-factor1000+--    -flate-dmd-anal+--    -fspec-constr-count=100+--  if flag(debugdump)+--    ghc-options:+--      -ddump-cmm+--      -ddump-simpl+--      -ddump-stg+--      -ddump-to-file+--      -dshow-passes+--      -dsuppress-all+--  if flag(llvm)+--    ghc-options:+--      -fllvm+--      -optlo-O3    test-suite properties+  import:+    deps   type:     exitcode-stdio-1.0   main-is:@@ -293,17 +190,7 @@     -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs:     tests-  default-language:-    Haskell2010-  default-extensions: CPP-                    , TemplateHaskell   build-depends: base-               , QuickCheck-               , smallcheck-               , tasty              >= 0.11-               , tasty-quickcheck   >= 0.8-               , tasty-smallcheck   >= 0.8-               , tasty-th           >= 0.1                --                , FormalGrammars 

@@ -1,9 +1,13 @@  -- | The data types that define a CFG. -module FormalLanguage.CFG.Grammar.Types where+module FormalLanguage.CFG.Grammar.Types+  ( module FormalLanguage.CFG.Grammar.Types+  , LocalGlobal(..)+  ) where  import           Control.Lens hiding (Index,index)+import           Data.Data (Data,Typeable) import           Data.Default import           Data.Map.Strict (Map) import           Data.Semigroup@@ -11,12 +15,14 @@ import           Data.String import qualified Data.Map.Strict as M import qualified Data.Set as S-import           Data.Data (Data,Typeable) +import           ADP.Fusion.Core.Term.Epsilon (LocalGlobal(..))  + newtype IndexName = IndexName { _getIndexName :: String }-  deriving (Show,Eq,Ord,IsString,Data,Typeable)+  deriving stock (Show,Eq,Ord,Data,Typeable)+  deriving newtype (IsString)  makeLenses ''IndexName @@ -56,8 +62,9 @@  -- | Newtype wrapper for symbol names. -newtype SymbolName = SymbolName { _getSteName :: String }-  deriving (Show,Eq,Ord,IsString,Data,Typeable)+newtype SymbolName = SymbolName { _getSteName ∷ String }+  deriving stock (Show,Eq,Ord,Data,Typeable)+  deriving newtype (IsString)  makeLenses ''SymbolName @@ -67,7 +74,8 @@ -- still have the same @SymbolName@ but different type and input!  newtype Tape = Tape { _getTape :: Int }-  deriving (Show,Eq,Ord,Enum,Num,Data,Typeable)+  deriving stock (Show,Eq,Ord,Data,Typeable)+  deriving newtype (Enum,Num)  makeLenses ''Tape @@ -100,7 +108,7 @@   -- | Finally, a real epsilon. Again, these are somewhat regular terminal   -- symbols, but it is important to be able to recognize these, when   -- trying to create outside variants of our algorithms.-  | Epsilon+  | Epsilon LocalGlobal   deriving (Show,Eq,Ord,Data,Typeable)  makeLenses ''SynTermEps@@ -112,7 +120,8 @@ -- over dimensional concatenation.  newtype Symbol = Symbol { _getSymbolList :: [SynTermEps] }-  deriving (Show,Eq,Ord,Monoid,Semigroup,Data,Typeable)+  deriving stock (Show,Eq,Data,Typeable)+  deriving newtype (Ord,Semigroup,Monoid)  makeLenses ''Symbol @@ -121,7 +130,8 @@ -- | The name of an attribute function  newtype AttributeFunction = Attr { _getAttr :: String }-  deriving (Show,Eq,Ord,IsString,Data,Typeable)+  deriving stock (Show,Eq,Ord,Data,Typeable)+  deriving newtype (IsString)  makeLenses ''AttributeFunction @@ -140,19 +150,30 @@   +-- | Indicate wether we are a handwritten @Inside@ grammar, or an @Outside@+-- grammar derived @fromInside@.+ data DerivedGrammar   = Inside-  | Outside String-  deriving (Show,Eq,Data,Typeable)+  -- ^ Indicates being Inside+  | Outside { _fromInside ∷ Grammar }+  -- ^ Indicates being Outside, with original Inside+  deriving (Show,Data,Typeable) +instance Eq DerivedGrammar where+  Inside == Inside = True+  Inside == Outside _ = False+  Outside _ == Inside = False+  Outside x == Outside y = _grammarName x == _grammarName y+ isOutside (Outside _) = True isOutside _           = False  instance Default DerivedGrammar where   def = Inside -makeLenses ''DerivedGrammar + -- | Complete descrition of a grammar. In principle it would be enough to hold -- @_rules@ and the @_start@ symbol name. We also store dimensionless names for -- syntactiv variables, and terminals. This makes certain checks easier or@@ -164,6 +185,10 @@ -- can easily rename terminals. -- -- TODO better way to handle indexed symbols?+--+-- TODO include "String" name to handle sharing signatures (and thereby+-- algebras!). This makes sense only when sharing the more complex signature,+-- until I start allowing signature merges.  data Grammar = Grammar   { _synvars      :: Map SymbolName SynTermEps@@ -174,7 +199,7 @@   , _termvars     :: Map SymbolName SynTermEps     -- ^ regular terminal symbols   , _outside      :: DerivedGrammar-    -- ^ Is this an automatically derived outside grammar+    -- ^ Is this an automatically derived outside grammar, if so provide @fromInside@.   , _rules        :: Set Rule     -- ^ set of production rules   , _start        :: Symbol@@ -206,5 +231,6 @@     , _write        = False     } +makeLenses ''DerivedGrammar makeLenses ''Grammar 

@@ -54,7 +54,7 @@ -- | Epsilon-only symbols.  isEpsilon :: Symbol -> Bool-isEpsilon = allOf folded (\case Epsilon -> True; _ -> False) . _getSymbolList+isEpsilon = allOf folded (\case Epsilon _ -> True; _ -> False) . _getSymbolList  -- | Dimension of the grammar. Rather costly, because we check for dimensional -- consistency.

@@ -31,7 +31,7 @@   -- (linear grammars are context-free as well).   -- not $ isContextFree g = Nothing   | otherwise = Just $ Grammar {..}-  where _outside     = Outside (g^.grammarName)+  where _outside     = Outside g         _rules       = S.fromList $ epsrule : (concatMap genOutsideRules $ g^..rules.folded)         _grammarName = "" -- will be set in the parser         _params      = g^.params@@ -85,7 +85,7 @@ -- |   genEpsilonRule :: [AttributeFunction] -> Symbol -> Rule-genEpsilonRule epsfun s = Rule (outsideSymb s) epsfun [(Symbol $ replicate (length $ s^.getSymbolList) Epsilon)]+genEpsilonRule epsfun s = Rule (outsideSymb s) epsfun [(Symbol $ replicate (length $ s^.getSymbolList) $ Epsilon Global)]  -- |  

@@ -16,8 +16,10 @@ import           Control.Lens hiding (Index, outside, indices, index) import           Control.Monad import           Control.Monad.State.Class (MonadState (..))+import           Control.Monad.Trans.Class import           Control.Monad.Trans.State.Strict hiding (get) import           Data.ByteString.Char8 (pack)+import           Data.Data.Lens import           Data.Default import           Data.List (nub,genericIndex,mapAccumL) import           Data.Map.Strict (Map)@@ -36,12 +38,9 @@ import           Text.Trifecta import           Text.Trifecta.Delta (Delta (Directed)) -import Data.Data.Lens- import           FormalLanguage.CFG.Grammar import           FormalLanguage.CFG.Outside import           FormalLanguage.CFG.PrettyPrint.ANSI--- testPrint = test >>= \z -> case z of {Just g -> mapM_ (printDoc . genGrammarDoc) g}   @@ -66,12 +65,13 @@                    }  -test = parseFromFile ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True}) "tests/pseudo.gra"-+test ∷ IO ()+test = do+  p ← parseFromFile (evalStateT (parseEverything empty) def{_verbose = True}) "./deps/FormalGrammars/tests/pseudo.gra"+  print p  --- parse = parseString ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True})-parse = parseString ((evalStateT . runGrammarParser) (parseEverything empty) def) (Directed (pack "via QQ") (fromIntegral 0) 0 0 0)+parse = parseString (evalStateT (parseEverything empty) def) (Directed (pack "via QQ") (fromIntegral 0) 0 0 0)  -- | Parse everything in the grammar source. The additional argument, normally -- @empty :: Alternative f a@, allows for providing additional parsing@@ -182,7 +182,7 @@  fgIdents = set styleReserved rs emptyIdents   where rs = H.fromList [ "Grammar:", "Outside:", "Source:", "NormStartEps:", "Emit:", "Help", "Verbose"-                        , "N:", "Y:", "T:", "S:", "->", "=", "<<<", "-", "e", "ε"+                        , "N:", "Y:", "T:", "S:", "->", "=", "<<<", "-", "e", "ε", "l", "λ"                         ]  -- |@@ -296,16 +296,12 @@                    let rminus = (\k -> [Index s k IMinus [] 1]) <$ reserve fgIdents "-" <*> natural                    let rplus  = (\k -> [Index s k IPlus  [] 1]) <$> (option 0 $ reserve fgIdents "+" *> natural)    -- the option here is for @+0@                    try req <|> try rminus <|> rplus-{--parseIndex e = braces $ commaSep ix where-  ix = (\v -> Index v [] 0) <$> some alphaNum--}  -- |  knownTermVar :: EvalReq -> Stately m Symbol knownTermVar e = Symbol <$> do-  ((:[]) <$> (eps <|> tv)) <|> (brackets $ commaSep (del <|> eps <|> tv))+  ((:[]) <$> (eps <|> tv)) <|> (brackets $ commaSep (del <|> eps <|> loc <|> tv))   where tv = flip (<?>) "known terminal variable" . try $ do                i <- ident fgIdents                t <- use (current . termvars . at i)@@ -315,13 +311,9 @@                -- (and probably for split cases, but these are even more                -- weird)                return $ if isJust t then Term i [] else SynVar i [] 1 0-               {--               if isJust t-                then return $ Term i []-                else return $ Epsilon-                -}         del = Deletion <$ reserve fgIdents "-"-        eps = Epsilon  <$ (reserve fgIdents "e" <|> reserve fgIdents "ε")+        eps = Epsilon Global  <$ (reserve fgIdents "e" <|> reserve fgIdents "ε")+        loc = Epsilon Local   <$ (reserve fgIdents "l" <|> reserve fgIdents "λ")  -- | Parses an already known symbol, either syntactic or terminal. --@@ -393,344 +385,10 @@  -- | -type Parse m a = (TokenParsing m, MonadState GrammarEnv (Unlined m), MonadState GrammarEnv m, MonadPlus m) => m a+type Parse m a = (TokenParsing m, MonadState GrammarEnv m, MonadPlus m) => m a+type Parse' a = StateT GrammarEnv Parser a  -- |  type Stately m a = (TokenParsing m, MonadState GrammarEnv m, MonadPlus m) => m a---- |--newtype GrammarParser m a = GrammarParser { runGrammarParser :: StateT GrammarEnv m a }-  deriving-  ( Alternative-  , Applicative-  , Functor-  , MonadPlus-  , Monad-  , CharParsing-  , Parsing-  , MonadState GrammarEnv-  )--instance (MonadPlus m, CharParsing m) => TokenParsing (GrammarParser m) where-  someSpace = buildSomeSpaceParser (() <$ space) haskellCommentStyle----deriving instance MonadState GrammarEnv (Unlined (GrammarParser Parser))------{--data Enumerated-  = Sing-  | ZeroBased Integer---  | Enum      [String]-  deriving (Show)---- | The --data GrammarState = GrammarState-  { _nsys         :: M.Map String Enumerated-  , _tsys         :: S.Set String-  , _esys         :: S.Set String-  , _grammarNames :: S.Set String-  }-  deriving (Show)--instance Default GrammarState where-  def = GrammarState-          { _nsys = def-          , _tsys = def-          , _esys = def-          , _grammarNames = def-          }--makeLenses ''GrammarState---- | Parse a single grammar.--grammar :: Parse Grammar-grammar = do-  reserveGI "Grammar:"-  _name :: String <- identGI-  _nsyms <- S.fromList . concat <$> many nts-  let _nIsms = S.empty-  _tsyms <- S.fromList . concat <$> many ts-  _epsis <- S.fromList <$> many epsP-  _start <- try (Just <$> startSymbol) <|> pure Nothing-  _rules <- (S.fromList . concat) <$> some rule-  reserveGI "//"-  grammarNames <>= S.singleton _name-  return Grammar { .. }---- | Start symbol. Only a single symbol may be given------ TODO for indexed symbols make sure we actually have one index to start with.--startSymbol :: Parse Symb-startSymbol = do-  reserveGI "S:"-  name :: String <- identGI-  -- TODO go and allow indexed NTs as start symbols, with one index given-  -- return $ nsym1 name Singular-  return $ Symb Inside [N name Singular]---- | The non-terminal declaration "NT: ..." returns a list of non-terms as--- indexed non-terminals are expanded.--nts :: Parse [Symb]-nts = do-  reserveGI "N:"-  name   <- identGI-  enumed <- option Sing $ braces enumeration-  let zs = expandNT name enumed-  nsys <>= M.singleton name enumed-  return zs---- | expand set of non-terminals based on type of enumerations--expandNT :: String -> Enumerated -> [Symb]-expandNT name = go where-  go Sing          = [Symb Inside [N name Singular]]-  go (ZeroBased k) = [Symb Inside [N name (IntBased   z k)] | z <- [0..(k-1)]]-  --go (Enum es)     = [Symb [N name (Enumerated z es        )] | z <- es        ]---- | Figure out if we are dealing with indexed (enumerable) non-terminals--enumeration =   ZeroBased <$> natural---            <|> Enum      <$> sepBy1 identGI (string ",")---- | Parse declared terminal symbols.--ts :: Parse [Symb]-ts = do-  reserveGI "T:"-  n <- identGI-  let z = Symb Inside [T n]-  tsys <>= S.singleton n-  return [z]---- | Parse epsilon symbols--epsP :: Parse TN-epsP = do-  reserveGI "E:"-  e <- identGI-  esys <>= S.singleton e-  return E---- | Parse a single rule. Some rules come attached with an index. In that case,--- each rule is inflated according to its modulus (or more general the set of--- indices indicated.------ TODO add @fun@ to each PR--rule :: P m => m [Rule] -- Parse [Rule]-rule = do-  lhs <- runUnlined $ parsePreNN-  reserveGI "->"-  fun :: String <- identGI-  reserveGI "<<<"-  -- rhs <- runUnlined $ some (try (lift $ parsePreNN) <|> (lift $ parsePreTT))-  rhs <- runUnlined $ some (try parsePreNN <|> try parsePreTT <|> parsePreEE)-  whiteSpace-  s <- get-  return $ generateRules s lhs fun rhs---- | Actually create a rule given both lhs and rhs. This means we need to--- expand rules according to what we allow.------ TODO need to handle epsilons correctly--generateRules :: GrammarState -> PreSymb -> String -> [PreSymb] -> [Rule]-generateRules gs lhs fun rhs = map buildRules js where-  -- gives (index,NT) list; from (NT,(index,integer)) list-  is = nub . map swap . over (mapped._2) indexName $ (lhs : rhs) ^.. folded.folded._OnlyIndexedPreN-  js = sequence $ map (expandIndex $ gs^.nsys) is-  expandIndex ns (i,n) =-    let expand Sing          = error "expanded index on singular"-        expand (ZeroBased z) = [0 .. (z-1)]-    in  map (i,) . expand $ ns M.! n-  buildTNE _  (PreE s) = E-  buildTNE _  (PreT s) = T s-  buildTNE _  (PreN s NotIndexed) = N s Singular-  buildTNE zs (PreN s (FixedInPreN   k)) =-    let ZeroBased m = (gs^.nsys) M.! s-    in  N s (IntBased k m)-  buildTNE zs (PreN s (IndexedPreN t k)) =-    let Just z = lookup t zs-        ZeroBased m = (gs^.nsys) M.! s-        l :: Integer = (z+k) `mod` m-    in  N s (IntBased l m)-  buildRules j = Rule (Symb Inside $ map (buildTNE j) lhs) [fun] (map (Symb Inside . map (buildTNE j)) rhs)--data IndexedPreN-  = NotIndexed-  | FixedInPreN Integer-  | IndexedPreN String Integer-  deriving (Show,Eq,Ord)--indexName (IndexedPreN s i) = s--_IndexedPreN :: Prism' IndexedPreN (String,Integer)-_IndexedPreN = prism (uncurry IndexedPreN) $ \case (IndexedPreN s i) -> Right (s,i)-                                                   other             -> Left  other--data PreTNE-  = PreN String IndexedPreN-  | PreT String-  | PreE String-  deriving (Show,Eq,Ord)--_PreN :: Prism' PreTNE (String,IndexedPreN)-_PreN = prism (uncurry PreN) $ \case (PreN s i) -> Right (s,i)-                                     other      -> Left  other--_OnlyIndexedPreN :: Prism' PreTNE (String,IndexedPreN)-_OnlyIndexedPreN = prism (uncurry PreN) $ \case (PreN s (IndexedPreN t i)) -> Right (s, IndexedPreN t i)-                                                other                      -> Left  other--_PreT :: Prism' PreTNE String-_PreT = prism PreT $ \case (PreT s) -> Right s-                           other    -> Left  other--_PreE :: Prism' PreTNE String-_PreE = prism PreE $ \case (PreE s) -> Right s-                           other    -> Left  other--type PreSymb = [PreTNE]----parsePreN :: P m => m PreTNE-parsePreN = lift (use nsys) >>= \ks -> (PreN <$> (choice . map string . M.keys $ ks) <*> parseIndexedPreN)----parsePreT :: P m => m PreTNE-parsePreT = PreT <$> (lift (use tsys) >>= choice . map string . S.elems)----parsePreE :: P m => m PreTNE-parsePreE = PreE <$> (lift (use esys) >>= choice . map string . S.elems)----parseIndexedPreN :: P m => m IndexedPreN-parseIndexedPreN = option NotIndexed (   (try . braces $ IndexedPreN <$> identGI <*> option 0 integer)-                                     <|> (braces $ FixedInPreN <$> integer)-                                     )---- parsePreNN :: P m => m [PreTNE]-parsePreNN = do-  ns <- (:[]) <$> parsePreN <* whiteSpace <|> listP (try parsePreN <|> parsePreE)-  guard (notNullOf (folded._PreN) ns) <?> "no non-terminal encountered"-  return ns----parsePreTT :: P m => m [PreTNE]-parsePreTT = do-  ts <- (:[]) <$> parsePreT <* whiteSpace <|> listP (try parsePreT <|> parsePreE)-  guard (notNullOf (folded._PreT) ts) <?> "no terminal encountered"-  return ts--parsePreEE = do-  es <- (:[]) <$> parsePreE <* whiteSpace <|> listP parsePreE-  guard (allOf (folded._PreT) (const True) es) <?> ""-  return es---- | Parses a list of a la @[a,b,c]@--listP = brackets . commaSep------ * Monadic Parsing Machinery---- | Parser with 'GrammarState'--newtype GrammarParser m a = GrammarP { runGrammarP :: StateT GrammarState m a }-  deriving  ( Monad-            , MonadPlus-            , Alternative-            , Applicative-            , Functor-            , MonadState GrammarState-            , TokenParsing-            , CharParsing-            , MonadTrans-            )--deriving instance (Parsing m, MonadPlus m) => Parsing (GrammarParser m) -- Nominal role, ghc 7.8---- | Functions that parse using the 'GrammarParser'--type Parse  a = ( Monad m-                , MonadPlus m-                , TokenParsing m-                ) => GrammarParser m a---- | Parsing where we stop at a newline (which needs to be parsed explicitly)--type ParseU a = (Monad m-                , MonadPlus m-                , TokenParsing m-                ) => Unlined (GrammarParser m) a--type P m = ( Monad m-           , MonadPlus m-           , Alternative m-           , Parsing m-           , TokenParsing m-           , MonadState GrammarState m-           )---- | grammar identifiers--grammarIdentifiers = set styleReserved rs emptyIdents where-  rs = H.fromList ["Grammar:", "N:", "T:", "E:"]---- | partial binding of 'reserve' to idents--reserveGI = reserve grammarIdentifiers--identGI = ident grammarIdentifiers----parseGrammar :: String -> String -> Result Grammar-parseGrammar fname cnts = parseString-  ((evalStateT . runGrammarP) grammar def)-  (Directed (B.pack fname) 0 0 0 0)-  cnts-------- test stuff-----testGrammar = unlines-  [ "Grammar: Align"-  , "N: X{2}"-  , "N: Y{2}"-  , "N: Z"-  , "T: a"-  , "T: e"-  , "E: ε"-  , "S: X"-  , "[X{i},Y{j}] -> many <<< [X{j+1},Y{i-1}]"-  , "[X{i},Y{i}] -> eeee <<< [e,e]"-  , "[X{1},Y{0}] -> blar <<< [X{0},Y{1}]"-  , "[X{1},Y{0}] -> blub <<< [X{0},Y{i}]"-  , "Z -> step  <<< Z a Z a Z"---  , "Z -> done  <<< ε" -- this shouldn't actually be done, as @E@ symbols are to denote that nothing happens (so this is actually rather undefined)---  , "X -> stand <<< X"---  , "[X] -> oned <<< [X]"---  , "X -> eps   <<< epsilon"-  , "//"-  ]--testParsing :: Result Grammar-testParsing = parseString-                ((evalStateT . runGrammarP) grammar def)-                (Directed (B.pack "testGrammar") 0 0 0 0)-                testGrammar--asG = let (Success g) = testParsing in g---} 

@@ -2,10 +2,10 @@ module FormalLanguage.CFG.PrettyPrint   ( module FormalLanguage.CFG.PrettyPrint.ANSI   , module FormalLanguage.CFG.PrettyPrint.Haskell-  , module FormalLanguage.CFG.PrettyPrint.LaTeX+--  , module FormalLanguage.CFG.PrettyPrint.LaTeX   ) where  import FormalLanguage.CFG.PrettyPrint.ANSI import FormalLanguage.CFG.PrettyPrint.Haskell-import FormalLanguage.CFG.PrettyPrint.LaTeX+--import FormalLanguage.CFG.PrettyPrint.LaTeX 

@@ -57,7 +57,7 @@ steDoc (SynVar  n i s k) = indexDoc i >>= return . blue . (text (n^.getSteName) <>) steDoc (SynTerm n i    ) = indexDoc i >>= return . magenta . (text (n^.getSteName) <>) steDoc (Term    n i    ) = return . green . text $ n^.getSteName-steDoc (Epsilon        ) = return . red   . text $ "ε"+steDoc (Epsilon _      ) = return . red   . text $ "ε" steDoc (Deletion       ) = return . red   . text $ "-"  indexDoc :: [Index] -> Reader Grammar Doc

@@ -1,69 +0,0 @@--module FormalLanguage.CFG.PrettyPrint.LaTeX-  ( renderFile-  , renderLaTeX-  ) where--import Control.Lens hiding ((&), to)-import Data.List (intersperse)-import Data.Set (toList)-import Data.Text (pack)-import Text.LaTeX.Base-import Text.LaTeX.Base.Class-import Text.LaTeX.Base.Syntax-import Text.LaTeX.Packages.AMSMath hiding (align)--import FormalLanguage.CFG.Grammar----renderLaTeX :: Int -> Grammar -> LaTeX-renderLaTeX = error "renderLaTeX" -- renderGrammar--{----- | Transform a grammar to some LaTeX code.--renderGrammar :: LaTeXC l => Int -> Grammar -> l-renderGrammar k g -- (Grammar ps gname)-  | k == 1 = align xs-  | k == 2 = align2 xs-  where -- subsubsection (raw $ pack gname) <> raw "\n" <> align2 xs <> raw "\n" where-    xs = [ (renderNtT l, mconcat (map renderNtT r)) | Rule l _ r <- toList (g^.rules) ]---- | Transform a single 'Symb'. This will produce a column of terminal /--- non-terminal symbols.------ TODO inside/outside--renderNtT :: LaTeXC l => Symb -> l-renderNtT (Symb io xs) = ll <> (mci $ map go xs) <> rr-  where-    go (T s  ) = render s-    go (N s e)-      | Singular        <- e = render s-      | IntBased   k zs <- e = render s !: (raw . pack $ show k)-    go (E    ) = render "-"---      | Enumerated k zs <- e = render s !: (raw . pack $ k)-    ll = raw "\\begingroup \\left ( \\begin{smallmatrix}"-    rr = raw "\\end{smallmatrix} \\right ) \\endgroup" where-    render x-      | x == "empty" = varepsilon-      | null x       = epsilon -- raw $ pack "-"-      | otherwise    = raw $ pack x--mci = mconcat . intersperse (raw "\\\\\n")--align :: LaTeXC l => [(l,l)] -> l-align = (liftL $ TeXEnv "align*" []) . go where-  go xs = mci [ l & to <> r | (l,r) <- xs ]--align2 :: LaTeXC l => [(l,l)] -> l-align2 = (liftL $ TeXEnv "align*" []) . go where-  go xs = let len     = length xs-              (as,bs) = splitAt ((len +1) `div` 2) $ xs ++ repeat ("","")-              to' c = if c > len `div` 2 then "" else to-          in-              mci [ ll & to <> lr & rl & to' c <> rr | (ll,lr) <- as | ((rl,rr),c) <- zip bs [1..] ]--}-

@@ -7,19 +7,20 @@ module FormalLanguage.CFG.QQ where  import Control.Applicative ((<$>),(<*>),empty)+import Control.Lens hiding (outside) import Control.Monad hiding (mapM) import Control.Monad.Trans.State.Strict (evalStateT) import Data.ByteString.Char8 (pack) import Data.Default (def)+import Data.List (nub)+import Data.List (transpose,sort,group)+import Data.Sequence (Seq) import Language.Haskell.TH import Language.Haskell.TH.Quote+import qualified Data.Sequence as Seq import Text.Trifecta.Delta (Delta (Directed)) import Text.Trifecta (parseString,Parser) import Text.Trifecta.Result (Result (..), ErrInfo (..))-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Control.Lens-import Data.List (transpose,sort,group)  -- ghc 7.8 / 7.10 split @@ -48,12 +49,12 @@  -- | -parseFormalLanguage :: GrammarParser Parser () -> String -> Q [Dec]+parseFormalLanguage ∷ Parse' () -> String -> Q [Dec] parseFormalLanguage ps s = do   loc <- location   let (lpos,cpos) = loc_start loc   -- let r = parseString ((evalStateT . runGrammarP) grammar def) (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0) $ trim s-  let r = parseString ((evalStateT . runGrammarParser) (parseEverything ps) def) (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0) $ trim s+  let r = parseString (evalStateT (parseEverything ps) def) (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0) $ trim s   case r of     (Failure (ErrInfo f _)) -> do       runIO . printDoc $ f@@ -77,14 +78,20 @@  -- | Determine the length of the unique prefix we need for algebra -- functions.+--+-- TODO only go over inside grammars! unless the inside grammar for an outside+-- grammar has not been emitted.  uniquePrefixLength :: Seq Grammar -> Int uniquePrefixLength xs-  | l == 0    = 0-  | l == 1    = 0-  | otherwise = go 1 . transpose $ xs^..folded.grammarName+--  | l == 0    = 0+--  | l == 1    = 0+  | otherwise = go 0 . transpose $ nub [ getName x | x ← xs^..folded ]   where l = Seq.length xs         go :: Int -> [String] -> Int         go acc []       = error $ "for whatever reason, there are two grammars with the same name!" ++ show xs         go acc (xs:xss) = if (maximum . map length . group $ sort xs) > 1 then go (acc+1) xss else acc+        getName x+          | Outside gI ← x^.outside = gI^.grammarName+          | otherwise               = x^.grammarName 

@@ -37,6 +37,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import           Text.Printf import qualified GHC.TypeLits as Kind+import           Data.Foldable (toList)  import           ADP.Fusion.Core ( (%), (|||), (...), (<<<) ) import           Data.PrimitiveArray (Z(..), (:.)(..))@@ -139,6 +140,7 @@  codeGen :: TQ [Dec] codeGen = do+  g ← use qGrammar   -- build up the terminal symbol lookup   qTermAtomVarNames <~ M.fromList <$> dimensionalTermSymbNames   qTermSymbExp      <~ M.fromList <$> (mapM grammarTermExpression =<< uniqueTerminalSymbols <$> use qGrammar)@@ -152,28 +154,47 @@   gra <- grammar   -- create inlining code   inl <- use qGrammarName >>= \gname -> lift $ pragInlD gname Inline FunLike AllPhases-  -- outside grammars use the inside signature?!-  g <- use qGrammar-  if False -- isOutside $ g^.outside -- considering to just use unsafeCoerce on inside algebras-    then return [gra,inl]-    else return [sig,gra,inl]+  return $ toList sig ++ [gra,inl]  -- | Create the signature. Will also set the signature name.+--+-- TODO check if signature has already been emitted (from inside, say). If so,+-- don't do anything. This goes by signature name. -signature :: TQ Dec+signature :: TQ (Maybe Dec) signature = do-  m         <- use qMTyName-  x         <- use qElemTyName-  r         <- use qRetTyName-  termNames <- use qTermAtomTyNames-  sigName   <- (mkName . ("Sig" ++)) <$> use (qGrammar.grammarName)-  fs        <- use qAttribFuns-  h         <- use qChoiceFun-  qSigName .= sigName-  lift $ dataD (cxt [])-               sigName-               (PlainTV m : PlainTV x : PlainTV r : (map PlainTV $ termNames^..folded))-               [recC sigName ((map return $ fs^..folded) ++ [return h])]+  g ← use qGrammar+  let gName = case g^.outside of+                Inside → g^.grammarName+                Outside gI → gI^.grammarName+  -- we can not lookup signatures in the environment, because everything is emitted in one go...+  -- hence we query the environment if such a signature has already been emitted...+  -- lkupName ← lift $ lookupValueName ("Sig" ++ gName)+  -- lift . runIO $ print (gName, lkupName)+  -- case lkupName of+  --   Just theName → do+  --     qSigName .= theName+  --     return Nothing+  --   Nothing → do+  case g^.outside of+    Outside gI → do+      lift . runIO $ putStrLn "WARNING: using workaround for Inside/Outside sharing which REQUIRES emitting the inside grammar!"+      qSigName .= (mkName $ "Sig" ++ gI^.grammarName)+      return Nothing+    Inside → do+      gType     ← use (qGrammar.outside)+      m         <- use qMTyName+      x         <- use qElemTyName+      r         <- use qRetTyName+      termNames <- use qTermAtomTyNames+      sigName   <- (mkName . ("Sig" ++)) <$> use (qGrammar.grammarName)+      fs        <- use qAttribFuns+      h         <- use qChoiceFun+      qSigName .= sigName+      lift $ Just <$> dataD (cxt [])+                   sigName+                   (PlainTV m : PlainTV x : PlainTV r : (map PlainTV $ termNames^..folded))+                   [recC sigName ((map return $ fs^..folded) ++ [return h])]  -- | The grammar requires three types of arguments. First we need to bind -- an algebra. Then we bind a list of non-terminals. Finally we bind a list@@ -314,14 +335,15 @@   let genType :: Int -> [SynTermEps] -> TypeQ       genType tape z         | [Deletion]      <- z = [t| () |]-        | [Epsilon ]      <- z = [t| () |]+        | [Epsilon _]     <- z = [t| () |]         | [Term tnm tidx] <- z         , Just v <- M.lookup (tnm^.getSteName,tape) ttypes = varT v -- single dimension only, set dim to 0         | [Term tnm tidx] <- z = varT elemTyName         | xs              <- z = foldl (\acc (tape',z) -> [t| $acc :. $(genType tape' [z]) |]) [t| Z |] (zip [0..] xs)   let genSingleExp :: Int -> SynTermEps -> ExpQ       genSingleExp _ Deletion = [| ADP.Deletion |]-      genSingleExp _ Epsilon  = [| ADP.Epsilon  |]+      genSingleExp _ (Epsilon Global) = [| ADP.Epsilon @Global |]+      genSingleExp _ (Epsilon Local) = [| ADP.Epsilon @Local |]       genSingleExp _ (((`M.lookup` synNames) . Symbol . (:[])) -> Just n) = error $ show n       genSingleExp k (Term tnm tidx)         | Just n <- M.lookup (tnm^.getSteName,k) tavn = varE n@@ -333,7 +355,8 @@   let genExp :: [SynTermEps] -> ExpQ       genExp z         | [Deletion]      <- z = [| ADP.Deletion |] -- TODO ???-        | [Epsilon ]      <- z = [| ADP.Epsilon  |]+        | [Epsilon Global]      <- z = [| ADP.Epsilon @Global |]+        | [Epsilon Local]      <- z = [| ADP.Epsilon @Local |]         | [Term tnm tidx] <- z         , Just v <- M.lookup (tnm^.getSteName,0) tavn = varE v         | xs              <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(genSingleExp k z) |])@@ -418,7 +441,7 @@                                       then attrFun                                       else prefix ++ over _head toUpper attrFun   tp <- lift $ foldr appT (varT elemTyName) $ map (appT arrowT . argument) $ r^.rhs-  ns <- lift notStrict+  ns <- lift $ bang noSourceUnpackedness noSourceStrictness   return (f:fs, (nm,ns,tp))  -- | Build the choice function. Basically @Stream m s -> m r@.@@ -432,6 +455,6 @@   let rtrn = AppT (VarT mTyName) (VarT retTyName)   prefix <- use qPrefix   let hFun = if null prefix then "h" else prefix ++ "H"-  ns <- lift notStrict+  ns <- lift $ bang noSourceUnpackedness noSourceStrictness   return (mkName hFun, ns, AppT args rtrn) 

@@ -7,7 +7,9 @@ import           Language.Haskell.TH  -+#if MIN_VERSION_base(4,10,0)+dataD ctxt tc tvs cons = TH.dataD ctxt tc tvs Nothing cons []+#else #if MIN_VERSION_base(4,9,0) --dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> CxtQ -> DecQ --@@ -16,5 +18,6 @@ dataD ctxt tc tvs cons = TH.dataD ctxt tc tvs Nothing cons (return []) #else dataD ctxt tc tvs cons = TH.dataD ctxt tc tvs cons []+#endif #endif 

@@ -29,7 +29,7 @@     [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf)   1.  Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler       *Algebraic dynamic programming for multiple context-free languages*  -    2015, submitted  +    2016, Theoretical Computer Science       [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)    

@@ -1,3 +1,10 @@+0.3.2.0+-------++- parsers 0.12.5 added mtl instances for Unlined, etc. We remove our own+  instances and require 0.12.5 as the new minimal version+- bang -> notStrict (GHC 8 only)+ 0.3.1.1 ------- 

@@ -1,67 +0,0 @@---- | This small utility allows us to turn a formal language description into--- either a LaTeX source file or a Haskell module.--module Main where--import System.Console.CmdArgs-import System.IO (openFile, hClose, IOMode (..))-import Text.PrettyPrint.ANSI.Leijen (hPutDoc)-import Data.Foldable (toList)-import Text.Trifecta.Result (ErrInfo (..))--import FormalLanguage.CFG.Grammar-import FormalLanguage.CFG.Parser-import FormalLanguage.CFG.PrettyPrint.ANSI (printDoc, genGrammarDoc)-import FormalLanguage.CFG.PrettyPrint.Haskell (grammarHaskell)-import FormalLanguage.CFG.PrettyPrint.LaTeX (renderFile, renderLaTeX)----data Options-  = LaTeX-    { inFile :: String-    , outFile ::String-    }-  | Ansi-    { inFile :: String-    }-  | Haskell-    { inFile :: String-    , outFile :: String-    }-  deriving (Show,Data,Typeable)--optionLatex = LaTeX-  { inFile = ""-  , outFile = ""-  }--optionAnsi = Ansi-  { inFile = ""-  }--optionHaskell = Haskell-  { inFile = ""-  , outFile = ""-  }--main = do-  o <- cmdArgs $ modes [{- optionLatex, -} optionAnsi]---  print o-  pr <- case (inFile o) of-          "" -> getContents >>= return . parse-          fn -> readFile fn >>= return . parse-  case pr of-    Failure (ErrInfo f _) -> printDoc f-    Success s -> case o of---      LaTeX{..} -> case outFile of---        "" -> error "need to set output file name"---        fn -> renderFile fn $ renderLaTeX 2 s-      Ansi {..} -> mapM_ (printDoc . genGrammarDoc) $ toList s---      Haskell{..} -> case outFile of---        "" -> printDoc $ grammarHaskell s---        fn -> do h <- openFile fn WriteMode---                 hPutDoc h $ grammarHaskell s---                 hClose h-

@@ -1,104 +0,0 @@---- | Needleman-Wunsch global alignment algorithm.--module Main where--import           Control.Applicative ()-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List (take)-import           Data.Vector.Fusion.Util-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           Data.Vector.Unboxed (Vector)-import           Text.Printf--import           ADP.Fusion-import           Data.PrimitiveArray as PA hiding (map,toList)--import           FormalLanguage.CFG------ | Define signature and grammar--[formalLanguage|-Verbose--Grammar: Global-N: X-T: c      -- NOTE that each tape with a 'c' uses its own type!-S: [X,X]-[X,X] -> done  <<< [e,e]-[X,X] -> align <<< [X,X] [c,c]-[X,X] -> indel <<< [X,X] [-,c]-[X,X] -> delin <<< [X,X] [c,-]-//--Emit: Global-|]---makeAlgebraProduct ''SigGlobal----- |--score :: Monad m => SigGlobal m Int Int Char Char-score = SigGlobal-  { done  = \   (Z:.():.()) -> 0-  , align = \ x (Z:.a :.b ) -> if a==b then x+1 else -999999-  , indel = \ x (Z:.():.b ) -> x - 2-  , delin = \ x (Z:.a :.()) -> x - 2-  , h     = SM.foldl' max (-999999)-  }-{-# INLINE score #-}----- | ------ NOTE The alignment needs to be reversed to print out.--pretty :: Monad m => SigGlobal m (String,String) [(String,String)] Char Char-pretty = SigGlobal-  { done  = \       (Z:.():.()) -> ("","")-  , align = \ (x,y) (Z:.a :.b ) -> (x ++ [a] ,y ++ [b]) -  , indel = \ (x,y) (Z:.():.b ) -> (x ++ "-" ,y ++ [b]) -  , delin = \ (x,y) (Z:.a :.()) -> (x ++ [a] ,y ++ "-") -  , h     = SM.toList-  }-{-# Inline pretty #-}--runNeedlemanWunsch :: Int -> String -> String -> (Int,[(String,String)])-runNeedlemanWunsch k i1' i2' = (d, take k . unId $ axiom b) where-  i1 = VU.fromList i1'-  i2 = VU.fromList i2'-  !(Z:.t) = runNeedlemanWunschForward i1 i2-  d = unId $ axiom t-  !(Z:.b) = gGlobal (score <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i1) (chr i2)-{-# NoInline runNeedlemanWunsch #-}---- | Decoupling the forward phase for CORE observation.--runNeedlemanWunschForward :: Vector Char -> Vector Char -> Z:.(TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int)-runNeedlemanWunschForward i1 i2 = let n1 = VU.length i1; n2 = VU.length i2 in mutateTablesDefault $-  gGlobal score-    (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))-    (chr i1) (chr i2)-{-# NoInline runNeedlemanWunschForward #-}--main = do-  ls <- lines <$> getContents-  let eats [] = return ()-      eats [x] = return ()-      eats (a:b:xs) = do-        putStrLn a-        putStrLn b-        let (k,ys) = runNeedlemanWunsch 1 a b-        forM_ ys $ \(y1,y2) -> printf "%s %5d\n%s\n" y1 k y2-        eats xs-  eats ls-

@@ -1,122 +0,0 @@---- | The Nussinov RNA secondary structure prediction problem.--module Main where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List-import           Data.Vector.Fusion.Util-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           Text.Printf-import           Unsafe.Coerce (unsafeCoerce)--import           ADP.Fusion-import           Data.PrimitiveArray as PA hiding (map)--import           FormalLanguage------ | Define signature and grammar--[formalLanguage|-Verbose--Grammar: Nussinov-N: X-T: c-S: X-X -> unp <<< X c-X -> jux <<< X c X c-X -> nil <<< e-//--Outside: Vonissun-Source:  Nussinov-//--Emit: Nussinov-Emit: Vonissun-|]----makeAlgebraProduct ''SigNussinov-makeAlgebraProduct ''SigVonissun--bpmax :: Monad m => SigNussinov m Int Int Char-bpmax = SigNussinov-  { nUnp = \ x c     -> x-  , nJux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999-  , nNil = \ ()      -> 0-  , nH   = SM.foldl' max 0-  }-{-# INLINE bpmax #-}--bpmaxV :: Monad m => SigVonissun m Int Int Char-bpmaxV = undefined--pairs !c !d-  =  c=='A' && d=='U'-  || c=='C' && d=='G'-  || c=='G' && d=='C'-  || c=='G' && d=='U'-  || c=='U' && d=='A'-  || c=='U' && d=='G'-{-# INLINE pairs #-}--pretty :: Monad m => SigNussinov m String [String] Char-pretty = SigNussinov-  { nUnp = \ x c     -> x ++ "."-  , nJux = \ x c y d -> x ++ "(" ++ y ++ ")"-  , nNil = \ ()      -> ""-  , nH   = SM.toList-  }-{-# INLINE pretty #-}--prettyV :: Monad m => SigVonissun m String [String] Char-prettyV = undefined--runNussinov :: Int -> String -> (Int,[String]) -- ,Int,[String])-runNussinov k inp = (d, take k . unId $ axiom b) where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  !(Z:.t) = mutateTablesDefault-          $ gNussinov bpmax-              (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))-              (chr i)-              :: Z:.TwITbl Id Unboxed EmptyOk (Subword I) Int-  d = unId $ axiom t-  !(Z:.b) = gNussinov (bpmax <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i)-              :: Z:.TwITblBt Unboxed EmptyOk (Subword I) Int Id Id String-{-# NoInline runNussinov #-}--runVonissun :: Int -> String -> (Int,[String])-runVonissun k inp = (d, []) where -- take k . unId $ axiom b) where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  !(Z:.t) = mutateTablesDefault-          $ gVonissun bpmaxV-              (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))-              (undefined :: TwITbl Id Unboxed EmptyOk (Subword I) Int)-              (chr i)-              :: Z:.TwITbl Id Unboxed EmptyOk (Subword O) Int-  d = unId $ axiom t---  !(Z:.b) = gVonissun (bpmaxV <|| prettyV) (toBacktrack t (undefined :: Id a -> Id a)) (undefined :: Backtrack (ITbl Id Unboxed Subword Int) Id Id String) (chr i)-{-# NoInline runVonissun #-}----main = do-  ls <- lines <$> getContents-  forM_ ls $ \l -> do-    putStrLn l-    let (k,[x]) = runNussinov 1 l-    printf "%s %5d\n" x k-

@@ -1,138 +0,0 @@---- | Needleman-Wunsch global alignment algorithm.--module Main where--import           Control.Applicative ()-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List (take)-import           Data.Vector.Fusion.Util-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           Data.Vector.Unboxed (Vector)-import           Text.Printf--import           ADP.Fusion-import           Data.PrimitiveArray as PA hiding (map,toList)--import           FormalLanguage.CFG------ | Define signature and grammar--[formalLanguage|-Verbose--Grammar: Global-N: X-T: c      -- NOTE that each tape with a 'c' uses its own type!-S: [X,X,X]-[X,X,X] -> done <<< [e,e,e]-[X,X,X] -> ccc  <<< [X,X,X] [c,c,c]-[X,X,X] -> ccm  <<< [X,X,X] [c,c,-]-[X,X,X] -> cmc  <<< [X,X,X] [c,-,c]-[X,X,X] -> mcc  <<< [X,X,X] [-,c,c]-[X,X,X] -> cmm  <<< [X,X,X] [c,-,-]-[X,X,X] -> mcm  <<< [X,X,X] [-,c,-]-[X,X,X] -> mmc  <<< [X,X,X] [-,-,c]-//--Emit: Global---- SumOfPairs: Global has the following job: it takes the signature of the--- given grammar (here Global) and provides a second signature SopGlobal--- and a function of type @SopGlobal -> Global@. SopGlobal is special in--- that we need functions for combining two '-' characters, the actual--- 'sum' function in sum-of-pairs which is not really a monoid, since we--- have to take in all arguments and combine correctly.------ Example (a,b,'-') yields (a,b) , (a,'-') , (b,'-') and produces either--- a score of a triple.------ TODO use a function of arguments to Global directly?---- SumOfPairs: Global-|]---makeAlgebraProduct ''SigGlobal----data SopGlobal' m s r x y z = SopGlobal'-  {-  }---- |--score :: Monad m => SigGlobal m Int Int Char Char Char-score = SigGlobal-  { done  = \   (Z:.():.():.()) -> 0-  , ccc   = \ x (Z:.a :.b :.c ) -> if a==b && a==c then x+3 else -999999-  , ccm   = \ x (Z:.a :.b :.()) -> if a==b         then x+1 else -999999-  , cmc   = \ x (Z:.a :.():.c ) -> if a==c         then x+1 else -999999-  , mcc   = \ x (Z:.():.b :.c ) -> if b==c         then x+1 else -999999-  , cmm   = \ x (Z:.a :.():.()) -> x-2-  , mcm   = \ x (Z:.():.b :.()) -> x-2-  , mmc   = \ x (Z:.():.():.c ) -> x-2-  , h     = SM.foldl' max (-999999)-  }-{-# INLINE score #-}----- | --pretty :: Monad m => SigGlobal m (String,String,String) [(String,String,String)] Char Char Char-pretty = SigGlobal-  { done  = \         (Z:.():.():.()) -> ("","","")-  , ccc   = \ (x,y,z) (Z:.a :.b :.c ) -> (x ++ [a] ,y ++ [b], z ++ [c])-  , ccm   = \ (x,y,z) (Z:.a :.b :.()) -> (x ++ [a] ,y ++ [b], z ++ "-")-  , cmc   = \ (x,y,z) (Z:.a :.():.c ) -> (x ++ [a] ,y ++ "-", z ++ [c])-  , mcc   = \ (x,y,z) (Z:.():.b :.c ) -> (x ++ "-" ,y ++ [b], z ++ [c])-  , cmm   = \ (x,y,z) (Z:.a :.():.()) -> (x ++ [a] ,y ++ "-", z ++ "-")-  , mcm   = \ (x,y,z) (Z:.():.b :.()) -> (x ++ "-" ,y ++ [b], z ++ "-")-  , mmc   = \ (x,y,z) (Z:.():.():.c ) -> (x ++ "-" ,y ++ "-", z ++ [c])-  , h     = SM.toList-  }-{-# Inline pretty #-}--runNeedlemanWunsch :: Int -> String -> String -> String -> (Int,[(String,String,String)])-runNeedlemanWunsch k i1' i2' i3' = (d, take k . unId $ axiom b) where-  i1 = VU.fromList i1'-  i2 = VU.fromList i2'-  i3 = VU.fromList i3'-  !(Z:.t) = runNeedlemanWunschForward i1 i2 i3-  d = unId $ axiom t-  !(Z:.b) = gGlobal (score <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i1) (chr i2) (chr i3)-{-# NoInline runNeedlemanWunsch #-}---- | Decoupling the forward phase for CORE observation.--runNeedlemanWunschForward-  :: Vector Char-  -> Vector Char-  -> Vector Char-  -> Z:.(TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I:.PointL I) Int)-runNeedlemanWunschForward i1 i2 i3 = let n1 = VU.length i1; n2 = VU.length i2; n3 = VU.length i3 in mutateTablesDefault $-  gGlobal score-    (ITbl 0 0 (Z:.EmptyOk:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2:.PointL n3) (-999999) []))-    (chr i1) (chr i2) (chr i3)-{-# NoInline runNeedlemanWunschForward #-}--main = do-  ls <- lines <$> getContents-  let eats (a:b:c:xs) = do-        putStrLn a-        putStrLn b-        putStrLn c-        let (k,ys) = runNeedlemanWunsch 1 a b c-        forM_ ys $ \(y1,y2,y3) -> printf "%s %5d\n%s\n%s\n" y1 k y2 y3-        eats xs-      eats _ = return ()-  eats ls-

@@ -1,14 +1,8 @@  module Main where -import Test.Tasty-import Test.Tasty.TH  - main :: IO ()-main = do-  defaultMain $ testGroup ""-    [-    ]+main = return ()