GrammarProducts 0.1.1.3 → 0.2.0.0

raw patch · 12 files changed

+123/−684 lines, 12 filesdep ~ADPfusiondep ~FormalGrammarsdep ~PrimitiveArrayPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ADPfusion, FormalGrammars, PrimitiveArray, base, trifecta

API changes (from Hackage documentation)

Files

• FormalLanguage/GrammarProduct/Op/Add.hs +1/−1
• FormalLanguage/GrammarProduct/Op/Chomsky.hs +1/−1
• FormalLanguage/GrammarProduct/Op/Chomsky/Proof.hs +0/−80
• FormalLanguage/GrammarProduct/Op/Common.hs +2/−1
• FormalLanguage/GrammarProduct/Op/Greibach.hs +1/−1
• FormalLanguage/GrammarProduct/Op/Greibach/Proof.hs +0/−163
• FormalLanguage/GrammarProduct/Op/Subtract.hs +1/−1
• FormalLanguage/GrammarProduct/Parser.hs +2/−362
• GrammarProducts.cabal +67/−56
• changelog.md +12/−0
• src/AlignGlobal.hs +28/−18
• tests/properties.hs +8/−0

@@ -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

@@ -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

@@ -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"-    , "//"-    ]---}-

@@ -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.

@@ -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)

@@ -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"-    , "//"-    ]---}-

@@ -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

@@ -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 #-}--} 

@@ -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:                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>                 .-                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   

@@ -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 ------- 

@@ -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 

@@ -0,0 +1,8 @@++module Main where++++main :: IO ()+main = return ()+