FormalGrammars 0.2.0.0 → 0.2.1.0

raw patch · 10 files changed

+370/−141 lines, 10 filesdep ~ADPfusiondep ~PrimitiveArrayPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ADPfusion, PrimitiveArray

API changes (from Hackage documentation)

Files

• FormalGrammars.cabal +20/−53
• FormalLanguage/CFG/Grammar/Types.hs +35/−13
• FormalLanguage/CFG/Grammar/Util.hs +23/−3
• FormalLanguage/CFG/Outside.hs +7/−5
• FormalLanguage/CFG/Parser.hs +125/−28
• FormalLanguage/CFG/PrettyPrint/ANSI.hs +24/−16
• FormalLanguage/CFG/TH.hs +81/−17
• README.md +37/−6
• changelog.md +7/−0
• tests/parsing.gra +11/−0

@@ -1,8 +1,9 @@ name:           FormalGrammars-version:        0.2.0.0+version:        0.2.1.0 author:         Christian Hoener zu Siederdissen, 2013-2015 copyright:      Christian Hoener zu Siederdissen, 2013-2015-homepage:       http://www.bioinf.uni-leipzig.de/Software/gADP/+homepage:       https://github.com/choener/FormalGrammars+bug-reports:    https://github.com/choener/FormalGrammars/issues maintainer:     choener@bioinf.uni-leipzig.de category:       Formal Languages, Bioinformatics license:        GPL-3@@ -13,6 +14,8 @@ tested-with:    GHC == 7.8.4, GHC == 7.10.1 synopsis:       (Context-free) grammars in formal language theory description:+                <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>+                .                 Context-free grammars in formal language theory are sets of                 production rules, non-terminal and terminal symbols. This                 library provides basic data types and functions to manipulate@@ -26,6 +29,9 @@                 This library also provides the machinery that transforms an                 Inside grammar into the corresponding Outside grammar.                 .+                Starting with version 0.2.1 it is possible to write multiple+                context-free grammars within this framework.+                .                 In addition, TemplateHaskell and QuasiQuoting functionality                 allow embedding thusly defined grammars in Haskell programs.                 ADPfusion then turns such a grammar into an efficient dynamic@@ -36,37 +42,8 @@                 that want to implement their CFG in another language than                 Haskell.                 .-                .-                .-                .-                Formal background can be found in these papers:-                .-                @-                Christian Hoener zu Siederdissen-                Sneaking Around ConcatMap: Efficient Combinators for Dynamic Programming-                2012. Proceedings of the 17th ACM SIGPLAN international conference on Functional programming-                <http://doi.acm.org/10.1145/2364527.2364559> preprint: <http://www.tbi.univie.ac.at/newpapers/pdfs/TBI-p-2012-2.pdf>-                @-                .-                @-                Andrew Farmer, Christian Höner zu Siederdissen, and Andy Gill.-                The HERMIT in the stream: fusing stream fusion’s concatMap.-                2014. Proceedings of the ACM SIGPLAN 2014 workshop on Partial evaluation and program manipulation.-                <http://dl.acm.org/citation.cfm?doid=2543728.2543736>-                @-                .-                @-                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>-                @-                .-                @-                Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler.-                Algebraic Dynamic Programming over General Data Structures.-                2015. submitted.-                @+                Formal background can be found in a number of papers which are+                given in the README.                 .  @@ -76,28 +53,23 @@   changelog.md   tests/parsing.gra ++ flag examples   description:  build the examples   default:      False   manual:       True -flag llvm-  description:  build using LLVM-  default:      False-  manual:       True- flag debug   description:  dump intermediate Core files   default:      False   manual:       True --- TODO relax parsers dependency once https://github.com/ekmett/parsers/issues/37 is dealt with --- explicit dependency on PrimitiveArray to be able to load the examples  library   build-depends: base                  >= 4.7     && < 4.9-               , ADPfusion             == 0.4.0.*+               , ADPfusion             >= 0.4.1   && < 0.4.2                , ansi-wl-pprint        == 0.6.7.*                , bytestring            == 0.10.*                , containers@@ -106,7 +78,7 @@                , lens                  == 4.*                , mtl                   == 2.*                , parsers               >= 0.12    && < 0.13-               , PrimitiveArray        == 0.6.0.*+               , PrimitiveArray        >= 0.6.0   && < 0.6.2                , semigroups            >= 0.16    && < 0.17                , template-haskell                , text                  == 1.*@@ -131,7 +103,9 @@     FormalLanguage.CFG.TH   default-language:     Haskell2010-  default-extensions: FlexibleContexts+  default-extensions: DeriveDataTypeable+                    , DataKinds+                    , FlexibleContexts                     , FlexibleInstances                     , GeneralizedNewtypeDeriving                     , LambdaCase@@ -139,6 +113,7 @@                     , NamedFieldPuns                     , NoMonomorphismRestriction                     , PatternGuards+                    , QuasiQuotes                     , RankNTypes                     , RecordWildCards                     , ScopedTypeVariables@@ -147,6 +122,7 @@                     , TupleSections                     , TypeFamilies                     , TypeOperators+                    , ViewPatterns   ghc-options:     -O2 -funbox-strict-fields @@ -209,13 +185,9 @@       -ddump-simpl       -ddump-stg       -dsuppress-all-  if flag(llvm)-    ghc-options:-      -fllvm-      -optlo-O3 -optlo-std-compile-opts-      -fllvm-tbaa  + executable NeedlemanWunschFG   if flag(examples)     buildable:@@ -257,11 +229,6 @@       -ddump-simpl       -ddump-stg       -dsuppress-all-  if flag(llvm)-    ghc-options:-      -fllvm-      -optlo-O3-      -fllvm-tbaa   

