diff --git a/FormalGrammars.cabal b/FormalGrammars.cabal --- a/FormalGrammars.cabal +++ b/FormalGrammars.cabal @@ -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: + + . 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 - preprint: - @ - . - @ - 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. - - @ - . - @ - 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. - - @ - . - @ - 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 diff --git a/FormalLanguage/CFG/Grammar/Types.hs b/FormalLanguage/CFG/Grammar/Types.hs --- a/FormalLanguage/CFG/Grammar/Types.hs +++ b/FormalLanguage/CFG/Grammar/Types.hs @@ -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 } diff --git a/FormalLanguage/CFG/Grammar/Util.hs b/FormalLanguage/CFG/Grammar/Util.hs --- a/FormalLanguage/CFG/Grammar/Util.hs +++ b/FormalLanguage/CFG/Grammar/Util.hs @@ -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? diff --git a/FormalLanguage/CFG/Outside.hs b/FormalLanguage/CFG/Outside.hs --- a/FormalLanguage/CFG/Outside.hs +++ b/FormalLanguage/CFG/Outside.hs @@ -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. diff --git a/FormalLanguage/CFG/Parser.hs b/FormalLanguage/CFG/Parser.hs --- a/FormalLanguage/CFG/Parser.hs +++ b/FormalLanguage/CFG/Parser.hs @@ -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 -- | diff --git a/FormalLanguage/CFG/PrettyPrint/ANSI.hs b/FormalLanguage/CFG/PrettyPrint/ANSI.hs --- a/FormalLanguage/CFG/PrettyPrint/ANSI.hs +++ b/FormalLanguage/CFG/PrettyPrint/ANSI.hs @@ -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) diff --git a/FormalLanguage/CFG/TH.hs b/FormalLanguage/CFG/TH.hs --- a/FormalLanguage/CFG/TH.hs +++ b/FormalLanguage/CFG/TH.hs @@ -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 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 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@. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/ diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 ------- diff --git a/tests/parsing.gra b/tests/parsing.gra --- a/tests/parsing.gra +++ b/tests/parsing.gra @@ -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} +//