diff --git a/FormalGrammars.cabal b/FormalGrammars.cabal --- a/FormalGrammars.cabal +++ b/FormalGrammars.cabal @@ -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: @@ -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 diff --git a/FormalLanguage/CFG/Grammar/Types.hs b/FormalLanguage/CFG/Grammar/Types.hs --- a/FormalLanguage/CFG/Grammar/Types.hs +++ b/FormalLanguage/CFG/Grammar/Types.hs @@ -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) diff --git a/FormalLanguage/CFG/QQ.hs b/FormalLanguage/CFG/QQ.hs --- a/FormalLanguage/CFG/QQ.hs +++ b/FormalLanguage/CFG/QQ.hs @@ -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 diff --git a/FormalLanguage/CFG/TH.hs b/FormalLanguage/CFG/TH.hs --- a/FormalLanguage/CFG/TH.hs +++ b/FormalLanguage/CFG/TH.hs @@ -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) diff --git a/FormalLanguage/CFG/TH/Internal.hs b/FormalLanguage/CFG/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/FormalLanguage/CFG/TH/Internal.hs @@ -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 + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 ------- diff --git a/src/GrammarPP.hs b/src/GrammarPP.hs --- a/src/GrammarPP.hs +++ b/src/GrammarPP.hs @@ -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" diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs --- a/src/NeedlemanWunsch.hs +++ b/src/NeedlemanWunsch.hs @@ -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) [])) diff --git a/src/Nussinov.hs b/src/Nussinov.hs --- a/src/Nussinov.hs +++ b/src/Nussinov.hs @@ -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 #-} diff --git a/src/TriNeedle.hs b/src/TriNeedle.hs new file mode 100644 --- /dev/null +++ b/src/TriNeedle.hs @@ -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 +