@@ -11,7 +11,23 @@ import           Data.String import qualified Data.Map.Strict as M import qualified Data.Set as S+import           Data.Data (Data,Typeable) +++newtype IndexName = IndexName { _getIndexName :: String }+  deriving (Show,Eq,Ord,IsString,Data,Typeable)++makeLenses ''IndexName++data IOP+  = IPlus     -- in rules+  | IMinus    -- in rules+  | IEq       -- in rules+  | INone     -- grammar-global+  | ISymbol   -- when creating the symbol, here @=n@ says to use @[0..n-1]@+  deriving (Show,Eq,Ord,Data,Typeable)+ -- | Encode the index of the syntactic or terminal variable. -- -- In case of grammar-based indexing, keep @indexRange@ empty. The@@ -22,15 +38,17 @@ -- one might want to be able to differentiate between terminals.  data Index = Index-  { _indexVar   :: String-  , _indexRange :: [String]-  , _indexStep  :: Int+  { _indexName  :: IndexName+  , _indexHere  :: Integer+  , _indexOp    :: IOP+  , _indexRange :: [Integer]+  , _indexStep  :: Integer   }   -- TODO need a version, where we have figured out everything   -- , i.e. replaced @i+2@ with, say, @1@ @(i==1+2 `mod` 3)@.   -- Use the @_indexVar = j@ version in the set of syn-vars, but   -- @_indexVar=x, x \in _indexRange@ in rules?-  deriving (Show,Eq,Ord)+  deriving (Show,Eq,Ord,Data,Typeable)  makeLenses ''Index @@ -39,7 +57,7 @@ -- | Newtype wrapper for symbol names.  newtype SymbolName = SymbolName { _getSteName :: String }-  deriving (Show,Eq,Ord,IsString)+  deriving (Show,Eq,Ord,IsString,Data,Typeable)  makeLenses ''SymbolName @@ -49,7 +67,7 @@ -- still have the same @SymbolName@ but different type and input!  newtype Tape = Tape { _getTape :: Int }-  deriving (Show,Eq,Ord,Enum,Num)+  deriving (Show,Eq,Ord,Enum,Num,Data,Typeable)  makeLenses ''Tape @@ -62,6 +80,8 @@   = SynVar     { _name   :: SymbolName     , _index  :: [Index]+    , _splitN :: Integer+    , _splitK :: Integer     }   -- syntactic terminals. Inside-synvars used in an outside context.   | SynTerm@@ -81,7 +101,7 @@   -- symbols, but it is important to be able to recognize these, when   -- trying to create outside variants of our algorithms.   | Epsilon-  deriving (Show,Eq,Ord)+  deriving (Show,Eq,Ord,Data,Typeable)  makeLenses ''SynTermEps makePrisms ''SynTermEps@@ -92,7 +112,7 @@ -- over dimensional concatenation.  newtype Symbol = Symbol { _getSymbolList :: [SynTermEps] }-  deriving (Show,Eq,Ord,Monoid,Semigroup)+  deriving (Show,Eq,Ord,Monoid,Semigroup,Data,Typeable)  makeLenses ''Symbol @@ -101,7 +121,7 @@ -- | The name of an attribute function  newtype AttributeFunction = Attr { _getAttr :: String }-  deriving (Show,Eq,Ord,IsString)+  deriving (Show,Eq,Ord,IsString,Data,Typeable)  makeLenses ''AttributeFunction @@ -114,7 +134,7 @@   , _attr :: [AttributeFunction]  -- ^ the attribute for this rule   , _rhs  :: [Symbol]             -- ^ the right-hand side with a collection of terminals and syntactic variables   }-  deriving (Show,Eq,Ord)+  deriving (Show,Eq,Ord,Data,Typeable)  makeLenses ''Rule @@ -123,7 +143,7 @@ data DerivedGrammar   = Inside   | Outside String-  deriving (Show,Eq)+  deriving (Show,Eq,Data,Typeable)  isOutside (Outside _) = True isOutside _           = False@@ -152,11 +172,12 @@   , _outside      :: DerivedGrammar                     -- ^ Is this an automatically derived outside grammar   , _rules        :: Set Rule                           -- ^ set of production rules   , _start        :: Symbol                             -- ^ start symbol-  , _params       :: Map String Index                   -- ^ any global variables+  , _params       :: Map IndexName Index                -- ^ any global variables+  , _indices      :: Map IndexName Index                -- ^ active indices   , _grammarName  :: String                             -- ^ grammar name   , _write        :: Bool                               -- ^ some grammar file requested this grammar to be expanded into code -- TODO remove, we have an emission queue   }-  deriving (Show)+  deriving (Show,Data,Typeable)  instance Default Grammar where   def = Grammar@@ -167,6 +188,7 @@     , _rules        = S.empty     , _start        = mempty     , _params       = M.empty+    , _indices      = M.empty     , _grammarName  = ""     , _write        = False     }

