GrammarProducts 0.0.0.4 → 0.1.0.0
raw patch · 19 files changed
+675/−341 lines, 19 filesdep +GrammarProductsdep +template-haskelldep +vectordep −HaTeXdep −cmdargsdep ~ADPfusiondep ~FormalGrammarsdep ~PrimitiveArraynew-component:exe:AlignGlobal
Dependencies added: GrammarProducts, template-haskell, vector
Dependencies removed: HaTeX, cmdargs
Dependency ranges changed: ADPfusion, FormalGrammars, PrimitiveArray, ansi-wl-pprint, base, bytestring, containers, data-default, lens, newtype, parsers, semigroups, transformers, trifecta
Files
- FormalLanguage/GrammarProduct.hs +4/−55
- FormalLanguage/GrammarProduct/Op.hs +55/−0
- FormalLanguage/GrammarProduct/Op/Add.hs +23/−25
- FormalLanguage/GrammarProduct/Op/Chomsky.hs +7/−6
- FormalLanguage/GrammarProduct/Op/Chomsky/Proof.hs +4/−0
- FormalLanguage/GrammarProduct/Op/Common.hs +35/−9
- FormalLanguage/GrammarProduct/Op/Greibach.hs +4/−1
- FormalLanguage/GrammarProduct/Op/Greibach/Proof.hs +4/−2
- FormalLanguage/GrammarProduct/Op/Linear.hs +40/−26
- FormalLanguage/GrammarProduct/Op/Power.hs +16/−1
- FormalLanguage/GrammarProduct/Op/Subtract.hs +25/−10
- FormalLanguage/GrammarProduct/Parser.hs +125/−27
- FormalLanguage/GrammarProduct/QQ.hs +52/−0
- GramProd.hs +0/−130
- GrammarProducts.cabal +125/−40
- README.md +17/−0
- changelog +0/−9
- changelog.md +29/−0
- src/AlignGlobal.hs +110/−0
FormalLanguage/GrammarProduct.hs view
@@ -7,61 +7,10 @@ -- TODO Later on we probably will be able to multiply without restrictions. module FormalLanguage.GrammarProduct- ( (><)- , gAdd- , gSubtract- , gPower+ ( module FormalLanguage.GrammarProduct.QQ ) where -import Data.Monoid--import FormalLanguage.CFG.Grammar--import FormalLanguage.GrammarProduct.Op.Greibach as Greibach-import FormalLanguage.GrammarProduct.Op.Chomsky as Chomsky-import FormalLanguage.GrammarProduct.Op.Linear as Linear-import FormalLanguage.GrammarProduct.Op.Add-import FormalLanguage.GrammarProduct.Op.Subtract as S-import FormalLanguage.GrammarProduct.Op.Power as P------ |--gAdd g h = runAdd $ (Add g) <> (Add h)--gSubtract g h = S.subtract g h--gPower = P.power------ | The product of two grammars.------ In general, it is quite hard to define the product of two context-free--- grammars in a way that keeps associativity and also "does what we want it to--- do" (see paper). For linear grammars it is much easier. Also, for grammars--- in certain normal forms, a simpler definition is possible. Due to this, we--- make the choice of the actual way on how to multiply based on the type of--- grammars given. This, however, should only affect the resulting rules, not--- the (multi-tape) language that the operations yields.------ TODO I think, left-linear could reasonably be expanded to both, left- and--- right-linear and maybe linear in general.------ NOTE A proof for associativity is possible, but generally hard, so we prefer--- to let the framework perform the proof for us.--(><) :: Grammar -> Grammar -> Grammar-g >< h- | isLeftLinear g && isLeftLinear h = runLinear $ Linear g <> Linear h--- | isChomskyNF g && isChomskyNF h = runCNF $ CNF g <> CNF h--- | isGreibachNF g && isGreibachNF h = runTwoGNF $ TwoGNF g <> TwoGNF h- | otherwise = error "Grammars in general CFG form are not handled. You need to convert into either Greibach- or Chomsky normal form. This might change in the future"---- | The addition operation defined for two grammars of the same dimension. It--- forms a monoid under the 'Add' newtype.--(.+) :: Grammar -> Grammar -> Grammar-g .+ h = runAdd $ Add g <> Add h+{-+-}+import FormalLanguage.GrammarProduct.QQ (grammarProduct)
+ FormalLanguage/GrammarProduct/Op.hs view
@@ -0,0 +1,55 @@++module FormalLanguage.GrammarProduct.Op where++import Data.Monoid++import FormalLanguage.CFG.Grammar++import FormalLanguage.GrammarProduct.Op.Greibach as Greibach+import FormalLanguage.GrammarProduct.Op.Chomsky as Chomsky+import FormalLanguage.GrammarProduct.Op.Linear as Linear+import FormalLanguage.GrammarProduct.Op.Add+import FormalLanguage.GrammarProduct.Op.Subtract as S+import FormalLanguage.GrammarProduct.Op.Power as P++++-- |++gAdd g h = runAdd $ (Add g) <> (Add h)++gSubtract g h = S.subtract g h++gPower = P.power++++-- | The product of two grammars.+--+-- In general, it is quite hard to define the product of two context-free+-- grammars in a way that keeps associativity and also "does what we want it to+-- do" (see paper). For linear grammars it is much easier. Also, for grammars+-- in certain normal forms, a simpler definition is possible. Due to this, we+-- make the choice of the actual way on how to multiply based on the type of+-- grammars given. This, however, should only affect the resulting rules, not+-- the (multi-tape) language that the operations yields.+--+-- TODO I think, left-linear could reasonably be expanded to both, left- and+-- right-linear and maybe linear in general.+--+-- NOTE A proof for associativity is possible, but generally hard, so we prefer+-- to let the framework perform the proof for us.++(><) :: Grammar -> Grammar -> Grammar+g >< h+ | isLeftLinear g && isLeftLinear h = runLinear $ Linear g <> Linear h+-- | isChomskyNF g && isChomskyNF h = runCNF $ CNF g <> CNF h+-- | isGreibachNF g && isGreibachNF h = runTwoGNF $ TwoGNF g <> TwoGNF h+ | otherwise = error "Grammars in general CFG form are not handled. You need to convert into either Greibach- or Chomsky normal form. This might change in the future"++-- | The addition operation defined for two grammars of the same dimension. It+-- forms a monoid under the 'Add' newtype.++(.+) :: Grammar -> Grammar -> Grammar+g .+ h = runAdd $ Add g <> Add h+
FormalLanguage/GrammarProduct/Op/Add.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE FlexibleInstances #-} module FormalLanguage.GrammarProduct.Op.Add where -import Control.Lens+import Control.Lens hiding (outside) import Control.Lens.Fold import Control.Newtype import Data.List (genericReplicate)@@ -10,11 +9,19 @@ import Data.Semigroup import qualified Data.Set as S import Text.Printf+import Data.Default import FormalLanguage.CFG.Grammar +import FormalLanguage.GrammarProduct.Op.Common ++-- |++add :: Grammar -> Grammar -> Grammar+add l r = runAdd $ Add l <> Add r+ -- | Add two grammars. Implemented as the union of production rules without any -- renaming. @@ -28,32 +35,23 @@ instance Semigroup (Add Grammar) where (Add l) <> (Add r)- | gDim l /= gDim r- = error $ printf "ERROR: grammars \n%s\n and \n%s\n have different dimensions, cannot unify. (add %d %d)"- (show l)- (show r)- (gDim l)- (gDim r)- | otherwise = Add $ Grammar (l^.tsyms <> r^.tsyms)- (l^.nsyms <> r^.nsyms) -- TODO add the newly created symbol to the non-terminals (or maybe just run ``fix T+N 's from the rules?'')- (l^.epsis <> r^.epsis)- (l^.rules <> r^.rules <> t)+ | Left err <- opCompatible l r = error err+ | otherwise = Add $ Grammar (l^.synvars <> r^.synvars)+ (l^.synterms <> r^.synterms) -- TODO add the newly created symbol to the non-terminals (or maybe just run ``fix T+N 's from the rules?'')+ (l^.termvars <> r^.termvars)+ (l^.outside)+ (l^.rules <> r^.rules) -- s- (l^.name <> r^.name)- where s = case (l^.start,r^.start) of- (Nothing, Nothing) -> Nothing- (Nothing, Just k ) -> Just k- (Just k , Nothing) -> Just k- (Just k , Just l ) -> if k==l then Just k else error "need to create new symbol, see note on Semigroup (Add Grammar)"- t = case (l^.start,r^.start) of- (Just k , Just l ) -> if k==l then S.empty else error "this will create the new rule"- _ -> S.empty- --(if l^.start == r^.start- -- then l^.start- -- else error "maybe add another rule and a unique start symbol?")+ (l^.params <> r^.params)+ (l^.grammarName <> r^.grammarName)+ False+ where s | l^.start == r^.start = l^.start+ | l^.start /= mempty && r^.start /= mempty = error "add new start symbol"+ | l^.start == mempty = r^.start+ | r^.start == mempty = l^.start instance Monoid (Add Grammar) where- mempty = Add $ Grammar S.empty S.empty S.empty S.empty Nothing ""+ mempty = Add def mappend = (<>) -- idempotency is not made explicit here
FormalLanguage/GrammarProduct/Op/Chomsky.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternGuards #-} module FormalLanguage.GrammarProduct.Op.Chomsky where @@ -25,6 +22,8 @@ +{-+ newtype CNF = CNF { runCNF :: Grammar } instance Semigroup CNF where@@ -93,7 +92,7 @@ printDoc $ rulesDoc $ S.singleton $ Rule l f rs printDoc $ rulesDoc $ S.singleton $ Rule a g bs fail "cannot handle (rule is not CNF):"- -- | otherwise = error $ "cannot handle (rule is not CNF): " ++ show (printDoc $ rulesDoc $ S.singleton $ Rule l f rs, Rule a g bs)+ -- \| otherwise = error $ "cannot handle (rule is not CNF): " ++ show (printDoc $ rulesDoc $ S.singleton $ Rule l f rs, Rule a g bs) {- -- | Extend mixed rules and rederive CNF@@ -125,11 +124,11 @@ -- the new non-terminal for the terminal symbol, with terms replaced by non-term symbols -- TODO we can't just replace all N here with eps, tome could have been created from other prods. trmN = Symb . map (\case (T s) -> N ("T"++s) Singular ; N _ _ -> eps; z -> z) $ x^.symb- -- finally the terminal + -- finally the terminal epsT = Symb . map (\case (N _ _) -> eps ; z -> z) $ x^.symb -} --- | +-- | symbToRules :: Symb -> Symb -> (Symb, [Rule]) symbToRules u' l'@@ -154,4 +153,6 @@ genTermStar :: Symb -> [TN] genTermStar s = map (\case (T s) -> N ("S"++s) Singular ; z -> z) $ s^.symb++-}
FormalLanguage/GrammarProduct/Op/Chomsky/Proof.hs view
@@ -30,6 +30,8 @@ +{-+ -- * Proof of associativity of the 2-GNF. -- | Run the 2-gnf grammar with the TwoGNF monoid which observes the 2 star@@ -73,4 +75,6 @@ -- , "Sa -> oneT <<< a" , "//" ]++-}
FormalLanguage/GrammarProduct/Op/Common.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE LambdaCase #-} module FormalLanguage.GrammarProduct.Op.Common where import qualified Data.Set as S-import Control.Lens+import Control.Lens hiding (outside)+import Data.Set (Set) import FormalLanguage.CFG.Grammar @@ -15,23 +15,49 @@ -- -- TODO i guess, this collects multidim stuff for now!!! -collectTerminals :: S.Set Rule -> S.Set Symb-collectTerminals = S.fromList . filter isSymbT . concatMap _rhs . S.toList+collectTerminals :: S.Set Rule -> S.Set Symbol+collectTerminals = error "collectTerminals" -- S.fromList . filter isSymbT . concatMap _rhs . S.toList -- | Collect all non-terminal symbols from a set of rules. -- -- TODO move to FormalGrammars library -collectNonTerminals :: S.Set Rule -> S.Set Symb-collectNonTerminals = S.fromList . filter isSymbN . concatMap (\r -> r^.lhs : r^.rhs) . S.toList+collectNonTerminals :: Set Rule -> Set Symbol -- S.Set Rule -> S.Set Symb+collectNonTerminals = error "collectNonTerminals" -- S.fromList . _ . view (folded.rhs) -- S.fromList . filter isSymbN . concatMap (\r -> r^.lhs : r^.rhs) . S.toList -collectEpsilons :: S.Set Rule -> S.Set TN+-- |+--+-- TODO not needed anymore ?!++collectEpsilons :: S.Set Rule -> S.Set SynTermEps -- TN+collectEpsilons = error "collectEpsilons"+{- collectEpsilons = S.fromList . filter (\case E -> True ; z -> False) . concatMap (view symb) . concatMap _rhs . S.toList+-} -genEps :: Symb -> [TN]-genEps s = replicate (length $ s^.symb) E+-- | Generate a multidim epsilon symbol of the same length as the given+-- symbol.++genEps :: Symbol -> Symbol -- Symb -> [TN]+genEps s = Symbol $ replicate (length $ s^.getSymbolList) Epsilon -- replicate (length $ s^.symb) E++-- | Generate a multidim @Deletion@ symbol of the same length as the given+-- symbol.++genDel :: Symbol -> Symbol -- Symb -> [TN]+genDel s = Symbol $ replicate (length $ s^.getSymbolList) Deletion -- replicate (length $ s^.symb) E++-- | Checks if two grammars are compatible.+--+-- TODO different inside/outside status might not be a big problem!++opCompatible :: Grammar -> Grammar -> Either String ()+opCompatible l r+ | dim l /= dim r = Left "Grammars have different dimensions"+ | l^.outside /= r^.outside = Left "Grammars have incompatible inside/outside status"+ | otherwise = Right ()
FormalLanguage/GrammarProduct/Op/Greibach.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ParallelListComp #-} module FormalLanguage.GrammarProduct.Op.Greibach where @@ -28,6 +27,8 @@ +{-+ -- * Proof of associativity of the 2-GNF. -- | Wrap a grammar in 2-GNF form.@@ -131,5 +132,7 @@ | length lls > length rrs = undefined epsR ls = map (\(Symb s) -> Symb $ s ++ replicate dr (T "")) ls epsL rs = map (\(Symb s) -> Symb $ replicate dl (T "") ++ s) rs+-}+ -}
FormalLanguage/GrammarProduct/Op/Greibach/Proof.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE ParallelListComp #-} module FormalLanguage.GrammarProduct.Op.Greibach.Proof where @@ -33,6 +31,8 @@ +{-+ -- * Proof of associativity of the 2-GNF. -- | Run the 2-gnf grammar with the TwoGNF monoid which observes the 2 star@@ -158,4 +158,6 @@ , "A -> one <<< c" , "//" ]++-}
FormalLanguage/GrammarProduct/Op/Linear.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleInstances #-} -- | Direct product of two grammars. --@@ -8,12 +7,15 @@ module FormalLanguage.GrammarProduct.Op.Linear where +import Control.Arrow ((&&&)) import Data.Semigroup-import Control.Lens+import Control.Lens hiding (outside) import Control.Applicative import qualified Data.Set as S-import Data.List (groupBy)+import Data.List (groupBy,nub) import Data.Function (on)+import Data.Default+import qualified Data.Map as M import FormalLanguage.CFG.Grammar @@ -21,27 +23,38 @@ +directProduct l r = runLinear $ Linear l <> Linear r+ newtype Linear a = Linear {runLinear :: a} instance Semigroup (Linear Grammar) where- (Linear g) <> (Linear h) = Linear $ Grammar ts ns es rs s (g^.name <> h^.name) where+ (Linear g) <> (Linear h) = Linear $ Grammar sv st tv io rs s p (g^.grammarName ++ h^.grammarName) False where -- ts ns es rs s (g^.name <> h^.name) where+ sv = M.fromList . nub . map (_name &&& id) . concatMap _getSymbolList . uniqueSyntacticSymbols $ set rules rs def -- build a temporary @def@ grammar, extract symbols from that one+ st = g^.synterms <> h^.synterms+ tv = g^.termvars <> h^.termvars+ io = g^.outside+ rs = S.fromList [ direct l r | l <- g^..rules.folded, r <- h^..rules.folded ]+ s = (g^.start) <> (h^.start)+ p = (g^.params) <> (h^.params)+ direct l r = Rule (l^.lhs <> r^.lhs) (l^.attr <> r^.attr) (mergeRHS (l^.rhs) (r^.rhs))+ {- ts = g^.tsyms <> h^.tsyms ns = collectNonTerminals rs- es = g^.epsis <> h^.epsis rs = S.fromList [ direct l r | l <- g^..rules.folded, r <- h^..rules.folded ]- s = liftA2 (\l r -> Symb $ l^.symb ++ r^.symb) (g^.start) (h^.start)- direct (Rule l f rs) (Rule a g bs) = Rule (Symb $ l^.symb ++ a^.symb) (f++g) (mergeRHS rs bs)+ s = liftA2 (<>) (g^.start) (h^.start)+ direct (Rule l f rs) (Rule a g bs) = Rule (l <> a) (f++g) (mergeRHS rs bs)+ -} instance Monoid (Linear Grammar) where- mempty = Linear $ Grammar S.empty S.empty S.empty (S.singleton $ Rule (Symb []) [] []) Nothing ""+ mempty = Linear $ set rules (S.singleton $ Rule (Symbol []) [] []) def mappend = (<>) -- | Merges right-hand sides in a linear direct product. For full-fledged CFGs -- in different normal forms, see the GNF and CNF implementations. -mergeRHS :: [Symb] -> [Symb] -> [Symb]+mergeRHS :: [Symbol] -> [Symbol] -> [Symbol] mergeRHS [] rs = rs -- neutral element mergeRHS ls [] = ls -- neutral element mergeRHS ls' rs' = concat $ go (groupRHS ls') (groupRHS rs') where@@ -49,25 +62,26 @@ dr = head rs' go [] [] = [] go [] (r:rs)- | all isSymbT r = map (\(Symb z) -> Symb $ genEps dl ++ z) r : go [] rs- | all isSymbN r = let [Symb z] = r- in [Symb $ genEps dl ++ z] : go [] rs+ | all isTerminal r = map (genDel dl <>) r : go [] rs+ | all isSyntactic r = let [z] = r+ in [genDel dl <> z] : go [] rs go (l:ls) []- | all isSymbT l = map (\(Symb z) -> Symb $ z ++ genEps dr) l : go ls []- | all isSymbN l = let [Symb z] = l- in [Symb $ z ++ genEps dr] : go ls []+ | all isTerminal l = map (<> genDel dr) l : go ls []+ | all isSyntactic l = let [z] = l+ in [z <> genDel dr] : go ls [] go (l:ls) (r:rs)- | all isSymbT l && all isSymbT r = goT l r : go ls rs- | all isSymbN l && all isSymbN r = let [Symb y] = l- [Symb z] = r- in [Symb $ y++z] : go ls rs- | all isSymbN l = go [l] [] ++ go ls (r:rs)- | all isSymbN r = go [] [r] ++ go (l:ls) rs+ | all isTerminal l && all isTerminal r = goT l r : go ls rs+ | all isSyntactic l && all isSyntactic r = let [Symbol y] = l+ [Symbol z] = r+ in [Symbol $ y++z] : go ls rs+ | all isSyntactic l = go [l] [] ++ go ls (r:rs)+ | all isSyntactic r = go [] [r] ++ go (l:ls) rs | otherwise = go [l] [] ++ go [] [r] ++ go ls rs- goT [] [] = []- goT [] (Symb t : rs) = Symb (genEps dl ++ t) : goT [] rs- goT (Symb t : ls) [] = Symb (t ++ genEps dr) : goT ls []- goT (Symb u : ls) (Symb v : rs) = Symb (u++v) : goT ls rs+ go ls rs = error $ "unhandled (Lib-FormalLanguage, FormalLanguage.GrammarProduct.Op.Linear): " ++ show (ls,rs)+ goT [] [] = []+ goT [] (t : rs) = (genDel dl <> t) : goT [] rs+ goT (t : ls) [] = (t <> genDel dr) : goT ls []+ goT (u : ls) (v : rs) = (u<>v) : goT ls rs -groupRHS = groupBy ((==) `on` isSymbT)+groupRHS = groupBy ((==) `on` isTerminal)
FormalLanguage/GrammarProduct/Op/Power.hs view
@@ -1,10 +1,11 @@ module FormalLanguage.GrammarProduct.Op.Power where -import Control.Newtype+--import Control.Newtype import Data.Semigroup import Control.Lens import Control.Lens.Fold+import Data.Set.Lens import qualified Data.Set as S import Data.List (genericReplicate) import Text.Printf@@ -16,6 +17,19 @@ -- | power :: Grammar -> Integer -> Grammar+power g k+ | k < 1 = error $ "Op.Power.power: power " ++ show k ++ " < 1"+ | otherwise = over (rules . setmapped . attr) kAttr+ . over (rules . setmapped . rhs . traverse) kDim+ . over (rules . setmapped . lhs) kDim+ . over start kDim+ $ g+ where kDim :: Symbol -> Symbol+ kDim = Symbol . concat . genericReplicate k . _getSymbolList+ kAttr :: [AttributeFunction] -> [AttributeFunction]+ kAttr = concat . genericReplicate k++{- power g k = Grammar ts ns es rs s nm where ts = g^.tsyms ns = S.map go $ g^.nsyms@@ -24,4 +38,5 @@ s = fmap go $ g^.start nm = concat . genericReplicate k $ g^.name go (Symb z) = Symb . concat $ genericReplicate k z+-}
FormalLanguage/GrammarProduct/Op/Subtract.hs view
@@ -1,18 +1,19 @@-{-# LANGUAGE FlexibleInstances #-} module FormalLanguage.GrammarProduct.Op.Subtract where -import Control.Newtype-import Data.Semigroup-import Control.Lens-import Control.Lens.Fold+import Control.Arrow ((&&&))+import Control.Lens.Fold+import Control.Lens hiding (outside)+import Control.Newtype+import Data.List (genericReplicate)+import Data.Semigroup+import qualified Data.Map as M import qualified Data.Set as S-import Data.List (genericReplicate)-import Text.Printf+import Text.Printf -import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.Grammar -import FormalLanguage.GrammarProduct.Op.Common+import FormalLanguage.GrammarProduct.Op.Common @@ -20,7 +21,20 @@ subtract :: Grammar -> Grammar -> Grammar subtract l r- | gDim l /= gDim r = error $ printf "grammars %s and %s have different dimensions, cannot unify. (subtract)" (show l) (show r)+ | dim l /= dim r = error $ printf "grammars %s and %s have different dimensions, cannot unify. (subtract)" (show l) (show r)+ | l^.outside /= r^.outside = error $ printf "grammars %s and %s have different inside/outside annotation." (show l) (show r)+ | otherwise = g+ where sv = M.fromList . map ((_name &&& id) . fst) . uniqueSynVarsWithTape $ g+ st = M.fromList . map ((_name &&& id) . fst) . uniqueSynTermsWithTape $ g+ tv = M.fromList . map ((_name &&& id) . fst) . uniqueBindableTermsWithTape $ g+ io = l^.outside+ rs = (l^.rules) S.\\ (r^.rules)+ s = if (anyOf (folded . lhs) ((l^.start) ==) rs) then l^.start else Symbol []+ p = M.union (l^.params) (r^.params)+ g = Grammar sv st tv io rs s p (l^.grammarName ++ r^.grammarName) False++{-+subtract l r | otherwise = Grammar ts ns es rs s (l^.name ++ r^.name) where ts = collectTerminals rs ns = collectNonTerminals rs@@ -31,4 +45,5 @@ Just s' -> if anyOf (rules.folded.lhs) (==s') l then l^.start else Nothing+-}
FormalLanguage/GrammarProduct/Parser.hs view
@@ -1,13 +1,8 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-} -- | This parser extends the @FormalLanguage.Parser@ parser of single- and -- multi-dim grammars to accept grammar product definitions as well.+--+-- TODO display function names like this: <fun,fun,fun> module FormalLanguage.GrammarProduct.Parser where @@ -40,39 +35,91 @@ --import Numeric.Natural.Internal import Prelude hiding (subtract) import Control.Monad+import Data.Char (isUpper)+import Data.Data.Lens+import System.IO.Unsafe (unsafePerformIO) import FormalLanguage.CFG.Grammar import FormalLanguage.CFG.Parser+import FormalLanguage.CFG.PrettyPrint.ANSI -import FormalLanguage.GrammarProduct+import FormalLanguage.GrammarProduct.Op --- | Parse a product grammar.+-- TODO can remove, done via better FormalGrammars -parseProduct :: String -> String -> Result [Grammar]-parseProduct fname cnts = parseString- ((evalStateT . runGrammarP) productParser def)- (Directed (B.pack fname) 0 0 0 0)- cnts+-- -- | Parse a product grammar.+-- +-- parseProduct :: String -> String -> Result [Grammar]+-- parseProduct fname cnts = parseString+-- ((evalStateT . runGrammarP) productParser def)+-- (Directed (B.pack fname) 0 0 0 0)+-- cnts+-- +-- -- | Parse all grammars and grammar products, prepending to the list.+-- +-- productParser = go [] <* eof where+-- go gs = do+-- whiteSpace+-- g' <- option Nothing $ Just <$> (try grammar <|> grammarProduct gs)+-- case g' of+-- Nothing -> return gs+-- Just g -> go (g:gs) --- | Parse all grammars and grammar products, prepending to the list.+-- | The top-level parser for a grammar product. It can be used as one of the+-- additional parser arguments, the formal grammars parser accepts. -productParser = go [] <* eof where- go gs = do- whiteSpace- g' <- option Nothing $ Just <$> (try grammar <|> grammarProduct gs)- case g' of- Nothing -> return gs- Just g -> go (g:gs)+parseGrammarProduct :: Parse m ()+parseGrammarProduct = do+ reserve fgIdents "Product:"+ n <- newGrammarName+ current <~ parseProductString+ current.grammarName .= n -- need to set here, otherwise the underlying combinator produces a combined name (funny but useless ;-)+ reserve fgIdents "//"+ v <- use verbose+ g <- use current+ seq (unsafePerformIO $ if v then (printDoc $ genGrammarDoc g) else return ())+ $ env %= M.insert n g +{- grammarProduct gs = do reserveGI "Product:" n <- identGI+ r <- option Nothing $ Just <$> braces renameSymbols e <- getGrammar <$> expr (M.fromList [(g^.name,g) | g<-gs]) reserveGI "//"- return $ over (name) (const n) e+ return $ over (name) (const n) $ transformRenamed r e+-} +-- | Performs the actual parsing of a product string. Uses an expression parser+-- internally.++parseProductString :: Parse m Grammar+parseProductString = getGrammar <$> expr+ where expr :: Parse m ExprGrammar+ expr = buildExpressionParser table term+ table = [ [ binary "><" exprDirect AssocLeft+ , binary "*" exprPower AssocLeft+ ]+ , [ binary "+" exprPlus AssocLeft+ , binary "-" exprMinus AssocLeft+ ]+ ]+ term = parens expr+ <|> (ExprGrammar <$> knownGrammarName <?> "grammar not available in environment")+ <|> (ExprNumber <$> natural <?> "integral power of grammar")+ binary n f a = Infix (f <$ reserve fgIdents n) a+ exprDirect l r = ExprGrammar (getGrammar l >< getGrammar r)+ exprPlus l r = ExprGrammar (getGrammar l `gAdd` getGrammar r)+ exprMinus l r = ExprGrammar (getGrammar l `gSubtract` getGrammar r)+ exprPower l r = ExprGrammar (getGrammar l `gPower` getNumber r)++data ExprGrammar+ = ExprGrammar { getGrammar :: Grammar }+ | ExprNumber { getNumber :: Integer }++{- expr :: Map String Grammar -> Parse ExprGrammar expr g = e where e = buildExpressionParser table term@@ -96,12 +143,63 @@ exprPower l r = ExprGrammar $ gPower (getGrammar l) (getNumber r) highDirect l r = error "highDirect (not active)!" -- ExprGrammar . unDirect $ times1p (Natural $ getNumber r -1) (Direct $ getGrammar l) -data ExprGrammar- = ExprGrammar { getGrammar :: Grammar }- | ExprNumber { getNumber :: Integer }- gterm :: (String,Grammar) -> Parse Grammar gterm (s,g) = g <$ reserveGI s+-}++{-+transformRenamed Nothing e = e+transformRenamed (Just r) e = go r e where+ go [] e = e+ go (RTN f t:rs) e = go rs (e & tinplate %~ repTN f t)+ go (RSymb f t:rs) e = go rs (e & tinplate %~ repSymb f t)+ go (RFun f t:rs) e = go rs (e & tinplate %~ repFun f t)+ go (RStart s :rs) e = go rs (repStart s e)+ repTN :: String -> String -> TN -> TN+ repTN f t r | r^.tnName == f = set tnName t r+ repTN _ _ r = r+ repSymb :: [String] -> [String] -> Symb -> Symb+ repSymb f t r | r^..symb.folded.tnName == f = Symb . map fixTN . zipWith (set tnName) t $ getSymbs r+ repSymb _ _ r = r+ fixTN r | r^.tnName == "ε" = E+ fixTN r = r+ repFun f t r | r^.fun == f = set fun t r+ repFun _ _ r = r+ repStart [] e = set start Nothing e+ repStart s e = set start (Just . Symb . map (\z -> N z Singular) $ s) e++data Rename+ = RTN String String -- one-dim term / non-term+ | RSymb [String] [String] -- multi-dim symbol+ | RFun [String] [String] -- replace function names+ | RStart [String] -- set or delete a start symbol++renameSymbols = (try rtn <|> rsymb <|> rfun <|> rstart) `sepBy` (symbol ",") where+ rtn = RTN <$> identGI <* string "->" <*> identGI+ rsymb = RSymb <$> (brackets $ identGI `sepBy` comma) <* string "->" <*> (brackets $ identGI `sepBy` comma)+ rfun = RFun <$> (angles $ identGI `sepBy` comma) <* string "->" <*> (angles $ identGI `sepBy` comma)+ rstart = RStart <$ string "S:" <*> (brackets $ identGI `sepBy` comma)++-}+++++++++++++++++++ {- data GS = GS
+ FormalLanguage/GrammarProduct/QQ.hs view
@@ -0,0 +1,52 @@++module FormalLanguage.GrammarProduct.QQ where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Trifecta.Delta (Delta (Directed))+import Text.Trifecta (parseString)+import Text.Trifecta.Result (Result (..))+import Control.Monad.Trans.State.Strict (evalStateT)+import Data.Default (def)+import Data.ByteString.Char8 (pack)+import Control.Lens++import FormalLanguage.CFG.QQ (trim, parseFormalLanguage)+import FormalLanguage.CFG.PrettyPrint.ANSI+import FormalLanguage.CFG.Parser+import FormalLanguage.CFG.TH+import FormalLanguage.CFG.Grammar++import FormalLanguage.GrammarProduct.Parser (parseGrammarProduct)++++grammarProductF = quoteFile grammarProduct++grammarProduct = QuasiQuoter+ { quoteDec = parseFormalLanguage parseGrammarProduct+ , quoteExp = err+ , quotePat = err+ , quoteType = err+ } where err = error "there is only a Dec quoter"++{-+parseGrammarProduct :: String -> Q [Dec]+parseGrammarProduct s = do+ loc <- location+ let (lpos,cpos) = loc_start loc+ let r = parseString+ ((evalStateT . runGrammarP) P.productParser def)+ (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0)+ $ trim s+ case r of+ (Failure f) -> do+ runIO . printDoc $ f+ fail "aborting parseGrammarProduct"+ (Success g') -> do+ let g = reverse g'+ runIO . mapM_ (printDoc . grammarDoc) $ g+ zs <- thCodeGen $ last g+ return zs+-}+
− GramProd.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | The @GramProd@ executable reads a grammatical description (from stdin or a--- file) and produces a set of grammars, each written into a separate file.------ It is possible to both, produce @LaTeX@ and @Haskell@ output. The Haskell--- grammars require "ADPfusion" to be useful -- and you have to provide--- algebras that actually evaluate parses.--module Main where--import Control.Lens-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.State.Strict-import Data.Default-import Data.Semigroup-import qualified Text.LaTeX.Base.Render as Latex-import System.Console.CmdArgs hiding (def)-import System.IO-import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>))-import Text.Printf-import Text.Trifecta-import Text.Trifecta.Delta--import FormalLanguage.CFG.Grammar-import FormalLanguage.CFG.PrettyPrint.ANSI-import FormalLanguage.CFG.PrettyPrint.LaTeX-import FormalLanguage.CFG.PrettyPrint.Haskell-import FormalLanguage.GrammarProduct.Parser----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,optionHaskell]- pr <- case (inFile o) of- "" -> getContents >>= return . parseProduct "stdin"- fn -> readFile fn >>= return . parseProduct fn- case pr of- Failure f -> putStrLn "failed:" >> printDoc f- Success [] -> error "you did provide input?!"- Success (s:ss) -> case o of- LaTeX{..} -> case outFile of- "" -> error "need to set output file name"- fn -> renderFile fn $ renderLaTeX 2 s- Ansi {..} -> printDoc $ grammarDoc s- Haskell{..} -> case outFile of- "" -> printDoc $ grammarHaskell s- fn -> do h <- openFile fn WriteMode- hPutDoc h $ grammarHaskell s- hClose h----{--main :: IO ()-main = do- o <- cmdArgs $ modes [optionLatex, optionHaskell]- let g = runGrammarLang $ flip evalStateT def $ parseDesc- r <- case infile o of- "" -> getContents >>= return . parseString g (Directed "stdin" 0 0 0 0)- fn -> parseFromFileEx g fn- case r of- Failure e -> liftIO $ displayIO stdout $ renderPretty 0.8 80 $ e <> linebreak- Success (gs,ps) -> case o of- Latex{..} -> do- let latex g = Latex.renderFile (printf "%s/%s.tex" outdir (g^.gname)) . renderGrammarLaTeX columns $ g- when withatoms $ mapM_ latex gs- mapM_ latex ps- Haskell{..} -> do- let s = renderGrammarHaskell (if withatoms then gs else [] ++ ps)- -- writeFile (printf "%s/%s.hs" outdir (g^.gname)) s- putStrLn s--data Options- = Latex- { infile :: String- , outdir :: String- , withatoms :: Bool- , columns :: Int- }- | Haskell- { infile :: String--- , outdir :: String- , withatoms :: Bool- }- deriving (Show,Data,Typeable)--optionLatex = Latex- { infile = "" &= help "grammar file to read (stdin if not given)"- , outdir = "." &= help "directory to put grammars in (./ if not given)"- , withatoms = False &= help "if set, source grammars (atoms) are written to target, too"- , columns = 1 &= help "align grammar to 1 or 2 columns?"- }--optionHaskell = Haskell- {- }--}-
GrammarProducts.cabal view
@@ -1,17 +1,17 @@ name: GrammarProducts-version: 0.0.0.4-author: Christian Hoener zu Siederdissen, 2013-copyright: Christian Hoener zu Siederdissen, Ivo L. Hofacker, Peter F. Stadler, 2013-homepage: http://www.tbi.univie.ac.at/~choener/gramprod-maintainer: choener@tbi.univie.ac.at+version: 0.1.0.0+author: Christian Hoener zu Siederdissen, 2013-2015+copyright: Christian Hoener zu Siederdissen, 2013-2015+homepage: http://www.bioinf.uni-leipzig.de/gADP/+maintainer: choener@bioinf.uni-leipzig.de category: Formal Languages, Bioinformatics license: GPL-3 license-file: LICENSE build-type: Simple stability: experimental-cabal-version: >= 1.6.0-synopsis:- Grammar products and higher-dimensional grammars+cabal-version: >= 1.10.0+tested-with: GHC == 7.8.4, GHC == 7.10.1+synopsis: Grammar products and higher-dimensional grammars description: An algebra of liner and context-free grammars. .@@ -26,7 +26,10 @@ . An efficient implementation of the resulting grammars is possible via the ADPfusion framework. The @FormalGrammars@- library provides the required "Template Haskell" machinary.+ library provides the required "Template Haskell" machinery.+ GramarProducts can be integrated as a plugin into the existing+ transformation from DSL to ADPfusion. Haskell users can just+ use the QQ function provided in the .QQ module. . Alternatively, the resulting grammars can also be pretty-printed in various ways (LaTeX, ANSI, Haskell module@@ -37,9 +40,10 @@ Formal background can be found in two papers: . @- Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler- Product Grammars for Alignment and Folding- submitted+ Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler.+ Product Grammars for Alignment and Folding.+ 2014. IEEE/ACM Transactions on Computational Biology and Bioinformatics. 99.+ <http://ieeexplore.ieee.org/xpl/articleDetails.jsp?arnumber=6819790> @ . and@@ -50,31 +54,45 @@ Brazilian Symposium on Bioinformatics (BSB 2013) Lecture Notes in Bioinformatics 8213, Springer, Heidelberg @+ . Extra-Source-Files:- changelog+ changelog.md+ README.md +++flag examples+ description: build the examples (only Needleman-Wunsch for now)+ default: False+ manual: True++flag llvm+ description: build using LLVM+ default: False+ manual: True+++ library- build-depends:- base >= 4 && < 5 ,- ADPfusion >= 0.2.0 ,- ansi-wl-pprint ,- bytestring ,- containers ,- data-default ,- FormalGrammars >= 0.0.0.2 ,- HaTeX ,- lens ,- newtype ,- parsers ,- PrimitiveArray >= 0.5.1.0 ,- semigroups ,- transformers ,- trifecta+ build-depends: base >= 4.7 && < 4.9+ , ansi-wl-pprint >= 0.6 && < 0.7+ , bytestring >= 0.10 && < 0.11+ , containers >= 0.5 && < 0.6+ , data-default >= 0.5 && < 0.6+ , FormalGrammars == 0.2.0.*+ , lens >= 4 && < 5+ , newtype >= 0.2 && < 0.3+ , parsers >= 0.12 && < 0.13+ , semigroups >= 0.15 && < 0.17+ , template-haskell >= 2 && < 3+ , transformers >= 0.4 && < 0.5+ , trifecta >= 1.5 && < 1.6 exposed-modules: FormalLanguage.GrammarProduct+ FormalLanguage.GrammarProduct.Op FormalLanguage.GrammarProduct.Op.Add FormalLanguage.GrammarProduct.Op.Chomsky FormalLanguage.GrammarProduct.Op.Chomsky.Proof@@ -85,26 +103,93 @@ FormalLanguage.GrammarProduct.Op.Power FormalLanguage.GrammarProduct.Op.Subtract FormalLanguage.GrammarProduct.Parser--- BioInf.GrammarProducts--- BioInf.GrammarProducts.Grammar--- BioInf.GrammarProducts.Haskell--- BioInf.GrammarProducts.Helper--- BioInf.GrammarProducts.LaTeX--- BioInf.GrammarProducts.Tools--- BioInf.GrammarProducts.TH+ FormalLanguage.GrammarProduct.QQ+ default-language:+ Haskell2010+ default-extensions: FlexibleContexts+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , NoMonomorphismRestriction+ , OverloadedStrings+ , ParallelListComp+ , PatternGuards+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TemplateHaskell+ , UnicodeSyntax ghc-options: -O2+ -funbox-strict-fields ++ -- With grammar products, we need a refined way of turning input source files -- into LaTeX and Haskell modules. -executable GrammarProductPP- build-depends:- cmdargs == 0.10.*+--executable GrammarProductPP+-- build-depends: base >= 4.7 && < 4.9+-- , ansi-wl-pprint+-- , cmdargs >= 0.10 && < 0.11+-- , data-default+-- , FormalGrammars+-- , GrammarProducts+-- , HaTeX >= 3.16 && < 4+-- , lens+-- , semigroups+-- , transformers+-- , trifecta+-- hs-source-dirs:+-- src+-- main-is:+-- GramProd.hs+-- default-language:+-- Haskell2010+-- default-extensions:+-- ghc-options:+-- -O2++executable AlignGlobal+ if flag(examples)+ build-depends: base >= 4.7 && < 4.9+ , ADPfusion == 0.4.0.*+ , containers+ , FormalGrammars+ , GrammarProducts+ , PrimitiveArray == 0.6.0.*+ , template-haskell+ , vector == 0.10.*+ buildable: True+ else+ buildable: False+ hs-source-dirs:+ src main-is:- GramProd.hs+ AlignGlobal.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(llvm)+ ghc-options:+ -fllvm+ -optlo-O3+ -fllvm-tbaa++ source-repository head type: git
+ README.md view
@@ -0,0 +1,17 @@+Grammar Products+================++[](https://travis-ci.org/choener/GrammarProducts)++[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)++An algebra of liner and context-free grammars.++++#### Contact++Christian Hoener zu Siederdissen+choener@bioinf.uni-leipzig.de+Leipzig University, Leipzig, Germany+
− changelog
@@ -1,9 +0,0 @@-0.0.0.4----------Version bump for new TH stuff--0.0.0.3----------Products of linear and context-free grammars
+ changelog.md view
@@ -0,0 +1,29 @@+0.1.0.0+-------++- major version bump+- updated dependencies+- using ADPfusion 0.4.0.0 now+- rewritten as 'plugin' of FormalGrammars+- QQ here combines FormalGrammars + GrammarProducts+- travis-ci integration++0.0.1.0+-------++- fixed dependencies++0.0.0.5+-------++- the parser now comes with a very ad-hoc TN and Symb renaming system for products++0.0.0.4+-------++- Version bump for new TH stuff++0.0.0.3+-------++- Products of linear and context-free grammars
+ src/AlignGlobal.hs view
@@ -0,0 +1,110 @@++-- | 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 Data.Vector.Unboxed (Vector)+import Text.Printf+import Data.Sequence ((|>),Seq,empty)+import qualified Data.Vector.Fusion.Stream as S+import Data.Foldable (toList)++import ADP.Fusion+import Data.PrimitiveArray as PA hiding (map,toList)+import FormalLanguage.CFG++import FormalLanguage.GrammarProduct++++[grammarProduct|+Grammar: Step+N: X+T: c+S: X+X -> stp <<< X c+X -> del <<< X+//+Grammar: Stand+N: X+S: X+X -> del <<< X+//+Grammar: Done+N: X+S: X+X -> don <<< e+//+Product: Global+Step >< Step - Stand * 2 + Done * 2+//+Emit: Global+|]++makeAlgebraProduct ''SigGlobal++++score :: Monad m => SigGlobal m Int Int Char+score = SigGlobal+ { donDon = \ (Z:.():.()) -> 0+ , stpStp = \ x (Z:.a :.b ) -> if a==b then x+1 else -999999+ , delStp = \ x (Z:.():.b ) -> x - 2+ , stpDel = \ x (Z:.a :.()) -> x - 2+ , h = SM.foldl' max (-999999)+ }+{-# INLINE score #-}++-- |+--+-- TODO use fmlist to make this more efficient.++pretty :: Monad m => SigGlobal m (String,String) [(String,String)] Char+pretty = SigGlobal+ { donDon = \ (Z:.():.()) -> ("","")+ , stpStp = \ (x,y) (Z:.a :.b ) -> (x ++ [a],y ++ [b])+ , delStp = \ (x,y) (Z:.():.b ) -> (x ++ "-",y ++ [b])+ , stpDel = \ (x,y) (Z:.a :.()) -> (x ++ [a],y ++ "-")+ , h = SM.toList+ }++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:.(ITbl Id Unboxed (Z:.PointL:.PointL) 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+