diff --git a/FormalLanguage/GrammarProduct/Op/Add.hs b/FormalLanguage/GrammarProduct/Op/Add.hs --- a/FormalLanguage/GrammarProduct/Op/Add.hs +++ b/FormalLanguage/GrammarProduct/Op/Add.hs @@ -3,7 +3,7 @@ import Control.Lens hiding (outside,indices) import Control.Lens.Fold -import Control.Newtype +import "newtype" Control.Newtype import Data.List (genericReplicate) import Data.Monoid hiding ((<>)) import Data.Semigroup diff --git a/FormalLanguage/GrammarProduct/Op/Chomsky.hs b/FormalLanguage/GrammarProduct/Op/Chomsky.hs --- a/FormalLanguage/GrammarProduct/Op/Chomsky.hs +++ b/FormalLanguage/GrammarProduct/Op/Chomsky.hs @@ -4,7 +4,7 @@ import Control.Applicative import Control.Lens import Control.Lens.Fold -import Control.Newtype () +import "newtype" Control.Newtype () import Data.Function (on) import Data.List (genericReplicate,replicate,groupBy) import Data.Maybe diff --git a/FormalLanguage/GrammarProduct/Op/Chomsky/Proof.hs b/FormalLanguage/GrammarProduct/Op/Chomsky/Proof.hs deleted file mode 100644 --- a/FormalLanguage/GrammarProduct/Op/Chomsky/Proof.hs +++ /dev/null @@ -1,80 +0,0 @@ - -module FormalLanguage.GrammarProduct.Op.Chomsky.Proof where - -import Control.Lens -import Control.Lens.Fold -import Control.Newtype () -import Data.List (genericReplicate) -import Data.Monoid hiding ((<>)) -import Data.Semigroup -import qualified Data.Set as S -import Text.Printf -import Data.List (groupBy) -import Data.Function (on) -import Data.Maybe -import Control.Applicative - -import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) -import Text.Trifecta -- -import qualified Data.ByteString.Char8 as B -import Control.Monad.Trans.State.Strict -import Data.Default -import Text.Trifecta.Delta - -import FormalLanguage.CFG.Grammar -import FormalLanguage.CFG.PrettyPrint.ANSI -import FormalLanguage.CFG.PrettyPrint.LaTeX -import FormalLanguage.CFG.Parser - -import FormalLanguage.GrammarProduct.Op.Chomsky - - - -{- - --- * Proof of associativity of the 2-GNF. - --- | Run the 2-gnf grammar with the TwoGNF monoid which observes the 2 star --- cases. - -cNFassociativity :: (Grammar, Grammar, S.Set Rule, S.Set Rule, Bool) -cNFassociativity = ( l - , r - , (l^.rules) S.\\ (r^.rules) - , (r^.rules) S.\\ (l^.rules) - , l^.rules == r^.rules) where - l = runCNF $ (CNF g <> CNF g) <> CNF g - r = runCNF $ CNF g <> (CNF g <> CNF g) - g = cNFgrammar - -cNFs = g where - g = runCNF $ (CNF h <> CNF h) - h = cNFgrammar - -showTwo = printDoc $ grammarDoc $ runCNF $ CNF cNFgrammar <> CNF cNFgrammar - --- * The simple 2-gnf grammar to run the proof on. - --- | Very simple 2-gnf form for proofs. - -cNFgrammar = case g of - Success g' -> g' - Failure f -> error $ show f - where - g = parseGrammar "testGrammar" twoGNF - twoGNF = unlines - [ "Grammar: CNF" - , "N: A" - , "N: B" - , "N: C" --- , "N: Sa" - , "T: a" - , "A -> twoN <<< B C" - , "A -> oneT <<< a" --- , "A -> oneN <<< Sa" --- , "Sa -> oneT <<< a" - , "//" - ] - --} - diff --git a/FormalLanguage/GrammarProduct/Op/Common.hs b/FormalLanguage/GrammarProduct/Op/Common.hs --- a/FormalLanguage/GrammarProduct/Op/Common.hs +++ b/FormalLanguage/GrammarProduct/Op/Common.hs @@ -6,6 +6,7 @@ import Data.Set (Set) import FormalLanguage.CFG.Grammar +import ADP.Fusion.Core.Term.Epsilon (LocalGlobal(..)) @@ -43,7 +44,7 @@ -- symbol. genEps :: Symbol -> Symbol -- Symb -> [TN] -genEps s = Symbol $ replicate (length $ s^.getSymbolList) Epsilon -- replicate (length $ s^.symb) E +genEps s = Symbol $ replicate (length $ s^.getSymbolList) $ Epsilon Global -- replicate (length $ s^.symb) E -- | Generate a multidim @Deletion@ symbol of the same length as the given -- symbol. diff --git a/FormalLanguage/GrammarProduct/Op/Greibach.hs b/FormalLanguage/GrammarProduct/Op/Greibach.hs --- a/FormalLanguage/GrammarProduct/Op/Greibach.hs +++ b/FormalLanguage/GrammarProduct/Op/Greibach.hs @@ -4,7 +4,7 @@ import Control.Applicative import Control.Lens import Control.Lens.Fold -import Control.Newtype () +import "newtype" Control.Newtype () import Data.Function (on) import Data.List (genericReplicate) import Data.List (groupBy) diff --git a/FormalLanguage/GrammarProduct/Op/Greibach/Proof.hs b/FormalLanguage/GrammarProduct/Op/Greibach/Proof.hs deleted file mode 100644 --- a/FormalLanguage/GrammarProduct/Op/Greibach/Proof.hs +++ /dev/null @@ -1,163 +0,0 @@ - -module FormalLanguage.GrammarProduct.Op.Greibach.Proof where - -import Control.Lens -import Control.Lens.Fold -import Control.Newtype () -import Data.List (genericReplicate) -import Data.Monoid hiding ((<>)) -import Data.Semigroup -import qualified Data.Set as S -import Text.Printf -import Data.List (groupBy) -import Data.Function (on) -import Data.Maybe -import Control.Applicative - -import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) -import Text.Trifecta -- -import qualified Data.ByteString.Char8 as B -import Control.Monad.Trans.State.Strict -import Data.Default -import Text.Trifecta.Delta - -import FormalLanguage.CFG.Grammar -import FormalLanguage.CFG.PrettyPrint.ANSI -import FormalLanguage.CFG.PrettyPrint.LaTeX -import FormalLanguage.CFG.Parser - -import FormalLanguage.GrammarProduct.Op.Greibach -import FormalLanguage.GrammarProduct.Op.Common - - - -{- - --- * Proof of associativity of the 2-GNF. - --- | Run the 2-gnf grammar with the TwoGNF monoid which observes the 2 star --- cases. - -twoGNFassociativity :: (Grammar, Grammar, S.Set Rule, S.Set Rule, Bool) -twoGNFassociativity = ( l - , r - , (l^.rules) S.\\ (r^.rules) - , (r^.rules) S.\\ (l^.rules) - , l^.rules == r^.rules) where - l = runTwoGNF $ (TwoGNF g <> TwoGNF g) <> TwoGNF g - r = runTwoGNF $ TwoGNF g <> (TwoGNF g <> TwoGNF g) - g = twoGNFgrammar - -twoGNFs = g where - g = runTwoGNF $ (TwoGNF h <> TwoGNF h) - h = twoGNFgrammar - -assocHelper l r = ( l - , r - , (l^.rules) S.\\ (r^.rules) - , (r^.rules) S.\\ (l^.rules) - , l^.rules == r^.rules) - --- * Proof that the 2 star cases are actually needed. We loose associativity --- without those. As this version does not preserve associativity, we keep it --- here, instead of the general Greibach version. - -newtype FailGNF = FailGNF { runFailGNF :: Grammar } - --- | --- --- TODO check correctness - -instance Semigroup FailGNF where - (FailGNF g) <> (FailGNF h) = FailGNF $ Grammar ts ns es rs s (g^.name ++ h^.name) where - ts = collectTerminals rs - ns = collectNonTerminals rs - es = g^.epsis <> h^.epsis - rs = S.fromList - . map starRemove - . concat - $ [ l <.> r - | l <- S.toList $ g^.rules - , r <- S.toList $ h^.rules - ] - s = liftA2 (\l r -> Symb $ l^.symb ++ r^.symb) (g^.start) (h^.start) - (<.>) :: Rule -> Rule -> [Rule] - a <.> b | ((Just $ a^.lhs)==g^.start) `exactlyOne` ((Just $ b^.lhs)==h^.start) = [] - a <.> b - | [s,m] <- a^.rhs - , [t,n,o] <- b^.rhs - = [ Rule (Symb $ a^.lhs.symb ++ b^.lhs.symb) - [""] - [Symb $ s^.symb ++ t^.symb, Symb $ m^.symb ++ n^.symb, Symb $ stars (length $ m^.symb) ^.symb ++ o^.symb ] - , Rule (Symb $ a^.lhs.symb ++ b^.lhs.symb) - [""] - [Symb $ s^.symb ++ t^.symb, Symb $ stars (length $ m^.symb) ^.symb ++ n^.symb, Symb $ m^.symb ++ o^.symb ] - ] - | [s,m,o] <- a^.rhs - , [t,n] <- b^.rhs - = [ Rule (Symb $ a^.lhs.symb ++ b^.lhs.symb) - [""] - [ Symb $ s^.symb ++ t^.symb - , Symb $ m^.symb ++ n^.symb - , Symb $ o^.symb ++ stars (length $ t^.symb) ^.symb - ] - , Rule (Symb $ a^.lhs.symb ++ b^.lhs.symb) - [""] - [ Symb $ s^.symb ++ t^.symb - , Symb $ m^.symb ++ stars (length $ t^.symb) ^.symb - , Symb $ o^.symb ++ n^.symb - ] - ] - a <.> b = [ Rule (Symb $ a^.lhs.symb ++ b^.lhs.symb) - [""] - (take 3 $ zipWith (\l r -> Symb $ l^.symb ++ r^.symb) (a^.rhs ++ repeat (stars (gDim g))) - (b^.rhs ++ repeat (stars (gDim h))) - ) - ] - exactlyOne False True = True - exactlyOne True False = True - exactlyOne _ _ = False - stars :: Int -> Symb - stars k = Symb $ replicate k E - -- | Remove star-online columns. - starRemove :: Rule -> Rule - starRemove = over rhs (filter (any (not . isEpsilon) . getSymbs)) - isEpsilon E = True - isEpsilon _ = False - - --- | Run the 2-gnf grammar without the star cases. - --- noStarFailure :: (S.Set Rule, S.Set Rule, -noStarFailure = assocHelper l r where - l = runFailGNF $ (FailGNF g <> FailGNF g) <> FailGNF g - r = runFailGNF $ FailGNF g <> (FailGNF g <> FailGNF g) - g = twoGNFgrammar - --- * The simple 2-gnf grammar to run the proof on. - --- | Very simple 2-gnf form for proofs. - -twoGNFgrammar = case g of - Success g' -> g' - Failure f -> error $ show f - where - g = parseGrammar "testGrammar" twoGNF - twoGNF = unlines - [ "Grammar: TwoGNF" - , "N: A" - , "N: B" - , "N: C" - , "N: D" - , "T: a" - , "T: b" - , "T: c" --- , "S: X" - , "A -> three <<< a B C" - , "A -> two <<< b D" - , "A -> one <<< c" - , "//" - ] - --} - diff --git a/FormalLanguage/GrammarProduct/Op/Subtract.hs b/FormalLanguage/GrammarProduct/Op/Subtract.hs --- a/FormalLanguage/GrammarProduct/Op/Subtract.hs +++ b/FormalLanguage/GrammarProduct/Op/Subtract.hs @@ -4,7 +4,7 @@ import Control.Arrow ((&&&)) import Control.Lens.Fold import Control.Lens hiding (outside,indices) -import Control.Newtype +import "newtype" Control.Newtype import Data.List (genericReplicate) import Data.Semigroup import qualified Data.Map as M diff --git a/FormalLanguage/GrammarProduct/Parser.hs b/FormalLanguage/GrammarProduct/Parser.hs --- a/FormalLanguage/GrammarProduct/Parser.hs +++ b/FormalLanguage/GrammarProduct/Parser.hs @@ -31,7 +31,7 @@ import Text.Trifecta.Delta import Text.Trifecta.Result import Data.Semigroup ((<>)) -import qualified Control.Newtype as T +import qualified "newtype" Control.Newtype as T --import Numeric.Natural.Internal import Prelude hiding (subtract) import Control.Monad @@ -47,26 +47,6 @@ --- TODO can remove, done via better FormalGrammars - --- -- | 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) - -- | The top-level parser for a grammar product. It can be used as one of the -- additional parser arguments, the formal grammars parser accepts. @@ -82,16 +62,8 @@ 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) $ transformRenamed r e --} + -- | Performs the actual parsing of a product string. Uses an expression parser -- internally. @@ -118,336 +90,4 @@ data ExprGrammar = ExprGrammar { getGrammar :: Grammar } | ExprNumber { getNumber :: Integer } - -{- -expr :: Map String Grammar -> Parse ExprGrammar -expr g = e where - e = buildExpressionParser table term - table = [ [ binary "^><" highDirect AssocLeft - ] - , [ binary "><" exprDirect AssocLeft - , binary "*" exprPower AssocLeft - ] - , [ binary "+" exprPlus AssocLeft - , binary "-" exprMinus AssocLeft - ] - ] - term = parens e - <|> (choice gts "previously defined grammar") - <|> (ExprNumber <$> natural "integral power of grammar") - gts = map (fmap ExprGrammar . gterm) $ M.assocs g - binary n f a = Infix (f <$ reserveGI n) a - exprDirect l r = ExprGrammar $ (getGrammar l >< getGrammar r) - exprPlus l r = ExprGrammar $ gAdd (getGrammar l) (getGrammar r) - exprMinus l r = ExprGrammar $ gSubtract (getGrammar l) (getGrammar r) - 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) - -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 - { _ntsyms :: Map String Integer - , _tsyms :: Set String - , _gs :: Map String Grammar - , _gCount :: Integer - , _grammarUid :: Integer - } - deriving (Show) - -instance Default GS where - def = GS - { _ntsyms = def - , _tsyms = def - , _gs = def - , _gCount = def - , _grammarUid = def - } - -makeLenses ''GS - --- | Parsing product expressions, producing a grammar, again - -{- -expr :: Map String Grammar -> Parse Grammar -expr g = choice [directprod] where - directprod = do - gl <- choice gts - reserve gi "><" - gr <- choice gts - return . unDirect $ Direct gl <> Direct gr - gts = map gterm $ M.assocs g --} - -expr :: Map String Grammar -> Parse ExprGrammar -expr g = e where - e = buildExpressionParser table term - table = [ [ binary "^><" highDirect AssocLeft - ] - , [ binary "><" exprDirect AssocLeft - , binary "*" exprPower AssocLeft - ] - , [ binary "+" exprPlus AssocLeft - , binary "-" exprMinus AssocLeft - ] - ] - term = parens e - <|> (choice gts "previously defined grammar") - <|> (ExprNumber <$> natural "integral power of grammar") - gts = map (fmap ExprGrammar . gterm) $ M.assocs g - binary n f a = Infix (f <$ reserve gi n) a - exprDirect l r = ExprGrammar . unDirect $ (Direct $ getGrammar l) <> (Direct $ getGrammar r) - exprPlus l r = ExprGrammar . unAdd $ (Add $ getGrammar l) <> (Add $ getGrammar r) - exprMinus l r = ExprGrammar $ subtract (getGrammar l) (getGrammar r) - exprPower l r = ExprGrammar $ power (getGrammar l) (getNumber r) - highDirect l r = 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 <$ reserve gi s - --- | Grammar product - -gprod :: Parse Grammar -gprod = do - reserve gi "Product:" - n <- ident gi - g <- use gs - e <- getGrammar <$> expr g - reserve gi "//" - let g = e & gname .~ n - gs <>= M.singleton (g ^. gname) g - return g - -data Product = Product - deriving (Show) - --- | --- --- TODO complain on indexed NTs with modulus '1' - -grammar :: Parse Grammar -grammar = do - -- reset some information - ntsyms .= def - tsyms .= def - -- new grammar - gCount += 1 - -- begin parsing - reserve gi "Grammar:" - n <- ident gi - (nts,ts) <- partitionEithers <$> ntsts - rs <- concat <$> some rule - reserve gi "//" - let g = Grammar (S.fromList rs) n - gs <>= M.singleton (g ^. gname) g - return g - --- | Parse a single rule. Some rules come attached with an index. In that case, --- each rule is inflated according to its modulus. --- --- TODO add @fun@ to each PR - -rule :: Parse [PR] -rule = do - ln <- ident gi "rule: lhs non-terminal" - uses ntsyms (M.member ln) >>= guard (printf "undeclared NT: %s" ln) - i <- nTindex - reserve gi "->" - fun <- ident gi - reserve gi "<<<" - zs <- runUnlined $ some (Left <$> try ruleNts <|> Right <$> try ruleTs) - whiteSpace - s <- get - let ret = runReaderT (genPR fun ln i zs) s - return ret - --- | Generate one or more production rules from a parsed line. - -genPR :: String -> String -> NtIndex -> [Either (String,NtIndex) String] -> ReaderT GS [] PR -genPR f ln i xs = go where - go = do - (l,(m,k)) <- genL i - r <- genR m k xs - return $ PR [l] r [f] - genL NoIdx = do - g <- view grammarUid - return (Nt 1 [NTSym ln 1 0], (1,0)) - genL (WithVar v 0) = do - g <- view grammarUid - m <- views ntsyms (M.! ln) - k <- lift [0 .. m-1] - return (Nt 1 [NTSym ln m k], (m,k)) - genL (Range xs) = do - g <- view grammarUid - m <- views ntsyms (M.! ln) - k <- lift xs - return (Nt 1 [NTSym ln m k], (m,k)) - genR m k [] = do - return [] - genR m k (Left (n,WithVar k' p) :rs) = do - let (WithVar v 0) = i - g <- view grammarUid - nm <- views ntsyms (M.! n) - when (v/=k') $ error "oops, index var wrong" - rs' <- genR m k rs - return (Nt 1 [NTSym n m ((k+p) `mod` m)] :rs') - genR m k (Left (n,Range ls) :rs) = do - g <- view grammarUid - nm <- views ntsyms (M.! n) - l <- lift ls - rs' <- genR m k rs - return (Nt 1 [NTSym n m l] :rs') - genR m k (Left (n,NoIdx) :rs) = do - g <- view grammarUid - nm <- views ntsyms (M.! n) - when (nm>1) $ error $ printf "oops, NoIdx given, but indexed NT in: %s" (show (nm,m,k,n,rs)) - rs' <- genR m k rs - return (Nt 1 [NTSym n 1 0] :rs') - genR m k (Right t :rs) = do - g <- view grammarUid - rs' <- genR m k rs - return (T 1 [TSym t] :rs') - -ruleNts :: ParseU (String,NtIndex) -ruleNts = do - n <- ident gi "rule: nonterminal identifier" - i <- nTindex "rule:" -- option ("",1) $ braces ((,) <$> ident gi <*> option 0 integer) "rule: nonterminal index" - lift $ uses ntsyms (M.member n) >>= guard (printf "undeclared NT: %s" n) - return (n,i) - -nTindex :: ParseG NtIndex -nTindex = option NoIdx - $ try (braces $ WithVar <$> ident gi <*> option 0 integer) - <|> try (Range <$> braces (commaSep1 integer)) - "non-terminal index" - -data NtIndex - = WithVar String Integer - | Range [Integer] - | NoIdx - deriving (Show) - -ruleTs :: ParseU String -ruleTs = do - n <- ident gi "rule: terminal identifier" - lift $ uses tsyms (S.member n) >>= guard (printf "undeclared T: %s" n) - return n - -ntsts :: Parse [Either NTSym TSym] -ntsts = concat <$> some (map Left <$> nts <|> map Right <$> ts) - --- | --- --- TODO expand @NT@ symbols here or later? - -nts :: Parse [NTSym] -nts = do - reserve gi "NT:" - n <- ident gi - mdl <- option 1 $ braces natural - let zs = map (NTSym n mdl) [0 .. mdl-1] - ntsyms <>= M.singleton n mdl - return zs - -ts :: Parse [TSym] -ts = do - reserve gi "T:" - n <- ident gi - let z = TSym n - tsyms <>= S.singleton n - return [z] - -parseDesc = do - whiteSpace - {- - gs <- some grammar - let g = undefined -- M.fromList $ map ((^. gname) &&& id) gs - ps <- some (gprod g) - -} - gsps <- some (grammar <|> gprod) - eof - let (gs,ps) = partition ((==1) . grammarDim) gsps - return (gs,ps) - -gi = set styleReserved rs emptyIdents where - rs = H.fromList ["Grammar:", "NT:", "T:"] - -newtype GrammarLang m a = GrammarLang {runGrammarLang :: m a } - deriving (Functor,Applicative,Alternative,Monad,MonadPlus,Parsing,CharParsing) - -instance MonadTrans GrammarLang where - lift = GrammarLang - {-# INLINE lift #-} - -instance TokenParsing m => TokenParsing (GrammarLang m) where - someSpace = GrammarLang $ someSpace `buildSomeSpaceParser` haskellCommentStyle - -type Parse a = (Monad m, TokenParsing m, MonadPlus m) => StateT GS m a -type ParseU a = (Monad m, TokenParsing m, MonadPlus m) => Unlined (StateT GS m) a -type ParseG a = (Monad m, TokenParsing m, MonadPlus m) => m a - -instance MonadTrans Unlined where - lift = Unlined - {-# INLINE lift #-} --} diff --git a/GrammarProducts.cabal b/GrammarProducts.cabal --- a/GrammarProducts.cabal +++ b/GrammarProducts.cabal @@ -1,7 +1,7 @@ name: GrammarProducts -version: 0.1.1.3 -author: Christian Hoener zu Siederdissen, 2013-2017 -copyright: Christian Hoener zu Siederdissen, 2013-2017 +version: 0.2.0.0 +author: Christian Hoener zu Siederdissen, 2013-2019 +copyright: Christian Hoener zu Siederdissen, 2013-2019 homepage: https://github.com/choener/GrammarProducts bug-reports: https://github.com/choener/GrammarProducts/issues maintainer: choener@bioinf.uni-leipzig.de @@ -11,36 +11,31 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0 -tested-with: GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 8.6.4 synopsis: Grammar products and higher-dimensional grammars description: . - An algebra of liner and context-free grammars. + An algebra of linear and context-free grammars. . - This library provides the implementation of our theory of - algebraic operations over linear and context-free grammars. - Using algebraic operations, it is possible to construct complex - dynamic programming algorithms from simpler "atomic" grammars. + This library provides the implementation of our theory of algebraic operations over + linear and context-free grammars. Using algebraic operations, it is possible to + construct complex dynamic programming algorithms from simpler "atomic" grammars. . - Our most important contribution is the definition of a product - of grammars which naturally leads to alignment-like algorithms - on multiple tapes. + Our most important contribution is the definition of a product of grammars which + naturally leads to alignment-like algorithms on multiple tapes. . - An efficient implementation of the resulting grammars is - possible via the ADPfusion framework. The @FormalGrammars@ - 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. + An efficient implementation of the resulting grammars is possible via the ADPfusion + framework. The @FormalGrammars@ 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 - with signature and grammar). + Alternatively, the resulting grammars can also be pretty-printed in various ways + (ANSI, Haskell module with signature and grammar). . - The formal background can be found in two papers given in the - README. The gADP homepage has further details, tutorials, - examples. + The formal background can be found in two papers given in the README. The gADP + homepage has further details, tutorials, examples. . @@ -70,20 +65,21 @@ , semigroups >= 0.15 , template-haskell >= 2 , transformers >= 0.4 - , trifecta >= 1.6 +-- due to we still using ansi-wl-pprint + , trifecta >= 1.7.1.1 && < 2.1 -- - , ADPfusion == 0.5.2.* - , FormalGrammars == 0.3.1.* - , PrimitiveArray == 0.8.0.* + , ADPfusion == 0.6.0.* + , FormalGrammars == 0.4.0.* + , PrimitiveArray == 0.10.0.* exposed-modules: FormalLanguage.GrammarProduct FormalLanguage.GrammarProduct.Op FormalLanguage.GrammarProduct.Op.Add FormalLanguage.GrammarProduct.Op.Chomsky - FormalLanguage.GrammarProduct.Op.Chomsky.Proof +-- FormalLanguage.GrammarProduct.Op.Chomsky.Proof FormalLanguage.GrammarProduct.Op.Common FormalLanguage.GrammarProduct.Op.Greibach - FormalLanguage.GrammarProduct.Op.Greibach.Proof +-- FormalLanguage.GrammarProduct.Op.Greibach.Proof FormalLanguage.GrammarProduct.Op.Linear FormalLanguage.GrammarProduct.Op.Power FormalLanguage.GrammarProduct.Op.Subtract @@ -97,12 +93,14 @@ , LambdaCase , NoMonomorphismRestriction , OverloadedStrings + , PackageImports , ParallelListComp , PatternGuards , RankNTypes , ScopedTypeVariables , StandaloneDeriving , TemplateHaskell + , TypeApplications , UnicodeSyntax ghc-options: -O2 @@ -110,31 +108,6 @@ --- With grammar products, we need a refined way of turning input source files --- into LaTeX and Haskell modules. - ---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 && < 5.0 @@ -156,19 +129,57 @@ default-language: Haskell2010 default-extensions: BangPatterns + , DataKinds , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses , QuasiQuotes , TemplateHaskell + , TypeApplications , TypeFamilies , TypeOperators ghc-options: -O2 - -fcpr-off -funbox-strict-fields -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + + + +test-suite properties + type: + exitcode-stdio-1.0 + main-is: + properties.hs + ghc-options: + -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: + tests + default-language: + Haskell2010 + default-extensions: BangPatterns +-- , CPP +-- , FlexibleContexts +-- , FlexibleInstances +-- , MultiParamTypeClasses +-- , ScopedTypeVariables +-- , TemplateHaskell +-- , TypeFamilies +-- , TypeOperators +-- , TypeSynonymInstances + cpp-options: + -DADPFUSION_TEST_SUITE_PROPERTIES + build-depends: base +-- , ADPfusion +-- , bits +-- , OrderedBits +-- , PrimitiveArray +-- , QuickCheck +-- , strict +-- , tasty >= 0.11 +-- , tasty-quickcheck >= 0.8 +-- , tasty-th >= 0.1 +-- , vector diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,15 @@ +0.2.0.0 +------- + +- cleanup and version bumped to ADPfusion 0.6 +- small rewrite of some of the underlying machinery +- updated the example "AlignGlobal" + +0.1.1.4 +------- + +- ADPfusion version bump (we still carefully track our own version bounds!) + 0.1.1.3 ------- diff --git a/src/AlignGlobal.hs b/src/AlignGlobal.hs --- a/src/AlignGlobal.hs +++ b/src/AlignGlobal.hs @@ -18,7 +18,7 @@ import Data.Sequence ((|>),Seq,empty) import Data.Foldable (toList) -import ADP.Fusion +import ADP.Fusion.PointL import Data.PrimitiveArray as PA hiding (map,toList) import FormalLanguage.CFG @@ -44,18 +44,18 @@ S: X X -> don <<< e // -Product: Global +Product: Glbl Step >< Step - Stand * 2 + Done * 2 // -Emit: Global +Emit: Glbl |] -makeAlgebraProduct ''SigGlobal +makeAlgebraProduct ''SigGlbl -score :: Monad m => SigGlobal m Int Int Char Char -score = SigGlobal +score :: Monad m => SigGlbl m Int Int Char Char +score = SigGlbl { donDon = \ (Z:.():.()) -> 0 , stpStp = \ x (Z:.a :.b ) -> if a==b then x+1 else -999999 , delStp = \ x (Z:.():.b ) -> x - 2 @@ -68,8 +68,8 @@ -- -- TODO use fmlist to make this more efficient. -pretty :: Monad m => SigGlobal m (String,String) [(String,String)] Char Char -pretty = SigGlobal +pretty :: Monad m => SigGlbl m (String,String) [(String,String)] Char Char +pretty = SigGlbl { donDon = \ (Z:.():.()) -> ("","") , stpStp = \ (x,y) (Z:.a :.b ) -> (x ++ [a],y ++ [b]) , delStp = \ (x,y) (Z:.():.b ) -> (x ++ "-",y ++ [b]) @@ -77,23 +77,32 @@ , h = SM.toList } -runNeedlemanWunsch :: Int -> String -> String -> (Int,[(String,String)]) -runNeedlemanWunsch k i1' i2' = (d, take k . unId $ axiom b) where +runNeedlemanWunsch :: Int -> String -> String -> (Int,[(String,String)],String) +runNeedlemanWunsch k i1' i2' = (d, take k . unId $ axiom b, show perf) where i1 = VU.fromList i1' i2 = VU.fromList i2' - !(Z:.t) = runNeedlemanWunschForward i1 i2 + Mutated (Z:.t) perf eachPerf = runNeedlemanWunschForward i1 i2 d = unId $ axiom t - !(Z:.b) = gGlobal (score <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i1) (chr i2) + !(Z:.b) = gGlbl (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 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) +runNeedlemanWunschForward + :: Vector Char + -> Vector Char + -> Mutated (Z:.TwITbl 0 0 Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int) {-# NoInline runNeedlemanWunschForward #-} +runNeedlemanWunschForward i1 i2 = runST $ do + arr <- newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999) + ts <- fillTables $ gGlbl score + (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr) + (chr i1) (chr i2) + return ts + where !n1 = VU.length i1 + !n2 = VU.length i2 + {- + -} main = do ls <- lines <$> getContents @@ -102,8 +111,9 @@ eats (a:b:xs) = do putStrLn a putStrLn b - let (k,ys) = runNeedlemanWunsch 1 a b + let (k,ys,p) = runNeedlemanWunsch 1 a b forM_ ys $ \(y1,y2) -> printf "%s %5d\n%s\n" y1 k y2 + putStrLn p eats xs eats ls diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,8 @@ + +module Main where + + + +main :: IO () +main = return () +