@@ -5,7 +5,7 @@  import Control.Lens hiding (Index,index) import Data.Tuple (swap)-import Data.List (sort,nub)+import Data.List (sort,nub,genericReplicate)  import FormalLanguage.CFG.Grammar.Types @@ -14,7 +14,7 @@ -- | @Term@, @Deletion@, and @Epsilon@ all count as terminal symbols.  isTerminal :: Symbol -> Bool-isTerminal = allOf folded (\case (SynVar _ _) -> False; (SynTerm _ _) -> False; _ -> True) . _getSymbolList+isTerminal = allOf folded (\case SynVar{} -> False; (SynTerm _ _) -> False; _ -> True) . _getSymbolList  -- | @Term@, and @Epsilon@ are terminal symbols that can be bound. @@ -24,7 +24,27 @@ -- | Only @SynVar@s are non-terminal.  isSyntactic :: Symbol -> Bool-isSyntactic = allOf folded (\case (SynVar _ _) -> True; _ -> False) . _getSymbolList+isSyntactic = allOf folded (\case SynVar{} -> True; _ -> False) . _getSymbolList++-- | special case of single-tape synvar in multi-tape setting++isSynStacked :: Symbol -> Bool+isSynStacked = allOf folded (\case SynVar{} -> True; Deletion -> True; _ -> False) . _getSymbolList++-- | true if we have a split synvar++isAllSplit :: Symbol -> Bool+isAllSplit = allOf folded (\case (SynVar _ _ n _) -> n>1 ; _ -> False) . _getSymbolList++-- | Set all @splitK@ values to @0@ for lookups.++splitK0 :: Symbol -> Symbol+splitK0 = set (getSymbolList . traverse . splitK) 0++-- | Take a split symbol and rewrite as full.++splitToFull :: Symbol -> Symbol+splitToFull (Symbol [SynVar s i n k]) = Symbol . genericReplicate n $ SynVar s i n 0  -- | Is this a syntactic terminal symbol? 

@@ -10,7 +10,7 @@ module FormalLanguage.CFG.Outside where  import           Data.List (inits,tails,nub,sort)-import           Control.Lens hiding (Index,outside)+import           Control.Lens hiding (Index,outside,indices) import qualified Data.Set as S import           Data.Set (Set) import           Data.Maybe (catMaybes)@@ -35,9 +35,10 @@         _rules       = S.fromList $ epsrule : (concatMap genOutsideRules $ g^..rules.folded)         _grammarName = "" -- will be set in the parser         _params      = g^.params-        _synvars     = M.fromList $ [ (n,v) | v@(SynVar  n _) <- (_rules^..folded.lhs.getSymbolList.folded) ]-        _synterms    = M.fromList $ [ (n,v) | v@(SynTerm n _) <- (_rules^..folded.rhs.folded.getSymbolList.folded) ]-        _termvars    = M.fromList $ [ (n,t) | t@(Term    n _) <- (_rules^..folded.rhs.folded.getSymbolList.folded) ]+        _indices     = g^.indices+        _synvars     = M.fromList $ [ (n,v) | v@(SynVar  n _ _ _) <- (_rules^..folded.lhs.getSymbolList.folded) ]+        _synterms    = M.fromList $ [ (n,v) | v@(SynTerm n _)     <- (_rules^..folded.rhs.folded.getSymbolList.folded) ]+        _termvars    = M.fromList $ [ (n,t) | t@(Term    n _)     <- (_rules^..folded.rhs.folded.getSymbolList.folded) ]         _start       = case (findStartSymbols $ g^.rules) of                          [s] -> s                          xs  -> error $ "more than one epsilon rule in the source: " ++ show xs@@ -71,7 +72,8 @@           | otherwise  = Just $ Rule (outsideSymb h) (outsideFun f) (map toSynTerm xs ++ [outsideSymb l] ++ map toSynTerm ys)         outsideFun  = id         toSynTerm s-          | isSyntactic s = over (getSymbolList . traverse) (\(SynVar n i) -> SynTerm n i) s+          -- TODO need to handle @SynVar n i s | s > 1@ !+          | isSyntactic s = over (getSymbolList . traverse) (\(SynVar n i s k) -> SynTerm n i) s           | otherwise     = s  -- | Helper function that turns an inside symbol into an outside symbol.

