FormalGrammars 0.3.0.0 → 0.3.1.0
raw patch · 10 files changed
+267/−35 lines, 10 filesdep ~ADPfusiondep ~HaTeXdep ~PrimitiveArraynew-component:exe:TriNeedleFGPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ADPfusion, HaTeX, PrimitiveArray, base, data-default, transformers, trifecta, vector
API changes (from Hackage documentation)
+ FormalLanguage.CFG.TH.Internal: dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> DecQ
- FormalLanguage.CFG.Parser: Failure :: Doc -> Result a
+ FormalLanguage.CFG.Parser: Failure :: ErrInfo -> Result a
Files
- FormalGrammars.cabal +57/−10
- FormalLanguage/CFG/Grammar/Types.hs +23/−10
- FormalLanguage/CFG/QQ.hs +2/−2
- FormalLanguage/CFG/TH.hs +14/−8
- FormalLanguage/CFG/TH/Internal.hs +20/−0
- changelog.md +6/−0
- src/GrammarPP.hs +2/−1
- src/NeedlemanWunsch.hs +1/−1
- src/Nussinov.hs +4/−3
- src/TriNeedle.hs +138/−0
FormalGrammars.cabal view
@@ -1,5 +1,5 @@ name: FormalGrammars-version: 0.3.0.0+version: 0.3.1.0 author: Christian Hoener zu Siederdissen, 2013-2016 copyright: Christian Hoener zu Siederdissen, 2013-2016 homepage: https://github.com/choener/FormalGrammars@@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0-tested-with: GHC == 7.8.4, GHC == 7.10.3+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 synopsis: (Context-free) grammars in formal language theory description: <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>@@ -68,24 +68,25 @@ library- build-depends: base >= 4.7 && < 4.9- , ADPfusion >= 0.5.1 && < 0.5.2+ build-depends: base >= 4.7 && < 5.0 , ansi-wl-pprint >= 0.6.7 && < 0.6.8 , bytestring >= 0.10 && < 0.11 , containers- , data-default >= 0.5 && < 0.6- , HaTeX >= 3.16 && < 3.17+ , data-default >= 0.5 && < 0.7+ , HaTeX >= 3.16 && < 4.0 , lens >= 4.0 && < 5.0 , mtl >= 2.0 && < 3.0 , parsers >= 0.12 && < 0.13- , PrimitiveArray >= 0.6.0 && < 0.7.1 , semigroups >= 0.16 && < 0.19 , template-haskell , text >= 1.0 && < 1.3- , transformers >= 0.3 && < 0.5- , trifecta >= 1.5 && < 1.6+ , transformers >= 0.3 && < 0.6+ , trifecta >= 1.6 && < 1.7 , unordered-containers >= 0.2 && < 0.3 , vector >= 0.10 && < 0.12+ --+ , ADPfusion == 0.5.2.*+ , PrimitiveArray == 0.7.1.* exposed-modules: FormalLanguage FormalLanguage.CFG@@ -99,11 +100,12 @@ FormalLanguage.CFG.PrettyPrint.Haskell FormalLanguage.CFG.PrettyPrint.LaTeX FormalLanguage.CFG.QQ--- FormalLanguage.CFG.QuickCheck FormalLanguage.CFG.TH+ FormalLanguage.CFG.TH.Internal default-language: Haskell2010 default-extensions: BangPatterns+ , CPP , DeriveDataTypeable , DataKinds , FlexibleContexts@@ -136,6 +138,7 @@ , ansi-wl-pprint , cmdargs >= 0.10 && < 0.11 , FormalGrammars+ , trifecta hs-source-dirs: src default-language:@@ -207,6 +210,50 @@ 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++++executable TriNeedleFG+ if flag(examples)+ buildable:+ True+ build-depends: base+ , ADPfusion+ , containers+ , FormalGrammars+ , PrimitiveArray+ , template-haskell+ , vector+ else+ buildable:+ False+ hs-source-dirs:+ src+ main-is:+ TriNeedle.hs default-language: Haskell2010 default-extensions: BangPatterns
FormalLanguage/CFG/Grammar/Types.hs view
@@ -166,16 +166,29 @@ -- TODO better way to handle indexed symbols? data Grammar = Grammar- { _synvars :: Map SymbolName SynTermEps -- ^ regular syntactic variables, without dimension- , _synterms :: Map SymbolName SynTermEps -- ^ Terminal synvars are somewhat weird. They are used in Outside grammars, and hold previously calculated inside values.- , _termvars :: Map SymbolName SynTermEps -- ^ regular terminal symbols- , _outside :: DerivedGrammar -- ^ Is this an automatically derived outside grammar- , _rules :: Set Rule -- ^ set of production rules- , _start :: Symbol -- ^ start symbol- , _params :: Map IndexName Index -- ^ any global variables- , _indices :: Map IndexName Index -- ^ active indices- , _grammarName :: String -- ^ grammar name- , _write :: Bool -- ^ some grammar file requested this grammar to be expanded into code -- TODO remove, we have an emission queue+ { _synvars :: Map SymbolName SynTermEps+ -- ^ regular syntactic variables, without dimension+ , _synterms :: Map SymbolName SynTermEps+ -- ^ Terminal synvars are somewhat weird. They are used in Outside+ -- grammars, and hold previously calculated inside values.+ , _termvars :: Map SymbolName SynTermEps+ -- ^ regular terminal symbols+ , _outside :: DerivedGrammar+ -- ^ Is this an automatically derived outside grammar+ , _rules :: Set Rule+ -- ^ set of production rules+ , _start :: Symbol+ -- ^ start symbol+ , _params :: Map IndexName Index+ -- ^ any global variables+ , _indices :: Map IndexName Index+ -- ^ active indices+ , _grammarName :: String+ -- ^ grammar name+ , _write :: Bool+ -- ^ some grammar file requested this grammar to be expanded into code+ --+ -- TODO remove, we have an emission queue } deriving (Show,Data,Typeable)
FormalLanguage/CFG/QQ.hs view
@@ -15,7 +15,7 @@ import Language.Haskell.TH.Quote import Text.Trifecta.Delta (Delta (Directed)) import Text.Trifecta (parseString,Parser)-import Text.Trifecta.Result (Result (..))+import Text.Trifecta.Result (Result (..), ErrInfo (..)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Control.Lens@@ -55,7 +55,7 @@ -- 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 case r of- (Failure f) -> do+ (Failure (ErrInfo f _)) -> do runIO . printDoc $ f error "aborting parseFormalLanguage" (Success g) -> do
FormalLanguage/CFG/TH.hs view
@@ -30,7 +30,7 @@ import Data.Vector.Fusion.Stream.Monadic (Stream) import Debug.Trace import GHC.Exts (the)-import Language.Haskell.TH+import Language.Haskell.TH hiding (dataD) import Language.Haskell.TH.Syntax hiding (lift) import qualified Data.Map as M import qualified Data.Set as S@@ -38,12 +38,13 @@ import Text.Printf import qualified GHC.TypeLits as Kind -import ADP.Fusion ( (%), (|||), (...), (<<<) )+import ADP.Fusion.Core ( (%), (|||), (...), (<<<) ) import Data.PrimitiveArray (Z(..), (:.)(..))-import qualified ADP.Fusion as ADP+import qualified ADP.Fusion.Core as ADP import FormalLanguage.CFG.Grammar import FormalLanguage.CFG.PrettyPrint.ANSI+import FormalLanguage.CFG.TH.Internal @@ -173,7 +174,6 @@ 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@@ -195,7 +195,7 @@ -- bind algebra let alg = recP signame [ fieldPat n (varP n) | (n,_,_) <- h:(fs^..folded) ] -- bind partially applied non-terminals- let syn = [ varP s | s <- psyn^..folded ]+ let syn = [ bangP $ varP s | s <- psyn^..folded ] -- bind fully applied non-terminals let isn = [ bangP $ varP s | s <- isyn^..folded ] -- bind terminals@@ -251,7 +251,11 @@ (varE '(...)) (varE hname) ) (varE ix)- return $ valD (varP n) (normalB $ appE (varE $ M.findWithDefault (error "grammarBodySyn") s partial) (lamE [varP ix] rhs)) []+ let sname = M.findWithDefault (error $ "grammarBodySyn: name not found for: " ++ show s) s partial+ -- use @TW@ to combine the table @varE sname@ and the rule RHS @lamE...@+ let bdy = [| ADP.TW $(varE sname) $(lamE [varP ix] rhs) |]+ -- return $ valD (varP n) (normalB $ appE (varE $ M.findWithDefault (error "grammarBodySyn") s partial) (lamE [varP ix] rhs)) []+ return $ valD (varP n) (normalB bdy) [] -- | Build up the rhs for each rule. --@@ -414,7 +418,8 @@ then attrFun else prefix ++ over _head toUpper attrFun tp <- lift $ foldr appT (varT elemTyName) $ map (appT arrowT . argument) $ r^.rhs- return (f:fs, (nm,NotStrict,tp))+ ns <- lift notStrict+ return (f:fs, (nm,ns,tp)) -- | Build the choice function. Basically @Stream m s -> m r@. @@ -427,5 +432,6 @@ let rtrn = AppT (VarT mTyName) (VarT retTyName) prefix <- use qPrefix let hFun = if null prefix then "h" else prefix ++ "H"- return (mkName hFun, NotStrict, AppT args rtrn)+ ns <- lift notStrict+ return (mkName hFun, ns, AppT args rtrn)
+ FormalLanguage/CFG/TH/Internal.hs view
@@ -0,0 +1,20 @@++-- | Support for different Template Haskell versions.++module FormalLanguage.CFG.TH.Internal where++import qualified Language.Haskell.TH.Lib as TH+import Language.Haskell.TH++++#if MIN_VERSION_base(4,9,0)+--dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> CxtQ -> DecQ+--+-- NOTE the last argument would be @mapM conT xs@ if we actually had any+-- @xs@ to work with.+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+
changelog.md view
@@ -1,3 +1,9 @@+0.3.1.0+-------++- This version only works together with ADPfusion-0.5.2, this update improves+ performance for all grammars.+ 0.3.0.0 -------
src/GrammarPP.hs view
@@ -8,6 +8,7 @@ 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@@ -52,7 +53,7 @@ "" -> getContents >>= return . parse fn -> readFile fn >>= return . parse case pr of- Failure f -> printDoc f+ Failure (ErrInfo f _) -> printDoc f Success s -> case o of -- LaTeX{..} -> case outFile of -- "" -> error "need to set output file name"
src/NeedlemanWunsch.hs view
@@ -83,7 +83,7 @@ -- | Decoupling the forward phase for CORE observation. -runNeedlemanWunschForward :: Vector Char -> Vector Char -> Z:.(ITbl Id Unboxed (Z:.PointL I:.PointL I) Int)+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) []))
src/Nussinov.hs view
@@ -91,9 +91,10 @@ $ gNussinov bpmax (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) (chr i)- :: Z:.ITbl Id Unboxed (Subword I) Int+ :: 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])@@ -103,9 +104,9 @@ !(Z:.t) = mutateTablesDefault $ gVonissun bpmaxV (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))- (undefined :: ITbl Id Unboxed (Subword O) Int)+ (undefined :: TwITbl Id Unboxed EmptyOk (Subword I) Int) (chr i)- :: Z:.ITbl Id Unboxed (Subword O) Int+ :: 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 #-}
+ src/TriNeedle.hs view
@@ -0,0 +1,138 @@++-- | 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+