@@ -13,28 +13,31 @@  import           Control.Applicative import           Control.Arrow-import           Control.Lens hiding (Index, outside)+import           Control.Lens hiding (Index, outside, indices, index) import           Control.Monad import           Control.Monad.State.Class (MonadState (..)) import           Control.Monad.Trans.State.Strict hiding (get)+import           Data.ByteString.Char8 (pack) import           Data.Default+import           Data.List (nub,genericIndex,mapAccumL) import           Data.Map.Strict (Map) import           Data.Maybe+import           Data.Monoid import           Data.Sequence (Seq) import           Debug.Trace import qualified Data.HashSet as H import qualified Data.Map.Strict as M import qualified Data.Sequence as Seq import qualified Data.Set as S+import qualified Text.PrettyPrint.ANSI.Leijen as AL import           System.IO.Unsafe (unsafePerformIO) import           Text.Parser.Token.Style import           Text.Printf import           Text.Trifecta-import qualified Text.PrettyPrint.ANSI.Leijen as AL-import           Data.Monoid import           Text.Trifecta.Delta (Delta (Directed))-import           Data.ByteString.Char8 (pack) +import Data.Data.Lens+ import           FormalLanguage.CFG.Grammar import           FormalLanguage.CFG.Outside import           FormalLanguage.CFG.PrettyPrint.ANSI@@ -63,7 +66,7 @@                    }  -test = parseFromFile ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True}) "tests/parsing.gra"+test = parseFromFile ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True}) "tests/pseudo.gra"   @@ -85,19 +88,29 @@   reserve fgIdents "Grammar:"   n <- newGrammarName   current.grammarName    .= n-  current.params   <~ (M.fromList . fmap (_indexVar &&& id))  <$> (option [] $ parseIndex EvalGrammar) <?> "global parameters"-  current.synvars  <~ (M.fromList . fmap (_name &&& id)) <$> some (parseSyntacticDecl EvalGrammar)-  current.synterms <~ (M.fromList . fmap (_name &&& id)) <$> many (parseSynTermDecl EvalGrammar)+  current.params   <~ (M.fromList . fmap (_indexName &&& id))  <$> (option [] $ parseIndex EvalGrammar) <?> "global parameters"+  current.synvars  <~ (M.fromList . fmap (_name &&& id)) <$> some (parseSyntacticDecl EvalSymb)+  current.synterms <~ (M.fromList . fmap (_name &&& id)) <$> many (parseSynTermDecl EvalSymb)   current.termvars <~ (M.fromList . fmap (_name &&& id)) <$> many parseTermDecl+  current.indices  <~ (M.fromList . fmap (_indexName &&& id)) <$> setIndices   -- TODO current.epsvars <~ ...   current.start    <~ parseStartSym-  current.rules    <~ S.fromList <$> some parseRule+  current.rules    <~ (S.fromList . concat) <$> some parseRule   reserve fgIdents "//"   g <- use current   v <- use verbose   seq (unsafePerformIO $ if v then (printDoc . genGrammarDoc $ g) else return ())     $ env %= M.insert n g +-- | Collect all indices and set them as active++setIndices :: Parse m [Index]+setIndices = do+  sv <- use (current . synvars  . folded . index)+  st <- use (current . synterms . folded . index)+  tv <- use (current . termvars . folded . index)+  return $ nub $ sv ++ st ++ tv+ -- | Which of the intermediate grammar to actually emit as code or text in -- TeX. Single line: @Emit: KnownGrammarName@ @@ -169,7 +182,7 @@  fgIdents = set styleReserved rs emptyIdents   where rs = H.fromList [ "Grammar:", "Outside:", "Source:", "NormStartEps:", "Emit:", "Help", "Verbose"-                        , "N:", "Y:", "T:", "S:", "->", "<<<", "-", "e", "ε"+                        , "N:", "Y:", "T:", "S:", "->", "=", "<<<", "-", "e", "ε"                         ]  -- |@@ -192,12 +205,15 @@   when (isNothing g) $ unexpected "known source grammar"   return $ fromJust g --- | Parses a syntactic (or non-terminal) symbol (for the corresponding index type). Cf. 'parseSynTermDecl'.+-- | Parses a syntactic (or non-terminal) symbol (for the corresponding+-- index type). Cf. 'parseSynTermDecl'.  parseSyntacticDecl :: EvalReq -> Parse m SynTermEps parseSyntacticDecl e = do   reserve fgIdents "N:"-  SynVar <$> (ident fgIdents <?> "syntactic variable name") <*> (option [] $ parseIndex e)+  try split <|> normal+  where split = angles (flip (set splitN) <$> normal <* string "," <*> integer)+        normal = SynVar <$> (ident fgIdents <?> "syntactic variable name") <*> (option [] $ parseIndex e) <*> pure 1 <*> pure 0  -- | Parses a syntactic terminal declaration; an inside syntactic variable in an outside context. @@ -219,23 +235,34 @@  parseStartSym :: Parse m Symbol parseStartSym-  =  (runUnlined $ reserve fgIdents "S:" *> knownSynVar EvalGrammar)+  =  (runUnlined $ reserve fgIdents "S:" *> knownSynVar EvalRule)   <* someSpace  -- | -data EvalReq = EvalFull | EvalGrammar | EvalSymb+data EvalReq+  -- | Happens when we actually emit a grammar product (in development)+  = EvalFull+  -- | Happens when we work through the rules+  | EvalRule+  -- | Happens when we encounter @N: @ and define a symbol+  | EvalSymb+  -- | Happens when we define grammar-global parameters+  | EvalGrammar  -- |  knownSynVar :: EvalReq -> Stately m Symbol knownSynVar e = Symbol <$> do-  ((:[]) <$> sv) <|> (brackets $ commaSep sv)+  ((:[]) <$> sv) <|> (brackets $ commaSep sv) <|> (angles $ commaSep sv)   where sv = flip (<?>) "known syntactic variable" . try $ do                s <- ident fgIdents-               use (current . synvars . at s) >>= guard . isJust-               i <- option [] $ parseIndex e-               return $ SynVar s i+               l <- use (current . synvars . at s)+               case l of+                Nothing -> fail "bla"+                Just (SynVar s' i' n' _) ->+                  do i <- option [] $ parseIndex e+                     return $ SynVar s i n' 0  -- | @@ -246,13 +273,33 @@                s <- ident fgIdents                use (current . synterms . at s) >>= guard . isJust                i <- option [] $ parseIndex e-               return $ SynVar s i+               return $ SynVar s i 0 0 --- |+-- | Parses indices @{ ... }@ within curly brackets (@braces@).+--+-- When parsing the @EvalSymb@ case, indexed symbols are being created.+--+-- Parsing in rules is handled via @EvalRule@ and actually requires us+-- saying which explicit index we use.  parseIndex :: EvalReq -> Stately m [Index]+parseIndex e = concat <$> (braces . commaSep $ ix e) where+  -- only declare that indices exist, but do not set ranges, etc+  ix EvalGrammar = (\s -> [Index s 0 undefined [] 1]) <$> ident fgIdents+  -- TODO check if @n@ is globally known+  ix EvalSymb = do s <- ident fgIdents+                   reserve fgIdents "="+                   n <- natural+                   return [Index s 0 ISymbol [0..n-1] 1]+  ix EvalRule = do s <- ident fgIdents+                   let req    = (\k -> [Index s k IEq    [] 1]) <$ reserve fgIdents "=" <*> natural+                   let rminus = (\k -> [Index s k IMinus [] 1]) <$ reserve fgIdents "-" <*> natural+                   let rplus  = (\k -> [Index s k IPlus  [] 1]) <$> (option 0 $ reserve fgIdents "+" *> natural)    -- the option here is for @+0@+                   try req <|> try rminus <|> rplus+{- parseIndex e = braces $ commaSep ix where   ix = (\v -> Index v [] 0) <$> some alphaNum+-}  -- | @@ -262,9 +309,12 @@   where tv = flip (<?>) "known terminal variable" . try $ do                i <- ident fgIdents                t <- use (current . termvars . at i)---               e <- use (current . epsvars  . at i)-               guard . isJust $ t -- <|> e-               return $ Term i []+               s <- use (current . synvars  . at i)+               guard . isJust $ t <|> s+               -- TODO this will produce bad @SynVar@ for indexed cases+               -- (and probably for split cases, but these are even more+               -- weird)+               return $ if isJust t then Term i [] else SynVar i [] 1 0                {-                if isJust t                 then return $ Term i []@@ -283,16 +333,63 @@  -- | -parseRule :: Parse m Rule-parseRule = (runUnlined rule) <* someSpace+parseRule :: Parse m [Rule]+parseRule = (expandIndexed =<< runUnlined rule) <* someSpace   where rule  = Rule-              <$> knownSynVar EvalGrammar+              <$> knownSynVar EvalRule               <*  reserve fgIdents "->"               <*> afun               <*  string "<<<" <* spaces-              <*> some syms+              <*> (updateSplitCounts <$> some syms)         afun = (:[]) <$> ident fgIdents-        syms = knownSymbol EvalSymb+        syms = knownSymbol EvalRule++-- | For split syntactic variables used in split manner+-- (i.e. @S -> X Y X Y)+--+-- TODO error control!++updateSplitCounts :: [Symbol] -> [Symbol]+updateSplitCounts = snd . mapAccumL go M.empty where+  go m (Symbol [SynVar s i n k])+    | n > 1                      = let o = M.findWithDefault 0 (s,i) m + 1+                                   in  (M.insert (s,i) o m, Symbol [SynVar s i n o])+  go m s                         = (m,s)++-- | Once we have parsed a rule, we still need to extract all active+-- indices in the rule, and enumerate over them. This will finally generate+-- the set of rules we are interested in.++expandIndexed :: Rule -> Parse m [Rule]+expandIndexed r = do+  -- active index names+  let is :: [IndexName] = nub $ r ^.. biplate . indexName+  -- corresponding @Index@es+  js :: [Index] <- catMaybes <$> mapM (\i -> use (current . indices . at i)) is+  --error $ show js+  if null js+    then return [r]+    else mapM go $ sequence $ map expand js+  where -- updates the indices in the rules accordingly+        go :: [Index] -> Parse m Rule+        go ixs = foldM (\b a -> return $ b & biplate.index.traverse %~ changeIndex a) r ixs+        -- expands each index to all variants+        expand :: Index -> [Index]+        expand i = [ i & indexHere .~ j | j <- i^.indexRange ]+        changeIndex :: Index -> Index -> Index+        changeIndex i o+          | iin /= oin = o+          | o^.indexOp == IEq = o+          | null otr   = error $ printf "index %s uses var %d that is not in range %s!\n" (oin^.getIndexName) oih (show rng)+          | o^.indexOp == IPlus  = o & indexHere .~ ((otr ++ cycle rng)           `genericIndex` oih)+          | o^.indexOp == IMinus = o & indexHere .~ ((tro ++ cycle (reverse rng)) `genericIndex` oih)+          where rng = i^.indexRange+                otr = dropWhile (/= i^.indexHere) rng+                tro = dropWhile (/= i^.indexHere) $ reverse rng+                iin = i^.indexName+                iih = i^.indexHere+                oin = o^.indexName+                oih = o^.indexHere  -- | 

@@ -32,12 +32,13 @@  grammarDoc :: Grammar -> Reader Grammar Doc grammarDoc g = do+  let numR = length $ g^..rules.folded   ga <- indexDoc $ g^..params.folded-  ss <- fmap (ind "syntactic symbols:"   2 . vcat) . mapM steDoc $ g^..synvars.folded-  os <- fmap (ind "syntactic terminals:" 2 . vcat) . mapM steDoc $ g^..synterms.folded-  ts <- fmap (ind "terminals:"           2 . vcat) . mapM steDoc $ g^..termvars.folded-  s  <- fmap (ind "start symbol:"        2) $ symbolDoc (g^.start)-  rs <- fmap (ind "rules:"               2 . vcat) . rulesDoc $ g^..rules.folded+  ss <- fmap (ind "syntactic symbols:"             2 . vcat) . mapM steDoc $ g^..synvars.folded+  os <- fmap (ind "syntactic terminals:"           2 . vcat) . mapM steDoc $ g^..synterms.folded+  ts <- fmap (ind "terminals:"                     2 . vcat) . mapM steDoc $ g^..termvars.folded+  s  <- fmap (ind "start symbol:"                  2) $ symbolDoc (g^.start)+  rs <- fmap (ind ("rules (" ++ show numR ++ "):") 2 . vcat) . rulesDoc $ g^..rules.folded   ind <- undefined   return $ text "Grammar: " <+> (text $ g^.grammarName) <+> ga <$> indent 2 (vsep $ [ss] ++ [os | Outside _ <- [g^.outside]] ++ [ts, s, rs]) <$> line   where ind s k d = text s <$> indent k d@@ -48,29 +49,36 @@ ruleDoc :: Rule -> Reader Grammar Doc ruleDoc (Rule lhs fun rhs)   = do l  <- symbolDoc lhs-       rs <- fmap (intersperse (text "   ")) . mapM symbolDoc $ rhs+       rs <- fmap (intersperse (text "   ")) . mapM (fmap (fill 5) . symbolDoc) $ rhs        return $ fill 10 l <+> text "->" <+> f <+> text "<<<" <+> hcat rs   where f  = fill 10 . text . concat . (over (_tail.traverse._head) toUpper) $ fun^..folded.getAttr  steDoc :: SynTermEps -> Reader Grammar Doc-steDoc (SynVar  n i) = indexDoc i >>= return . blue . (text (n^.getSteName) <+>)-steDoc (SynTerm n i) = indexDoc i >>= return . magenta . (text (n^.getSteName) <+>)-steDoc (Term    n i) = return . green . text $ n^.getSteName-steDoc (Epsilon    ) = return . red   . text $ "ε"-steDoc (Deletion   ) = return . red   . text $ "-"+steDoc (SynVar  n i s k) = indexDoc i >>= return . blue . (text (n^.getSteName) <>)+steDoc (SynTerm n i    ) = indexDoc i >>= return . magenta . (text (n^.getSteName) <>)+steDoc (Term    n i    ) = return . green . text $ n^.getSteName+steDoc (Epsilon        ) = return . red   . text $ "ε"+steDoc (Deletion       ) = return . red   . text $ "-"  indexDoc :: [Index] -> Reader Grammar Doc indexDoc [] = return empty indexDoc xs = fmap (encloseSep lbrace rbrace comma) . mapM iDoc $ xs-  where iDoc (Index i _ s) = do ps <- asks _params-                                return $ (if i `M.member` ps then red else id) $ text i+  where iDoc (Index n i _ is s) = do ps <- asks _params+                                     return $ (if n `M.member` ps then red else id) $ if (not $ null is)+                                                                                        then text $ _getIndexName n ++ "∈" ++ show is+                                                                                        else text $ _getIndexName n ++ "=" ++ show i          sDoc s | s==0 = empty-               | s> 0 = text $ "+" ++ show s+               | s>=0 = text $ "+" ++ show s                | s< 0 = text $        show s  symbolDoc :: Symbol -> Reader Grammar Doc-symbolDoc (Symbol [x]) = steDoc x-symbolDoc (Symbol xs ) = fmap list . mapM steDoc $ xs+symbolDoc (Symbol [x])+  | SynVar _ _ n k <- x+  , n > 1        = fmap (<> text "_" <> integer k) $ steDoc x+  | otherwise    = steDoc x+symbolDoc s@(Symbol xs )+  | isAllSplit s = fmap (encloseSep langle rangle comma) . mapM steDoc $ xs+  | otherwise    = fmap list . mapM steDoc $ xs  printDoc :: Doc -> IO () printDoc d = displayIO stdout (renderPretty 0.8 160 $ d <> linebreak)

@@ -19,6 +19,7 @@ import           Control.Exception (assert) import           Control.Lens hiding (Strict, (...), outside) import           Control.Monad+import           Control.Monad.Reader import           Control.Monad.State.Strict as M import           Control.Monad.Trans.Class import           Data.Char (toUpper,toLower)@@ -27,6 +28,7 @@ import           Data.List (intersperse,nub,nubBy,groupBy) import           Data.Maybe import           Data.Vector.Fusion.Stream.Monadic (Stream)+import           Debug.Trace import           GHC.Exts (the) import           Language.Haskell.TH import           Language.Haskell.TH.Syntax hiding (lift)@@ -34,11 +36,11 @@ import qualified Data.Set as S import qualified Text.PrettyPrint.ANSI.Leijen as PP import           Text.Printf-import           Control.Monad.Reader+import qualified GHC.TypeLits as Kind  import           ADP.Fusion ( (%), (|||), (...), (<<<) )-import qualified ADP.Fusion as ADP import           Data.PrimitiveArray (Z(..), (:.)(..))+import qualified ADP.Fusion as ADP  import           FormalLanguage.CFG.Grammar import           FormalLanguage.CFG.PrettyPrint.ANSI@@ -122,11 +124,15 @@   _qElemTyName          <- newName "s"   _qRetTyName           <- newName "r"   _qTermAtomTyNames     <- M.fromList <$> (mapM (\t -> (t,) <$> newName ("t_" ++ t)) $ g^..termvars.folded.name.getSteName)-  _qPartialSyntVarNames <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("s_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSyntacticSymbols g) -- g^..nsyms.folded) -- collectSymbN g)+  _qPartialSyntVarNames <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("s_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSyntacticSymbols g)   _qInsideSyntVarNames  <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("i_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSynTermSymbols   g)   let _qPrefix          =  over _head toLower $ take prefixLen (g^.grammarName)+  let ls = (nub . map _lhs . S.elems) $ g^.rules+  let synKeys  = (filter (`elem` ls) . M.keys) _qPartialSyntVarNames+  bodySynNames  <- sequence [ (n,) <$> (newName $ "ss_" ++ concat k) | n <- synKeys, let k = n^..getSymbolList.folded.name.getSteName ]+  let _qFullSyntVarNames = M.fromList bodySynNames   -- TODO inside synvars in outside context-  evalStateT codeGen def{_qGrammar, _qMTyName, _qElemTyName, _qRetTyName, _qTermAtomTyNames, _qPartialSyntVarNames, _qInsideSyntVarNames, _qPrefix}+  evalStateT codeGen def{_qGrammar, _qMTyName, _qElemTyName, _qRetTyName, _qTermAtomTyNames, _qPartialSyntVarNames, _qInsideSyntVarNames, _qPrefix, _qFullSyntVarNames}  -- | Actually create signature, grammar, inline pragma. @@ -218,10 +224,13 @@  grammarBodyWhere :: TQ [DecQ] grammarBodyWhere = do+  {-   ls <- (nub . map _lhs . S.elems) <$> use (qGrammar.rules)   synKeys       <- (filter (`elem` ls) . M.keys) <$> use qPartialSyntVarNames   bodySynNames  <- lift $ sequence [ (n,) <$> (newName $ "ss_" ++ concat k) | n <- synKeys, let k = n^..getSymbolList.folded.name.getSteName ]   qFullSyntVarNames .= M.fromList bodySynNames+  -}+  bodySynNames <- M.toList <$> use qFullSyntVarNames   -- TODO now we actually need to *ALSO* add symbols for the inside stuff,   -- if this is an outside grammar.   mapM grammarBodySyn bodySynNames@@ -254,10 +263,34 @@   terms        <- use qTermSymbExp   synNames     <- use qFullSyntVarNames -- just the name of the fully applied symbol   synTermNames <- use qInsideSyntVarNames-  let genSymbol s-        | isTerminal  s = return . snd  $ M.findWithDefault (error "grammarBodyRHS") s terms-        | isSyntactic s = return . VarE $ M.findWithDefault (error "grammarBodyRHS") s (synNames) -- `M.union` isnNames)-        | isSynTerm   s = return . VarE $ M.findWithDefault (error "grammarBodyRHS") s (synTermNames)+  let fragmentSynVar :: Symbol -> Maybe Name+      fragmentSynVar s@(Symbol [SynVar _ _ n k]) | n>1 && k<n = M.lookup (splitToFull s) synNames+      fragmentSynVar _ = Nothing+  let finalSynVar :: Symbol -> Maybe Name+      finalSynVar s@(Symbol [SynVar _ _ n k]) | n>1 && k==n = M.lookup (splitToFull s) synNames+      finalSynVar _ = Nothing+  let genSymbol :: Symbol -> ExpQ+      -- | If, for whatever reason, we have an empty symbol+      genSymbol (Symbol []) = error "empty genSymbol"+      -- | if we deal with terminals+      genSymbol ((`M.lookup` terms) -> Just (_,v)) = return v+      -- | if we deal with usual syntactic vars+      genSymbol ((`M.lookup` synNames) -> Just n) = varE n+      -- | usual syntactic terminals+      genSymbol ((`M.lookup` synTermNames) -> Just n) = varE n+      -- | if we deal with split synvars and have a fragment+      genSymbol (fragmentSynVar -> Just n) = let p = show n in [| ADP.split (ADP.Proxy :: ADP.Proxy ($(litT $ strTyLit p) :: Kind.Symbol)) (ADP.Proxy :: ADP.Proxy ADP.Fragment) $(varE n) |]+      -- | if we deal with split synvars and have a final split+      genSymbol (finalSynVar    -> Just n) = let p = show n in [| ADP.split (ADP.Proxy :: ADP.Proxy ($(litT $ strTyLit p) :: Kind.Symbol)) (ADP.Proxy :: ADP.Proxy ADP.Final   ) $(varE n) |]+      -- | single-tape synvars in a multi-tape setting+      genSymbol s+        | isSynStacked s = foldl go [|ADP.M|] $ _getSymbolList s+        where go acc Deletion = [| $(acc) ADP.:| ADP.Deletion |]+              go acc sv+                | Just n <- M.lookup (Symbol [sv]) synNames = [| $(acc) ADP.:| $(varE n) |]+                | otherwise = error $ "genSymbol:stacked: " ++ show s+      -- | catch-all error+      genSymbol s = error $ "genSymbol: " ++ show s   let rhs = assert (not $ null rs) $ foldl1 (\acc z -> uInfixE acc (varE '(%)) z) . map genSymbol $ rs   -- apply evaluation function   Just (fname,_,_) <- use (qAttribFuns . at f)@@ -271,24 +304,45 @@ grammarTermExpression s = do   ttypes <- use qTermAtomTyNames   tavn <- use qTermAtomVarNames+  elemTyName <- use qElemTyName+  synNames     <- use qFullSyntVarNames -- just the name of the fully applied symbol+  g <- use qGrammar   let genType :: [SynTermEps] -> TypeQ       genType z --        | Symb Outside _ <- z = error $ printf "terminal symbol %s with OUTSIDE annotation!\n" (show z)         | [Deletion]      <- z = [t| () |]         | [Epsilon ]      <- z = [t| () |]-        | [Term tnm tidx] <- z = varT $ ttypes M.! (tnm^.getSteName)+        | [Term tnm tidx] <- z+        , Just v <- M.lookup (tnm^.getSteName) ttypes = varT v+        | [Term tnm tidx] <- z+        {- , Just v <- M.lookup (tnm^.getSteName) (error "bla") -} = varT elemTyName         | xs              <- z = foldl (\acc z -> [t| $acc :. $(genType [z]) |]) [t| Z |] xs+  let genSingleExp :: Int -> SynTermEps -> ExpQ+      genSingleExp _ Deletion = [| ADP.Deletion |]+      genSingleExp _ Epsilon  = [| ADP.Epsilon  |]+      genSingleExp _ (((`M.lookup` synNames) . Symbol . (:[])) -> Just n) = error $ show n+      genSingleExp k (Term tnm tidx)+        | Just n <- M.lookup (tnm^.getSteName,k) tavn = varE n+        -- TODO this one is dangerous but currently necessary for split+        -- systems+        | Just n <- M.lookup (tnm^.getSteName,0) tavn = varE n+        | otherwise = error $ show ("genSingleExp:Term: ",k,tnm,tidx, tavn)+      genSingleExp _ err      = error $ "genSingleExp: " ++ show (s,err)   let genExp :: [SynTermEps] -> ExpQ       genExp z --        | Symb Outside _ <- z = error $ printf "terminal symbol %s with OUTSIDE annotation!\n" (show z)         | [Deletion]      <- z = [| ADP.Deletion |] -- TODO ???         | [Epsilon ]      <- z = [| ADP.Epsilon  |]-        | [Term tnm tidx] <- z = varE $ tavn M.! (tnm^.getSteName,0)+        | [Term tnm tidx] <- z+        , Just v <- M.lookup (tnm^.getSteName,0) tavn = varE v+        | xs              <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(genSingleExp k z) |])+                                        [| ADP.M |] $ zip [0..] xs+{-                                                 | xs              <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(case z of { Deletion -> [| ADP.Deletion |]                                                                                  ; Epsilon  -> [| ADP.Epsilon  |]-                                                                                 ; Term tnm tidx -> varE $ tavn M.! (tnm^.getSteName,k)+                                                                                 ; Term tnm tidx -> varE $ M.findWithDefault (error $ "genExp: " ++ show (tnm^.getSteName,k)) (tnm^.getSteName,k) tavn                                                                                  }) |])-                                        [| ADP.M |] $ zip [0..] xs+                                        [| ADP.M |] $ zip [0..] xs  -}   ty <- lift . genType $ s^.getSymbolList   ex <- lift . genExp  $ s^.getSymbolList   return (s, (ty,ex))@@ -339,17 +393,27 @@   let (f:fs) = r^..attr.folded   elemTyName <- use qElemTyName   terminal   <- use qTermSymbExp-  let argument :: Symbol -> Type+  let argument :: Symbol -> TypeQ       argument s-        | isSyntactic s = VarT elemTyName-        | isSynTerm   s = VarT elemTyName-        | isTerminal  s = fst $ terminal  M.! s+        -- split stuff has @()@ arg type+        | isSyntactic s+        , (Symbol [SynVar _ _ n k]) <- s+        , n>1 && k<n   = [t| () |]+        | isSyntactic s  = varT elemTyName+        | isSynTerm   s  = varT elemTyName+        | isTerminal  s  = return . fst $ terminal  M.! s+        | isSynStacked s = let go :: TypeQ -> SynTermEps -> TypeQ+                               go t Deletion = [t| $(t) :. () |]+                               go t SynVar{} = [t| $(t) :. $(varT elemTyName) |]+                               go t sv = error $ show sv+                           in  foldl go [t|Z|] $ _getSymbolList s+        | otherwise     = error $ "argument: " ++ show s   prefix <- use qPrefix   let attrFun = over _head toLower (f^.getAttr) ++ concatMap (over _head toUpper) (fs^..folded.getAttr) -- TODO mkName ???   nm <- lift $ (return . mkName) $ if null prefix                                       then attrFun                                       else prefix ++ over _head toUpper attrFun-  let tp = foldr AppT (VarT elemTyName) $ map (AppT ArrowT . argument) $ r^.rhs+  tp <- lift $ foldr appT (varT elemTyName) $ map (appT arrowT . argument) $ r^.rhs   return (f:fs, (nm,NotStrict,tp))  -- | Build the choice function. Basically @Stream m s -> m r@.

@@ -1,14 +1,45 @@-# FormalGrammars- [![Build Status](https://travis-ci.org/choener/FormalGrammars.svg?branch=master)](https://travis-ci.org/choener/FormalGrammars) -[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)+# FormalGrammars: A DSL for formal languages in Haskell +[*generalized Algebraic Dynamic Programming Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/) +The gADP homepage has a tutorial and example on how to write algorithms /+grammars. +Ideas implemented here are described in a couple of papers:++++1.  Christian Hoener zu Siederdissen  +    *Sneaking Around ConcatMap: Efficient Combinators for Dynamic Programming*  +    2012, Proceedings of the 17th ACM SIGPLAN international conference on Functional programming  +    [paper](http://doi.acm.org/10.1145/2364527.2364559) [preprint](http://www.tbi.univie.ac.at/newpapers/pdfs/TBI-p-2012-2.pdf)  +1.  Andrew Farmer, Christian Höner zu Siederdissen, and Andy Gill.  +    *The HERMIT in the stream: fusing stream fusion’s concatMap*  +    2014, Proceedings of the ACM SIGPLAN 2014 workshop on Partial evaluation and program manipulation.  +    [paper](http://dl.acm.org/citation.cfm?doid=2543728.2543736)  +1.  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  +    [paper](http://ieeexplore.ieee.org/xpl/articleDetails.jsp?arnumber=6819790)  +1.  Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler  +    *Algebraic Dynamic Programming over General Data Structures*  +    2015, BMC Bioinformatics  +    [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf)  +1.  Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler  +    *Algebraic dynamic programming for multiple context-free languages*  +    2015, submitted  +    [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)  +++++ #### Contact -Christian Hoener zu Siederdissen-choener@bioinf.uni-leipzig.de-http://www.bioinf.uni-leipzig.de/~choener/+Christian Hoener zu Siederdissen  +Leipzig University, Leipzig, Germany  +choener@bioinf.uni-leipzig.de  +http://www.bioinf.uni-leipzig.de/~choener/   

@@ -1,3 +1,10 @@+0.2.1.0+-------++- indexed rules and grammars (revamped system)+- *multi*-context free grammars available!+- new travis.yml+ 0.2.0.0 ------- 

@@ -6,6 +6,7 @@ Also: Pretty comments ;-) -} +{- Grammar: CPG  -- the name of the grammar  N: P  -- islands 'Plus'@@ -38,4 +39,14 @@  Emit: CPG -- Emit: GPC+-}++Grammar: Two {i,j}+N: A{k = 3,l = 3}+N: B+S: A{k = 0}+A{k} -> ff <<< A{l}+A{k} -> ff <<< B+A{k} -> ff <<< A{k + 0}+//