FormalGrammars 0.0.0.2 → 0.2.0.0
raw patch · 23 files changed
+2110/−435 lines, 23 filesdep +FormalGrammarsdep +PrimitiveArraydep +semigroupsdep −repadep ~ADPfusiondep ~HaTeXdep ~ansi-wl-pprintnew-component:exe:NeedlemanWunschFGnew-component:exe:NussinovFG
Dependencies added: FormalGrammars, PrimitiveArray, semigroups
Dependencies removed: repa
Dependency ranges changed: ADPfusion, HaTeX, ansi-wl-pprint, base, bytestring, data-default, lens, mtl, parsers, text, transformers, trifecta, unordered-containers, vector
Files
- FormalGrammars.cabal +213/−40
- FormalLanguage.hs +8/−6
- FormalLanguage/CFG.hs +8/−1
- FormalLanguage/CFG/Grammar.hs +218/−49
- FormalLanguage/CFG/Grammar/Types.hs +175/−0
- FormalLanguage/CFG/Grammar/Util.hs +116/−0
- FormalLanguage/CFG/Outside.hs +148/−0
- FormalLanguage/CFG/Parser.hs +312/−30
- FormalLanguage/CFG/PrettyPrint.hs +6/−2
- FormalLanguage/CFG/PrettyPrint/ANSI.hs +76/−16
- FormalLanguage/CFG/PrettyPrint/Haskell.hs +53/−43
- FormalLanguage/CFG/PrettyPrint/LaTeX.hs +7/−6
- FormalLanguage/CFG/QQ.hs +90/−0
- FormalLanguage/CFG/QuickCheck.hs +0/−4
- FormalLanguage/CFG/TH.hs +309/−161
- GrammarPP.hs +0/−67
- README.md +14/−0
- changelog +0/−10
- changelog.md +24/−0
- src/GrammarPP.hs +66/−0
- src/NeedlemanWunsch.hs +104/−0
- src/Nussinov.hs +122/−0
- tests/parsing.gra +41/−0
FormalGrammars.cabal view
@@ -1,17 +1,17 @@ name: FormalGrammars-version: 0.0.0.2-author: Christian Hoener zu Siederdissen, 2013-copyright: Christian Hoener zu Siederdissen, 2013-homepage: http://www.tbi.univie.ac.at/~choener/gramprod/-maintainer: choener@tbi.univie.ac.at+version: 0.2.0.0+author: Christian Hoener zu Siederdissen, 2013-2015+copyright: Christian Hoener zu Siederdissen, 2013-2015+homepage: http://www.bioinf.uni-leipzig.de/Software/gADP/+maintainer: choener@bioinf.uni-leipzig.de category: Formal Languages, Bioinformatics license: GPL-3 license-file: LICENSE build-type: Simple stability: experimental-cabal-version: >= 1.6.0-synopsis:- (Context-free) grammars in formal language theory+cabal-version: >= 1.10.0+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@@ -19,8 +19,13 @@ such grammars. . Grammars can be defined in a small domain-specific language- that is very close to typical CFG notation.+ that is very close to typical CFG notation. The DSL parser can+ easily be extended. Grammar products, for example, are+ implemented as a single additional sub-parser. .+ This library also provides the machinery that transforms an+ Inside grammar into the corresponding Outside grammar.+ . In addition, TemplateHaskell and QuasiQuoting functionality allow embedding thusly defined grammars in Haskell programs. ADPfusion then turns such a grammar into an efficient dynamic@@ -33,64 +38,232 @@ . . .- Formal background can be found in two papers:+ .+ Formal background can be found in these papers:+ . @- Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler- Product Grammars for Alignment and Folding- submitted+ 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> @- and+ . @- Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler- How to Multiply Dynamic Programming Algorithms- Brazilian Symposium on Bioinformatics (BSB 2013)- Lecture Notes in Bioinformatics 8213, Springer, Heidelberg+ 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.+ @+ . Extra-Source-Files:- changelog+ README.md+ 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 && < 5 ,- ADPfusion >= 0.2.0.3 ,- ansi-wl-pprint >= 0.6 ,- bytestring >= 0.10 ,- containers ,- data-default >= 0.5 ,- HaTeX ,- lens >= 3.9 ,- mtl ,- parsers >= 0.9 ,- repa >= 3.2 ,- template-haskell ,- text ,- transformers >= 0.3 ,- trifecta >= 1.2 ,- unordered-containers >= 0.2 ,- vector >= 0.10+ build-depends: base >= 4.7 && < 4.9+ , ADPfusion == 0.4.0.*+ , ansi-wl-pprint == 0.6.7.*+ , bytestring == 0.10.*+ , containers+ , data-default == 0.5.*+ , HaTeX == 3.16.*+ , lens == 4.*+ , mtl == 2.*+ , parsers >= 0.12 && < 0.13+ , PrimitiveArray == 0.6.0.*+ , semigroups >= 0.16 && < 0.17+ , template-haskell+ , text == 1.*+ , transformers >= 0.3 && < 0.5+ , trifecta == 1.5.*+ , unordered-containers == 0.2.*+ , vector == 0.10.* exposed-modules: FormalLanguage FormalLanguage.CFG FormalLanguage.CFG.Grammar+ FormalLanguage.CFG.Grammar.Types+ FormalLanguage.CFG.Grammar.Util+ FormalLanguage.CFG.Outside FormalLanguage.CFG.Parser FormalLanguage.CFG.PrettyPrint FormalLanguage.CFG.PrettyPrint.ANSI FormalLanguage.CFG.PrettyPrint.Haskell FormalLanguage.CFG.PrettyPrint.LaTeX- FormalLanguage.CFG.QuickCheck+ FormalLanguage.CFG.QQ+-- FormalLanguage.CFG.QuickCheck FormalLanguage.CFG.TH+ default-language:+ Haskell2010+ default-extensions: FlexibleContexts+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , NamedFieldPuns+ , NoMonomorphismRestriction+ , PatternGuards+ , RankNTypes+ , RecordWildCards+ , ScopedTypeVariables+ , StandaloneDeriving+ , TemplateHaskell+ , TupleSections+ , TypeFamilies+ , TypeOperators ghc-options:+ -O2 -funbox-strict-fields ++ -- A Simple pretty-printer for formal grammars. executable GrammarPP- build-depends:- cmdargs == 0.10.*+ build-depends: base+ , ansi-wl-pprint+ , cmdargs == 0.10.*+ , FormalGrammars+ hs-source-dirs:+ src+ default-language:+ Haskell2010+ default-extensions: DeriveDataTypeable+ , RecordWildCards main-is: GrammarPP.hs++++executable NussinovFG+ if flag(examples)+ buildable:+ True+ build-depends: base+ , ADPfusion+ , FormalGrammars+ , PrimitiveArray+ , template-haskell+ , vector+ else+ buildable:+ False+ hs-source-dirs:+ src+ main-is:+ Nussinov.hs+ default-language:+ Haskell2010+ default-extensions: BangPatterns+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , QuasiQuotes+ , TemplateHaskell+ , TypeFamilies+ , TypeOperators+ ghc-options:+ -O2+ -fcpr-off+ -funbox-strict-fields+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ if flag(debug)+ ghc-options:+ -ddump-to-file+ -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:+ True+ build-depends: base+ , ADPfusion+ , containers+ , FormalGrammars+ , PrimitiveArray+ , template-haskell+ , vector+ else+ buildable:+ False+ hs-source-dirs:+ src+ main-is:+ NeedlemanWunsch.hs+ default-language:+ Haskell2010+ default-extensions: BangPatterns+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , QuasiQuotes+ , TemplateHaskell+ , TypeFamilies+ , TypeOperators+ ghc-options:+ -O2+ -fcpr-off+ -funbox-strict-fields+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -rtsopts+ if flag(debug)+ ghc-options:+ -ddump-to-file+ -ddump-simpl+ -ddump-stg+ -dsuppress-all+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3+ -fllvm-tbaa++ source-repository head type: git
FormalLanguage.hs view
@@ -1,11 +1,13 @@ module FormalLanguage- ( module FormalLanguage.CFG.Grammar- , module FormalLanguage.CFG.Parser+ ( module FormalLanguage.CFG ) where+-- ( module FormalLanguage.CFG.Grammar+-- , module FormalLanguage.CFG.Outside+-- , module FormalLanguage.CFG.Parser+-- ) where -import FormalLanguage.CFG.Grammar-import FormalLanguage.CFG.PrettyPrint.ANSI-import FormalLanguage.CFG.PrettyPrint.LaTeX-import FormalLanguage.CFG.Parser+import FormalLanguage.CFG+--import FormalLanguage.CFG.Outside+--import FormalLanguage.CFG.Parser
FormalLanguage/CFG.hs view
@@ -1,2 +1,9 @@ -module FormalLanguage.CFG where+module FormalLanguage.CFG+ ( module FormalLanguage.CFG.QQ+ , module FormalLanguage.CFG.TH+ ) where++import FormalLanguage.CFG.QQ+import FormalLanguage.CFG.TH+
FormalLanguage/CFG/Grammar.hs view
@@ -1,13 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-} -- | The basic data types for formal languages up to and including context-free -- grammars.@@ -24,20 +14,157 @@ -- BIGTODO @E _@ are actually the "None" thing in ADPfusion; while normal -- epsilons are just terminals. -module FormalLanguage.CFG.Grammar where+module FormalLanguage.CFG.Grammar+ ( module FormalLanguage.CFG.Grammar.Types+ , module FormalLanguage.CFG.Grammar.Util+ ) where -import Control.Applicative-import Control.Lens-import Data.Default-import Data.Foldable-import Data.Set (Set)-import Prelude hiding (all)-import qualified Control.Lens.Indexed as Lens-import qualified Data.Set as S-import Data.List (sort,nub)+import FormalLanguage.CFG.Grammar.Types+import FormalLanguage.CFG.Grammar.Util +{-+import Data.List (partition,sort,nub)+import Data.Monoid+-} +{-++-- | A grammar with normalized start and epsilon symbols (i) has a start+-- symbol, whose RHSs only point to single syntactic variables. (ii) It has+-- terminating rules only when the single RHS symbol is a real epsilon symbol.++normalizeStartEpsilon :: Grammar -> Grammar+normalizeStartEpsilon g = gE+ -- good start rules go from the start symbol to a single syntactic+ -- symbol. It should not be the start symbol.+ where srs = [r | r<-g^..rules.folded , r^.lhs == g^.start]+ (gsr,bsr) = partition goodStartRule srs+ goodStartRule (Rule _ _ [r]) | isSyntactic r && r /= g^.start = True+ goodStartRule _ = False+ -- now we need to process the start rules. We create a fresh synvar,+ -- and the corresponding rules.+ d = dim g+ s = freshStartSymbol g+ sf = freshStartFun g+ srs' = [Rule s (replicate d sf) [r^.lhs] | r<-srs]+ gS = if null bsr+ then g+ else (g & rules %~ S.union (S.fromList srs')) & start .~ s -- otherwise, add new rules, set new start symbol+ -- good epsilon rules go from a syntactic variable directly to epsilon+ -- with no additional symbols on the RHS.+ ers = [r | r<-gS^..rules.folded, any isEpsilon (r^.rhs)]+ (ger,ber) = partition goodEpsilonRule ers+ goodEpsilonRule (Rule _ _ [r]) | isEpsilon r = True+ goodEpsilonRule _ = False+ -- same for the epsilon rules+ e = freshTermSynVar gS+ ef = freshTermFun gS+ ers' = concat [ [ Rule e (replicate d ef) [r]+ , Rule l f (rsl++[e]++rsr) ]+ | (Rule l f rs') <- ers+ , let (rsl,(r:rsr)) = span (not . isEpsilon) rs'+ ]+ gE = if null ber+ then gS+ else (gS & rules %~ (S.\\ S.fromList ers)) & rules %~ S.union (S.fromList ers') -- otherwise, replace old rules++-- | Given a grammar, generate a fresh start syntactic variable with a name+-- that is not "too weird". Also transfers any index structure to the start+-- symbol.+--+-- TODO if indices are correctly transferred needs be closely checked.++freshStartSymbol :: Grammar -> Symbol+freshStartSymbol g+ | d == 0 = error "zero-dim grammar"+ | otherwise = zipWith SynVar (replicate d x) ix+ where ss = ["S"] ++ (map (++"'") $ g^..start.folded.name) ++ map (\i -> "S" ++ show i) [1 :: Int ..]+ x = head $ dropWhile (`M.member` (g^.synvars)) ss+ d = dim g+ ix :: [[Index]]+ ix = g^..start.folded.index++-- | Given a grammar, generate a fresh terminating syntactic variable (that+-- only traverses to @Epsilon@ rules), that is not "too weird".++freshTermSynVar :: Grammar -> Symbol+freshTermSynVar g+ | d == 0 = error "zero-dim grammar"+ | otherwise = replicate d (SynVar e [])+ where es = ["E"] ++ map (\i -> "E" ++ show i) [1 :: Int .. ]+ e = head $ dropWhile (`M.member` (g^.synvars)) es+ d = dim g++-- | Create a fresh start function symbol.++freshStartFun :: Grammar -> String+freshStartFun g+ | S.null ks = error "no rules in grammar?"+ | otherwise = f+ where ks = S.fromList $ g^..rules.folded.attr.folded+ fs = ["fS"] ++ map (\i -> "fS" ++ show i) [1::Int ..]+ f = head $ dropWhile (`S.member` ks) fs++-- | Create a fresh terminating transition function symbol++freshTermFun :: Grammar -> String+freshTermFun g+ | S.null ks = error "no rules in grammar?"+ | otherwise = f+ where ks = S.fromList $ g^..rules.folded.attr.folded+ fs = ["fE"] ++ map (\i -> "fE" ++ show i) [1::Int ..]+ f = head $ dropWhile (`S.member` ks) fs++-- | Collect all terminal symbols from the rules (for cfg's it's not really+-- needed to include the lhs).++grammarTerminals :: Grammar -> [Symbol]+grammarTerminals g = nub . sort . filter isTerminal $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded)++-- | Collect all non-terminal symbols from the rules.+--+-- TODO WARNING: Problems handling syn-terms in outside grammars.++grammarSynVars :: Grammar -> [Symbol]+grammarSynVars g = nub . sort . filter isSyntactic $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded)++-}++++++++++++++++++++++++++++++++++{-+ -- * Basic data types for formal grammars. -- | Grammar indices are enumerable objects@@ -48,7 +175,7 @@ = Singular | IntBased Integer Integer -- current index, maximum index -- | Enumerated String [String]- deriving (Eq,Ord,Show)+ deriving (Eq,Ord,Show,Typeable,Data) _IntBased :: Prism' Enumerable (Integer,Integer) _IntBased = prism (uncurry IntBased) $ f where@@ -68,18 +195,27 @@ -- TODO write Eq,Ord by hand. Fail with error if Enumerable is not equal (this -- should actually be caught in the combination operations). +-- | 'T' – A terminal symbol (excluding epsilon)+--+-- 'N' – A non-terminal symbol (again, excluding non-terminal epsilons)+--+-- 'E' – Epsilon characters, may be named differently+ data TN where- -- | A terminal symbol (excluding epsilon) T :: String -> TN- -- | A non-terminal symbol (again, excluding non-terminal epsilons) N :: String -> Enumerable -> TN- -- | Epsilon characters, may be named differently E :: TN -deriving instance Show TN-deriving instance Eq TN-deriving instance Ord TN+deriving instance Show TN+deriving instance Eq TN+deriving instance Ord TN+deriving instance Typeable TN+deriving instance Data TN +isT = \case {T _ -> True; _ -> False}+isN = \case {N _ _ -> True; _ -> False}+isE = \case {E -> True; _ -> False}+ tnName :: Lens' TN String tnName f (T s ) = T <$> f s tnName f (N s e) = (\s' -> N s' e) <$> f s@@ -102,23 +238,43 @@ enumed = _N . _2 --- | A complete grammatical symbol is multi-dimensional with 0.. dimensions.+-- | Is a symbol of @Outside@ or @Inside@ type? -newtype Symb = Symb { getSymbs :: [TN] }+data InsideOutside = Inside | Outside+ deriving (Show,Eq,Ord,Typeable,Data) -deriving instance Show Symb-deriving instance Eq Symb-deriving instance Ord Symb+-- | A complete grammatical symbol is multi-dimensional with 0..+-- dimensions.+--+-- TODO we should expand this to three cases: (i) only terminals, (ii) only+-- syntactic variables, (iii) mixed cases +data Symb = Symb+ { inOut :: InsideOutside+ , getSymbs :: [TN]+ }++deriving instance Show Symb+deriving instance Eq Symb+deriving instance Ord Symb+deriving instance Typeable Symb+deriving instance Data Symb+ symb :: Lens' Symb [TN]-symb f (Symb xs) = Symb <$> f xs -- are we sure?+symb f (Symb io xs) = Symb io <$> f xs -- are we sure? +symbInOut :: Lens' Symb InsideOutside+symbInOut f (Symb io xs) = (`Symb` xs) <$> f io++sDim :: Symb -> Int+sDim = length . getSymbs+ type instance Index Symb = Int type instance IxValue Symb = TN -instance Applicative f => Ixed f Symb where- ix k f (Symb xs) = Symb <$> ix k f xs+instance Ixed Symb where+ ix k f (Symb io xs) = Symb io <$> ix k f xs {-# INLINE ix #-} -- | A production rule goes from a left-hand side (lhs) to a right-hand side@@ -132,7 +288,7 @@ , _fun :: [String] -- Fun , _rhs :: [Symb] }- deriving (Eq,Ord,Show)+ deriving (Eq,Ord,Show,Typeable,Data) makeLenses ''Rule @@ -151,14 +307,20 @@ data Grammar = Grammar { _tsyms :: Set Symb , _nsyms :: Set Symb+ , _nIsms :: Set Symb -- in case of an outside grammar, this contains the inside syntactic variables that now act as "kind-of" terminals , _epsis :: Set TN , _rules :: Set Rule , _start :: Maybe Symb , _name :: String- } deriving (Show)+ } deriving (Show,Data,Typeable) makeLenses ''Grammar +-- | Determines if this is an outside grammar++isOutsideGrammar :: Grammar -> Bool+isOutsideGrammar g = anyOf folded (\(Symb io _) -> io==Outside) $ g^.nsyms+ -- | the dimension of the grammar. Grammars with no symbols have dimension 0. gDim :: Grammar -> Int@@ -167,14 +329,18 @@ | Just (x,_) <- S.minView (g^.tsyms) = length $ x^.symb | otherwise = 0 +-- | Helper function giving the grammar name. Will add an @Outside@ prefix,+-- where necessary. +grammarName :: Grammar -> String+grammarName g = if isOutsideGrammar g then "Outside" ++ g^.name else "" ++ g^.name -- * Helper functions on rules and symbols. -- | Symb is completely in terminal form. isSymbT :: Symb -> Bool-isSymbT (Symb xs) = allOf folded tTN xs && anyOf folded (\case (T _) -> True ; _ -> False) xs+isSymbT (Symb io xs) = allOf folded tTN xs && anyOf folded (\case (T _) -> True ; _ -> False) xs tTN :: TN -> Bool tTN (T _ ) = True@@ -182,12 +348,12 @@ tTN (N _ _) = False isSymbE :: Symb -> Bool-isSymbE (Symb xs) = allOf folded (\case E -> True ; _ -> False) xs+isSymbE (Symb io xs) = allOf folded (\case E -> True ; _ -> False) xs -- | Symb is completely in non-terminal form. isSymbN :: Symb -> Bool-isSymbN (Symb xs) = allOf folded nTN xs && anyOf folded (\case (N _ _) -> True ; _ -> False) xs+isSymbN (Symb io xs) = allOf folded nTN xs && anyOf folded (\case (N _ _) -> True ; _ -> False) xs {- -- | Generalized non-terminal symbol with at least one non-terminal Symb.@@ -212,15 +378,6 @@ -- TODO maybe restrict those to epsilon-type terminals in generalized -- non-terminals. --- | Left-linear grammars have at most one non-terminal on the RHS. It is the--- first symbol.--isLeftLinear :: Grammar -> Bool-isLeftLinear g = allOf folded isll $ g^.rules where- isll :: Rule -> Bool- isll (Rule l _ []) = isSymbN l- isll (Rule l _ rs) = isSymbN l && (allOf folded (not . isSymbN) $ tail rs) -- at most one non-terminal- -- | Right-linear grammars have at most one non-terminal on the RHS. It is the -- last symbol. @@ -287,9 +444,21 @@ collectSymbN :: Grammar -> [Symb] collectSymbN g = nub . sort . filter isSymbN $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded) +-- | Collect the syntactic variable symbols for either inside or outside,+-- depending on the grammar++collectInOutSymbN :: Grammar -> [Symb]+collectInOutSymbN g = filter f xs where+ xs = collectSymbN g+ f (Symb Outside _) = isO+ f (Symb Inside _) = not isO+ isO = isOutsideGrammar g+ -- | Collect all terminal symbols from the rules (for cfg's it's not really -- needed to include the lhs). collectSymbT :: Grammar -> [Symb] collectSymbT g = nub . sort . filter isSymbT $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded)++-}
+ FormalLanguage/CFG/Grammar/Types.hs view
@@ -0,0 +1,175 @@++-- | The data types that define a CFG.++module FormalLanguage.CFG.Grammar.Types where++import Control.Lens hiding (Index,index)+import Data.Default+import Data.Map.Strict (Map)+import Data.Semigroup+import Data.Set (Set)+import Data.String+import qualified Data.Map.Strict as M+import qualified Data.Set as S++-- | Encode the index of the syntactic or terminal variable.+--+-- In case of grammar-based indexing, keep @indexRange@ empty. The+-- @indexStep@ keeps track of any @+k@ / @-k@ given in the production+-- rules.+--+-- We allow indexing terminals now, too. When glueing together terminals,+-- one might want to be able to differentiate between terminals.++data Index = Index+ { _indexVar :: String+ , _indexRange :: [String]+ , _indexStep :: Int+ }+ -- 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)++makeLenses ''Index++++-- | Newtype wrapper for symbol names.++newtype SymbolName = SymbolName { _getSteName :: String }+ deriving (Show,Eq,Ord,IsString)++makeLenses ''SymbolName++++-- | The tape, a terminal operates on. Terminals on different tapes could+-- still have the same @SymbolName@ but different type and input!++newtype Tape = Tape { _getTape :: Int }+ deriving (Show,Eq,Ord,Enum,Num)++makeLenses ''Tape++++-- | Symbols, potentially with an index or more than one.++data SynTermEps+ -- | Syntactic variables.+ = SynVar+ { _name :: SymbolName+ , _index :: [Index]+ }+ -- syntactic terminals. Inside-synvars used in an outside context.+ | SynTerm+ { _name :: SymbolName+ , _index :: [Index]+ }+ -- | Regular old terminal symbol -- reads stuff from the input.+ | Term+ { _name :: SymbolName+ , _index :: [Index]+ }+ -- | This sym denotes the case, where we have an @Deletion@ terminal, i.e.+ -- something is matched to nothing. This is actually just a regular+ -- terminal symbol, we just treat it differently.+ | Deletion+ -- | Finally, a real epsilon. Again, these are somewhat regular terminal+ -- 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)++makeLenses ''SynTermEps+makePrisms ''SynTermEps++++-- | The length of the list encodes the dimension of the symbol. Forms a monoid+-- over dimensional concatenation.++newtype Symbol = Symbol { _getSymbolList :: [SynTermEps] }+ deriving (Show,Eq,Ord,Monoid,Semigroup)++makeLenses ''Symbol++++-- | The name of an attribute function++newtype AttributeFunction = Attr { _getAttr :: String }+ deriving (Show,Eq,Ord,IsString)++makeLenses ''AttributeFunction++++-- | Production rules for at-most CFGs.++data Rule = Rule+ { _lhs :: Symbol -- ^ the left-hand side of the rule+ , _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)++makeLenses ''Rule++++data DerivedGrammar+ = Inside+ | Outside String+ deriving (Show,Eq)++isOutside (Outside _) = True+isOutside _ = False++instance Default DerivedGrammar where+ def = Inside++makeLenses ''DerivedGrammar++-- | Complete descrition of a grammar. In principle it would be enough to hold+-- @_rules@ and the @_start@ symbol name. We also store dimensionless names for+-- syntactiv variables, and terminals. This makes certain checks easier or+-- possible.+--+-- We store all single-tape symbol names dimensionless. This means that, for+-- terminals, symbols with the same name have the same tape. This is slightly+-- inconvenient for special applications (say Protein-DNA alignment) but one+-- can easily rename terminals.+--+-- TODO better way to handle indexed symbols?++data Grammar = Grammar+ { _synvars :: Map SymbolName SynTermEps -- ^ regular syntactic variables, without dimension+ , _synterms :: Map SymbolName SynTermEps -- ^ Terminal synvars are somewhat weird. They are used in Outside grammars, and hold previously calculated inside values.+ , _termvars :: Map SymbolName SynTermEps -- ^ regular terminal symbols+ , _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+ , _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)++instance Default Grammar where+ def = Grammar+ { _synvars = M.empty+ , _synterms = M.empty+ , _termvars = M.empty+ , _outside = def+ , _rules = S.empty+ , _start = mempty+ , _params = M.empty+ , _grammarName = ""+ , _write = False+ }++makeLenses ''Grammar+
+ FormalLanguage/CFG/Grammar/Util.hs view
@@ -0,0 +1,116 @@++-- | Collection of small helper functions for grammars.++module FormalLanguage.CFG.Grammar.Util where++import Control.Lens hiding (Index,index)+import Data.Tuple (swap)+import Data.List (sort,nub)++import FormalLanguage.CFG.Grammar.Types++++-- | @Term@, @Deletion@, and @Epsilon@ all count as terminal symbols.++isTerminal :: Symbol -> Bool+isTerminal = allOf folded (\case (SynVar _ _) -> False; (SynTerm _ _) -> False; _ -> True) . _getSymbolList++-- | @Term@, and @Epsilon@ are terminal symbols that can be bound.++isBindableTerminal :: Symbol -> Bool+isBindableTerminal = allOf folded (\case (Term _ _) -> True; _ -> False) . _getSymbolList++-- | Only @SynVar@s are non-terminal.++isSyntactic :: Symbol -> Bool+isSyntactic = allOf folded (\case (SynVar _ _) -> True; _ -> False) . _getSymbolList++-- | Is this a syntactic terminal symbol?++isSynTerm :: Symbol -> Bool+isSynTerm = allOf folded (\case (SynTerm _ _) -> True; _ -> False) . _getSymbolList++-- | Epsilon-only symbols.++isEpsilon :: Symbol -> Bool+isEpsilon = allOf folded (\case Epsilon -> True; _ -> False) . _getSymbolList++-- | Dimension of the grammar. Rather costly, because we check for dimensional+-- consistency.++dim :: Grammar -> Int+dim g+ | null ls = error "no terminal symbol in grammar"+ | all (l==) ls = l+ | otherwise = error "inconsistent dimensionality"+ where ls@(l:_) = map (length . _getSymbolList) $ g^.rules.folded.rhs++-- | Extract single-tape terminals together with their tape dimension.++uniqueTermsWithTape :: Grammar -> [(SynTermEps , Tape)]+uniqueTermsWithTape = uniqueSynTermEpsWithTape . uniqueTerminalSymbols++-- | Extract single-tape bindable terminals together with their tape dimension.++uniqueBindableTermsWithTape :: Grammar -> [(SynTermEps , Tape)]+uniqueBindableTermsWithTape = uniqueSynTermEpsWithTape . uniqueBindableTerminalSymbols++-- |++uniqueSynVarsWithTape :: Grammar -> [(SynTermEps, Tape)]+uniqueSynVarsWithTape = uniqueSynTermEpsWithTape . uniqueSyntacticSymbols++-- |++uniqueSynTermsWithTape :: Grammar -> [(SynTermEps, Tape)]+uniqueSynTermsWithTape = uniqueSynTermEpsWithTape . uniqueSynTermSymbols++-- |++uniqueSynTermEpsWithTape :: [Symbol] -> [(SynTermEps, Tape)]+uniqueSynTermEpsWithTape = nub . sort -- cleanup+ . map swap -- swap index to second position+ . concatMap (zip [0..] . _getSymbolList) -- combine single-tape STEs with tape indices++-- | Return the nub list of terminal symbols. This includes @Deletion@+-- symbols, and might not be what you want. Check+-- 'uniqueBindableTerminalSymbols' too!++uniqueTerminalSymbols :: Grammar -> [Symbol]+uniqueTerminalSymbols = nub . sort . filter isTerminal . toListOf (rules.folded.rhs.folded)++-- |++uniqueBindableTerminalSymbols :: Grammar -> [Symbol]+uniqueBindableTerminalSymbols = nub . sort . filter isBindableTerminal . toListOf (rules.folded.rhs.folded)++-- | Return the nub list of syntactic symbols.++uniqueSyntacticSymbols :: Grammar -> [Symbol]+uniqueSyntacticSymbols g = nub . sort . filter isSyntactic $ g^..rules.folded.lhs++-- | Return the nub list of syntactic terminals.++uniqueSynTermSymbols :: Grammar -> [Symbol]+uniqueSynTermSymbols = nub . sort . filter isSynTerm . toListOf (rules.folded.rhs.folded)++-- |+--+-- TODO Currently a stub (original is in @.Grammar@ still. Want to have it+-- monadically, as the code is a mess.++normalizeStartEpsilon :: Grammar -> Grammar+normalizeStartEpsilon = error "normalizeStartEpsilon: (re-)write me"++++-- | Left-linear grammars have at most one non-terminal on the RHS. It is the+-- first symbol.++isLeftLinear :: Grammar -> Bool+isLeftLinear g = allOf folded isll $ g^.rules where+ isll :: Rule -> Bool+ isll (Rule l _ []) = isSyntactic l+ isll (Rule l _ rs) = isSyntactic l && (allOf folded (not . isSyntactic) $ tail rs) -- at most one non-terminal+
+ FormalLanguage/CFG/Outside.hs view
@@ -0,0 +1,148 @@++-- | This module provides the functionality for automatic calculation of+-- outside grammars from their inside progenitors.+--+-- TODO If we already have an inside rule: @S -> A | B | C@ with inside+-- syntactic variable @S@ whose sole+-- purpose is to collect results, than we don't need an extra symbol for+-- Outside. What happens if this is not the case?++module FormalLanguage.CFG.Outside where++import Data.List (inits,tails,nub,sort)+import Control.Lens hiding (Index,outside)+import qualified Data.Set as S+import Data.Set (Set)+import Data.Maybe (catMaybes)+import Data.Default+import qualified Data.Map as M++import FormalLanguage.CFG.Grammar++++-- | Given an inside grammar, return @Just@ an outside grammar, otherwise+-- return @Nothing@.++outsideFromInside :: Grammar -> Maybe Grammar+outsideFromInside g+ | Outside _ <- g^.outside = Nothing+ -- TODO in theory, we should now check if we are at most context-free.+ -- (linear grammars are context-free as well).+ -- not $ isContextFree g = Nothing+ | otherwise = Just $ Grammar {..}+ where _outside = Outside (g^.grammarName)+ _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) ]+ _start = case (findStartSymbols $ g^.rules) of+ [s] -> s+ xs -> error $ "more than one epsilon rule in the source: " ++ show xs+ _write = False+ epsfun = case (filter (isEpsilon . head . _rhs) $ g^..rules.folded) of+ [] -> error "grammar does not terminate with an epsilon"+ (Rule _ f _ : _) -> f+ epsrule = genEpsilonRule epsfun (g^.start)++-- | Given a single inside rule, create the outside rules.+--+-- TODO rules with only terminals on the RHS may need some consideration+-- (this INCLUDES epsilon rules!)+--+-- TODO How do I know what an epsilon rule is? I might actually have to say+-- in the formal language... actually this might work. say @e@ is a free+-- variable, but terminal: @X -> e@ has the epsilon form @X -> e \eps@+-- because there are only "non-epsilon" rhs terminals -- we don't know yet+-- that @e@ is epsilon. This generates the outside rule @S -> e X*@ which+-- is what we want, except for the superfluous @e@ on the rhs. Because this+-- generates an algebra type that is incompatible with the inside version,+-- users should not do this. We are probably save, if all rules FROM the+-- start symbol are of the form @S -> A | B | C@ and all terminal ending+-- rules are of the form @A -> \eps@ (i.e. rewrite @A -> c@ to @A -> c E@+-- and have @E -> eps@.++genOutsideRules :: Rule -> [Rule]+genOutsideRules (Rule l f rs) = catMaybes $ zipWith go (inits rs) (init $ tails rs)+ where go xs (h:ys) -- @xs ++ [h] ++ ys@. We [h] the current element+ | isTerminal h = Nothing+ | 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+ | otherwise = s++-- | Helper function that turns an inside symbol into an outside symbol.+-- Simply by attaching a @'@ (prime) symbol.++outsideSymb :: Symbol -> Symbol+outsideSymb = over (getSymbolList . traverse . name . getSteName) (++"'")++-- | ++genEpsilonRule :: [AttributeFunction] -> Symbol -> Rule+genEpsilonRule epsfun s = Rule (outsideSymb s) epsfun [(Symbol $ replicate (length $ s^.getSymbolList) Epsilon)]++-- | ++findStartSymbols :: Set Rule -> [Symbol]+findStartSymbols rs = map (outsideSymb . _lhs) . filter (sing . _rhs) $ rs^..folded+ where sing [x] | isEpsilon x = True+ sing _ = False++-- | If necessary add a special "start" rule to the set of rules.++-- | Take a grammar and transform it into an outside grammar. If the given+-- grammar is already in outside form, the grammar is returned as is.++toOutside :: Grammar -> Grammar+toOutside g+ | Outside _ <- g^.outside = g+ | Just o <- outsideFromInside g = o+++{-++-- | Mechanically generate the @Outside@ grammar from a given @Inside@+-- grammar.+--+-- TODO clean up the resulting outside grammar where all symbols are killed+-- that are not needed. This means any syntactic variables from the inside+-- grammar, that are not used, are not retained. We need to consider+-- carefully if we should really do that, as we could just as well give all+-- symbols, making everything really mechanic in nature.++outsideFromInside :: Grammar -> Grammar+outsideFromInside g = Grammar term synv ins eps rls strt nm where+ term = g^.tsyms+ synv = S.fromList . filter (\(Symb io _) -> io==Outside) . filter isSymbN . nub $ (rls^..folded.lhs) ++ (rls^..folded.rhs.folded)+ ins = S.fromList . filter (\(Symb io _) -> io==Inside ) . filter isSymbN . nub $ (rls^..folded.rhs.folded)+ eps = g^.epsis+ rls = S.fromList . concatMap (outsideRules g) $ g^..rules.folded+ strt = Nothing -- TODO the outside version of the inside start?+ nm = (g^.name)++-- | Build the outside rules from inside ones.+--+-- TODO check wether the rule generation for the single terminal on the+-- right-hand side is correct.++outsideRules :: Grammar -> Rule -> [Rule]+outsideRules g (Rule l f [r]) | isSymbT r = [Rule (Symb Outside $ l^.symb) f [r]]+{-+outsideRules g (Rule l f [r]) | isSymbT r+ = let s = Symb Outside $ map (`N` Singular) n+ n = replicate (length $ l^.symb) "S"+ in [Rule s f [Symb Outside $ l^.symb]]+-}+outsideRules g (Rule l f r) =+ [ Rule i' f (p ++ [i'] ++ s)+ | (p,i,s) <- zip3 (init $ inits r) r (tail $ tails r)+ , isSymbN i+ , let i' = Symb Outside $ i^.symb+ ]++-}+
FormalLanguage/CFG/Parser.hs view
@@ -1,13 +1,3 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-} -- | We define a simple domain-specific language for context-free languages. --@@ -23,32 +13,319 @@ import Control.Applicative import Control.Arrow-import Control.Lens-import Control.Monad.Identity+import Control.Lens hiding (Index, outside)+import Control.Monad import Control.Monad.State.Class (MonadState (..))-import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict hiding (get) import Data.Default-import Data.Either-import Data.List (partition,sort,nub)-import Data.Maybe (catMaybes,isJust)-import Data.Tuple (swap)-import qualified Data.ByteString.Char8 as B+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Sequence (Seq)+import Debug.Trace import qualified Data.HashSet as H-import qualified Data.Map as M+import qualified Data.Map.Strict as M+import qualified Data.Sequence as Seq import qualified Data.Set as S-import Text.Parser.Expression-import Text.Parser.Token.Highlight+import System.IO.Unsafe (unsafePerformIO) import Text.Parser.Token.Style import Text.Printf import Text.Trifecta-import Text.Trifecta.Delta-import Text.Trifecta.Result+import qualified Text.PrettyPrint.ANSI.Leijen as AL+import Data.Monoid+import Text.Trifecta.Delta (Delta (Directed))+import Data.ByteString.Char8 (pack) -import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.Outside+import FormalLanguage.CFG.PrettyPrint.ANSI+-- testPrint = test >>= \z -> case z of {Just g -> mapM_ (printDoc . genGrammarDoc) g} +-- | The environment captures both the current grammar we work with+-- (@current@) as well as everything we have parsed until now (@env@).++data GrammarEnv = GrammarEnv+ { _current :: Grammar -- ^ The grammar declaration we currently evaluate+ , _env :: Map String Grammar -- ^ grammars within the environment+ , _emit :: Seq Grammar -- ^ sequence of grammars to emit (in order)+ , _verbose :: Bool -- ^ emit lots of informative messages+ }+ deriving (Show)++makeLenses ''GrammarEnv++instance Default GrammarEnv where+ def = GrammarEnv { _current = def+ , _env = def+ , _emit = def+ , _verbose = False+ }+++test = parseFromFile ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True}) "tests/parsing.gra"++++-- parse = parseString ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True})+parse = parseString ((evalStateT . runGrammarParser) (parseEverything empty) def) (Directed (pack "via QQ") (fromIntegral 0) 0 0 0)++-- | Parse everything in the grammar source. The additional argument, normally+-- @empty :: Alternative f a@, allows for providing additional parsing+-- capabilities -- e.g. for grammar products..++parseEverything :: Parse m () -> Parse m (Seq Grammar)+parseEverything ps = whiteSpace *> some (assign current def >> p) <* eof >> use emit+ where p = parseCommands <|> parseGrammar <|> parseOutside <|> parseNormStartEps <|> parseEmitGrammar <|> ps++-- | The basic parser, which generates a grammar from a description.++parseGrammar :: Parse m ()+parseGrammar = do+ 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.termvars <~ (M.fromList . fmap (_name &&& id)) <$> many parseTermDecl+ -- TODO current.epsvars <~ ...+ current.start <~ parseStartSym+ current.rules <~ S.fromList <$> 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++-- | Which of the intermediate grammar to actually emit as code or text in+-- TeX. Single line: @Emit: KnownGrammarName@++parseEmitGrammar :: Parse m ()+parseEmitGrammar = do+ reserve fgIdents "Emit:"+ g <- knownGrammarName+ v <- use verbose+ seq (unsafePerformIO $ if v then (printDoc . genGrammarDoc $ g) else return ())+ $ emit %= ( Seq.|> g) -- snoc the grammar++-- | Normalize start and epsilon rules in a known @Source:@, thereby+-- generating a new grammar.++parseNormStartEps :: Parse m ()+parseNormStartEps = do+ reserve fgIdents "NormStartEps:"+ n <- newGrammarName+ current.grammarName .= n+ reserve fgIdents "Source:"+ g <- (set grammarName n) <$> knownGrammarName <?> "known source grammar"+ reserve fgIdents "//"+ let h = normalizeStartEpsilon g+ v <- use verbose+ seq (unsafePerformIO $ if v then (printDoc . genGrammarDoc $ h) else return ())+ $ env %= M.insert n h++-- | Try to generate an outside grammar from an inside grammar. The @From:@+-- name is looked up in the environment.+--+-- @+-- Outside: NAME+-- From: (inside)NAME+-- //+-- @++parseOutside :: Parse m ()+parseOutside = do+ reserve fgIdents "Outside:"+ n <- newGrammarName+ reserve fgIdents "Source:"+ g <- knownGrammarName <?> "known source grammar"+ guard (not . isOutside $ g^.outside) <?> "source already is an outside grammar"+ reserve fgIdents "//"+ let h = set grammarName n $ toOutside g+ current .= h+ v <- use verbose+ seq (unsafePerformIO $ if v then (printDoc . genGrammarDoc $ h) else return ())+ $ env %= M.insert n h++-- | Some additional commands that change the parsing state.+--+-- TODO @MonoidOfPairs@ should generate an adapter function that turns any+-- 2-tape eval function into its k-tape version. This means collecting all+-- name pairs, then emitting the corresponding adapter. We'll also need+-- a monoidal function for combining pairs. (this is along the lines of+-- sum-of-pairs).++parseCommands :: Parse m ()+parseCommands = help <|> vrbose+ where help = reserve fgIdents "Help"+ vrbose = reserve fgIdents "Verbose" >> verbose .= True++++-- * Helper parsers++-- |++fgIdents = set styleReserved rs emptyIdents+ where rs = H.fromList [ "Grammar:", "Outside:", "Source:", "NormStartEps:", "Emit:", "Help", "Verbose"+ , "N:", "Y:", "T:", "S:", "->", "<<<", "-", "e", "ε"+ ]++-- |++newGrammarName :: Parse m String+newGrammarName = flip (<?>) "grammar name previously declared!" $ do+ n <- ident fgIdents+ e <- get+ let g = M.lookup n $ e^.env+ when (isJust g) $ unexpected "previously declared grammar name"+ return n++-- |++knownGrammarName :: Parse m Grammar+knownGrammarName = try $ do+ n <- ident fgIdents+ e <- get+ let g = M.lookup n $ e^.env+ when (isNothing g) $ unexpected "known source grammar"+ return $ fromJust g++-- | 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)++-- | Parses a syntactic terminal declaration; an inside syntactic variable in an outside context.++parseSynTermDecl :: EvalReq -> Parse m SynTermEps+parseSynTermDecl e = do+ reserve fgIdents "Y:"+ SynTerm <$> (ident fgIdents <?> "syntactic variable name") <*> (option [] $ parseIndex e)++-- |++parseTermDecl :: Parse m SynTermEps+parseTermDecl =+ (reserve fgIdents "T:" >> Term <$> (ident fgIdents <?> "terminal name") <*> pure [])+-- <|>+-- (reserve fgIdents "E:" >> Epsilon <$> (ident fgIdents <?> "epsilon terminal name"))++-- | The syntactic variable here needs to either have no index at all, have+-- a grammar-based index, or have a fully calculated index.++parseStartSym :: Parse m Symbol+parseStartSym+ = (runUnlined $ reserve fgIdents "S:" *> knownSynVar EvalGrammar)+ <* someSpace++-- |++data EvalReq = EvalFull | EvalGrammar | EvalSymb++-- |++knownSynVar :: EvalReq -> Stately m Symbol+knownSynVar e = Symbol <$> do+ ((:[]) <$> sv) <|> (brackets $ 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++-- |++knownSynTerm :: EvalReq -> Stately m Symbol+knownSynTerm e = Symbol <$> do+ ((:[]) <$> sv) <|> (brackets $ commaSep sv)+ where sv = flip (<?>) "known syntactic terminal" . try $ do+ s <- ident fgIdents+ use (current . synterms . at s) >>= guard . isJust+ i <- option [] $ parseIndex e+ return $ SynVar s i++-- |++parseIndex :: EvalReq -> Stately m [Index]+parseIndex e = braces $ commaSep ix where+ ix = (\v -> Index v [] 0) <$> some alphaNum++-- |++knownTermVar :: EvalReq -> Stately m Symbol+knownTermVar e = Symbol <$> do+ ((:[]) <$> (eps <|> tv)) <|> (brackets $ commaSep (del <|> eps <|> tv))+ 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 []+ {-+ if isJust t+ then return $ Term i []+ else return $ Epsilon+ -}+ del = Deletion <$ reserve fgIdents "-"+ eps = Epsilon <$ (reserve fgIdents "e" <|> reserve fgIdents "ε")++-- | Parses an already known symbol, either syntactic or terminal.+--+--TODO Correctly parse inside-syntactics in outside grammars? Do we want+--this explicitly?++knownSymbol :: EvalReq -> Stately m Symbol+knownSymbol e = try (knownSynVar e) <|> try (knownSynTerm e) <|> knownTermVar e++-- |++parseRule :: Parse m Rule+parseRule = (runUnlined rule) <* someSpace+ where rule = Rule+ <$> knownSynVar EvalGrammar+ <* reserve fgIdents "->"+ <*> afun+ <* string "<<<" <* spaces+ <*> some syms+ afun = (:[]) <$> ident fgIdents+ syms = knownSymbol EvalSymb++-- |++type Parse m a = (TokenParsing m, MonadState GrammarEnv (Unlined m), MonadState GrammarEnv m, MonadPlus m) => m a++-- |++type Stately m a = (TokenParsing m, MonadState GrammarEnv m, MonadPlus m) => m a++-- |++newtype GrammarParser m a = GrammarParser { runGrammarParser :: StateT GrammarEnv m a }+ deriving+ ( Alternative+ , Applicative+ , Functor+ , MonadPlus+ , Monad+ , CharParsing+ , Parsing+ , MonadState GrammarEnv+ )++instance (MonadPlus m, CharParsing m) => TokenParsing (GrammarParser m) where+ someSpace = buildSomeSpaceParser (() <$ space) haskellCommentStyle++deriving instance MonadState GrammarEnv (Unlined (GrammarParser Parser))++++++{- data Enumerated = Sing | ZeroBased Integer@@ -82,6 +359,7 @@ reserveGI "Grammar:" _name :: String <- identGI _nsyms <- S.fromList . concat <$> many nts+ let _nIsms = S.empty _tsyms <- S.fromList . concat <$> many ts _epsis <- S.fromList <$> many epsP _start <- try (Just <$> startSymbol) <|> pure Nothing@@ -100,7 +378,7 @@ name :: String <- identGI -- TODO go and allow indexed NTs as start symbols, with one index given -- return $ nsym1 name Singular- return $ Symb [N name Singular]+ return $ Symb Inside [N name Singular] -- | The non-terminal declaration "NT: ..." returns a list of non-terms as -- indexed non-terminals are expanded.@@ -118,8 +396,8 @@ expandNT :: String -> Enumerated -> [Symb] expandNT name = go where- go Sing = [Symb [N name Singular]]- go (ZeroBased k) = [Symb [N name (IntBased z k)] | z <- [0..(k-1)]]+ go Sing = [Symb Inside [N name Singular]]+ go (ZeroBased k) = [Symb Inside [N name (IntBased z k)] | z <- [0..(k-1)]] --go (Enum es) = [Symb [N name (Enumerated z es )] | z <- es ] -- | Figure out if we are dealing with indexed (enumerable) non-terminals@@ -133,7 +411,7 @@ ts = do reserveGI "T:" n <- identGI- let z = Symb [T n]+ let z = Symb Inside [T n] tsys <>= S.singleton n return [z] @@ -189,7 +467,7 @@ ZeroBased m = (gs^.nsys) M.! s l :: Integer = (z+k) `mod` m in N s (IntBased l m)- buildRules j = Rule (Symb $ map (buildTNE j) lhs) [fun] (map (Symb . map (buildTNE j)) rhs)+ buildRules j = Rule (Symb Inside $ map (buildTNE j) lhs) [fun] (map (Symb Inside . map (buildTNE j)) rhs) data IndexedPreN = NotIndexed@@ -277,10 +555,11 @@ , MonadState GrammarState , TokenParsing , CharParsing- , Parsing , MonadTrans ) +deriving instance (Parsing m, MonadPlus m) => Parsing (GrammarParser m) -- Nominal role, ghc 7.8+ -- | Functions that parse using the 'GrammarParser' type Parse a = ( Monad m@@ -355,3 +634,6 @@ testGrammar asG = let (Success g) = testParsing in g++-}+
FormalLanguage/CFG/PrettyPrint.hs view
@@ -1,7 +1,11 @@ module FormalLanguage.CFG.PrettyPrint- ( renderLaTeX+ ( module FormalLanguage.CFG.PrettyPrint.ANSI+ , module FormalLanguage.CFG.PrettyPrint.Haskell+ , module FormalLanguage.CFG.PrettyPrint.LaTeX ) where -import FormalLanguage.CFG.PrettyPrint.LaTeX as LaTeX+import FormalLanguage.CFG.PrettyPrint.ANSI+import FormalLanguage.CFG.PrettyPrint.Haskell+import FormalLanguage.CFG.PrettyPrint.LaTeX
FormalLanguage/CFG/PrettyPrint/ANSI.hs view
@@ -1,29 +1,92 @@-{-# LANGUAGE PatternGuards #-} +-- |+--+-- TODO grammar-level indices should be colored red! also, make grammar+-- globally available (reader monad)+ module FormalLanguage.CFG.PrettyPrint.ANSI- ( grammarDoc- , rulesDoc- , printDoc- ) where+-- ( grammarDoc+-- , rulesDoc+-- , printDoc+-- , symbolDoc+-- ) where+ where -import Control.Lens+import Control.Lens hiding (outside,Index)+import Control.Monad.Reader+import Data.List (intersperse)+import Prelude hiding ((<$>))+import qualified Data.Map as M import qualified Data.Set as S import System.IO (stdout) import Text.PrettyPrint.ANSI.Leijen+import Data.Char (toUpper) import FormalLanguage.CFG.Grammar-import FormalLanguage.CFG.Parser+--import FormalLanguage.CFG.Parser +genGrammarDoc :: Grammar -> Doc+genGrammarDoc g = runReader (grammarDoc g) g++grammarDoc :: Grammar -> Reader Grammar Doc+grammarDoc g = do+ 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+ 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++rulesDoc :: [Rule] -> Reader Grammar [Doc]+rulesDoc rs = mapM ruleDoc rs++ruleDoc :: Rule -> Reader Grammar Doc+ruleDoc (Rule lhs fun rhs)+ = do l <- symbolDoc lhs+ rs <- fmap (intersperse (text " ")) . mapM 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 $ "-"++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+ sDoc s | s==0 = empty+ | 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++printDoc :: Doc -> IO ()+printDoc d = displayIO stdout (renderPretty 0.8 160 $ d <> linebreak)++-- testPrint = test >>= \z -> case z of {Just g -> mapM_ (printDoc . genGrammarDoc) g}++{- -- | Prettyprint a grammar ANSI-style. -- -- TODO Later on, it would be really nice to better align the LHS, fun, and RHS -- of the rules grammarDoc :: Grammar -> Doc-grammarDoc g = text "Grammar: " <$> indent 2 (ns <$> ts <$> es <$> ss <$> rs) <$> line where- ns = ind "non terminals:" 2 . vcat $ zipWith (\k z -> (fill 5 $ int k) <+> (symbolDoc z <+> (text . show $ z))) [1..] (g^..nsyms.folded)+grammarDoc g = text "Grammar: " <+> (text $ g^.name) <$> indent 2 (ns <$> is <$> ts <$> es <$> ss <$> rs) <$> line where+ ns = ind "syntactic symbols:" 2 . vcat $ map (\z -> (symbolDoc z <+> (text . show $ z))) (g^..nsyms.folded)+ is = if S.null (g^.nIsms) then text "" else ind "inside syntactic symbols (acting as terminals .. in a way):" 2 . vcat $ map (\z -> (symbolDoc z <+> (text . show $ z))) (g^..nIsms.folded) ts = ind "terminals:" 2 . vcat . map (\z -> symbolDoc z <+> (text . show $ z)) $ g^..tsyms.folded es = ind "epsilons:" 2 . vcat . map (\z -> tnDoc z <+> (text . show $ z)) $ g^..epsis.folded ss = ind "start symbol:" 2 . startDoc $ g^.start@@ -57,8 +120,9 @@ symbolDoc :: Symb -> Doc symbolDoc s- | [z] <- s^.symb = tnDoc z- | otherwise = list $ map tnDoc $ s^.symb+ | [z] <- s^.symb = outside $ tnDoc z+ | otherwise = outside . list $ map tnDoc $ s^.symb+ where outside = case s^.symbInOut of {Inside -> id; Outside -> underline . bold . (<> red (text "*"))} -- | Prettyprint a (non-)terminal symbol. @@ -71,9 +135,5 @@ -- | -printDoc :: Doc -> IO ()-printDoc d = displayIO stdout (renderPretty 0.8 160 $ d <> linebreak)---- Print the test grammar from the parser.+-} -test = printDoc $ grammarDoc asG
FormalLanguage/CFG/PrettyPrint/Haskell.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} -- | A PrettyPrinter that generates "almost useable" Haskell modules. The -- signature and grammar are created but the algebras are (obviously) missing.@@ -15,6 +14,7 @@ import Text.PrettyPrint.ANSI.Leijen import Text.Printf import Control.Arrow hiding ((<+>))+import Prelude hiding ((<$>)) import FormalLanguage.CFG.Grammar import FormalLanguage.CFG.Parser@@ -24,19 +24,25 @@ -- | Render grammar grammarHaskell :: Grammar -> Doc-grammarHaskell g = signatureD g <$> empty <$> grammarD g <$> empty <$> productD g+grammarHaskell g = error "grammarHaskell" -- signatureD g <$> empty <$> grammarD g <$> empty <$> productD g ++{-+ signatureD :: Grammar -> Doc+signatureD = error "signatureD"+{- signatureD g = hdr <$> indent 2 fns where- hdr = text $ printf "data Sig%s {-Monad-} m {-NT-} nt hResT {-T-} %s = Sig%s" (g^.name) {- ns -} ts (g^.name)- ns = concat . intersperse " " . nub . sort . map ntS . filter isSymbN $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded)+ hdr = text $ printf "data Sig%s {-Monad-} m {-NT-} nt hResT {-T-} %s = Sig%s" (g^.grammarName) {- ns -} ts (g^.grammarName)+ ns = concat . intersperse " " . nub . sort . map ntS . filter isSyntactic $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded) ts = concat . intersperse " " . nub . sort- . map (view tnName) . filter (\case (T _) -> True ; z -> False)- $ g^..tsyms.folded.symb.folded+ . map (view (name.getSteName)) . filter (\case (Term _ _) -> True ; z -> False)+ $ g^..synterms.folded.getSymbolList.folded -- es = concat . intersperse " " . map (addEps . view tnName) $ g^..epsis.folded -- fns = encloseSep lbrace rbrace comma . map (text . concat) . (++[["h"]]) . nub . sort $ g^..rules.folded.fun fns = encloseSep lbrace rbrace comma . (++[h]) . map ruleSigDoc . nubBy ((==) `on` _fun) . sort $ g^..rules.folded h = text "h :: Data.Vector.Fusion.Stream.Monadic.Stream m nt -> m hResT"+-} -- | Generate rule signatures for the 'Signature' data ctor. --@@ -56,21 +62,21 @@ [x] -> text $ addEps $ x^.tnName xs -> encloseSep (text "(Z:.") rparen (text ":.") $ map (text . addEps . view tnName) xs -}- | isSymbN r = text "nt"- | isSymbT r = case (r^.symb) of- [x] -> text $ x^.tnName+ | isSyntactic r = text "nt"+ | isTerminal r = case (r^.getSymbolList) of+ [x] -> text $ x^.name xs -> encloseSep (text "(Z:.") rparen (text ":.") $ map sigT xs | otherwise = error $ "ruleSigDoc: " ++ show r- where sigT (T s) = text s- sigT E = text "()" -- important, EMIT NOTHING emits @()@+ where sigT (Term s) = text s+ sigT Epsilon = text "()" -- important, EMIT NOTHING emits @()@ -ntS :: Symb -> String-ntS (Symb []) = error "zero-dim symbol"-ntS (Symb xs) = "_" ++ concatMap (\x -> x^.tnName ++ addIndex x) xs+ntS :: Symbol -> String+ntS (Symbol io []) = error "zero-dim symbol"+ntS (Symbol io xs) = "_" ++ concatMap (\x -> x^.name ++ addIndex x) xs -addIndex :: TN -> String-addIndex (N _ Singular) = ""-addIndex (N _ (IntBased k _)) = show k+addIndex :: SynTermEps -> String+addIndex (SynVar _ []) = ""+addIndex (SynVar _ is) = show "???" ++ show is ++ "???" addIndex _ = "" -- |@@ -78,12 +84,12 @@ -- TODO collect all rules with same lhs grammarD :: Grammar -> Doc-grammarD g = text ("grammar" ++ g^.name) <+>- text ("Sig" ++ g^.name ++ "{..}") <+>+grammarD g = text ("grammar" ++ g^.grammarName) <+>+ text ("Sig" ++ g^.grammarName ++ "{..}") <+> text "{-NT-}" <+> hsep (map (text . ntS) . nub . sort $ g^..rules.folded.lhs) <+>- text "{-T-}" <+> hsep (map (text . view tnName) . nub . sort- . filter (\case (T _) -> True ; z -> False)- $ g^..tsyms.folded.symb.folded) <+>+ text "{-T-}" <+> hsep (map (text . view name) . nub . sort+ . filter (\case (Term _ _) -> True ; z -> False)+ $ g^..synterms.folded.getSymbolList.folded) <+> -- text "{-E-}" <+> hsep (map (text . addEps . view tnName) . nub . sort $ g^..epsis.folded) <+> text "="<$> indent 2 (tupled xs)@@ -97,7 +103,7 @@ l = text . ntS $ head xs ^. lhs r = encloseSep empty (text " ... h") (text " ||| ") $ map genApp xs -genApp x = (text $ concat $ x^.fun)+genApp x = (text $ concat $ (undefined :: [String])) -- x^.getAttr) <+> text "<<<" <+> (encloseSep empty empty (text " % ") $ map genSymb $ x^.rhs) @@ -107,16 +113,16 @@ [z] -> text $ theName z zs -> encloseSep (text "(Z:.") rparen (text ":.") $ map (text . theName) zs -}- | isSymbN x = text $ ntS x- | isSymbT x = case (x^.symb) of+ | isSyntactic x = text $ ntS x+ | isTerminal x = case (x^.getSymbolList) of [z] -> text $ theName z zs -> encloseSep (text "(T:!") rparen (text ":!") $ map (text . theName) zs where- theName (E ) = "None"- theName (T s ) = s+ theName (Epsilon e) = e^.getSteName+ theName (Term s i ) = s^.getSteName -productD g = (text $ printf "(<**) f g = Sig%s" (g^.name)) <$> indent 2 fs <$> bnd where- fs = encloseSep lbrace rbrace comma $ (map productFun . nubBy ((==) `on` _fun) . sort $ g^..rules.folded) ++ [h]+productD g = (text $ printf "(<**) f g = Sig%s" (g^.grammarName)) <$> indent 2 fs <$> bnd where+ fs = encloseSep lbrace rbrace comma $ (map productFun . nubBy ((==) `on` _attr) . sort $ g^..rules.folded) ++ [h] h = vcat $ map text [ "h xs = do" , " hfs <- _Fh . Data.Vector.Fusion.Stream.Monadic.map fst $ xs"@@ -125,10 +131,10 @@ , " _Gh phfs" ] bnd = indent 2 ((text "where") <$> indent 2 (bF <$> bG))- bF = vcat $ map (\f -> let z = concat $ _fun f in text $ printf "_F%s = %s f" z z)- $ fnubs ++ [Rule undefined ["h"] undefined]- bG = vcat $ map (\f -> let z = concat $ _fun f in text $ printf "_G%s = %s g" z z)- $ fnubs ++ [Rule undefined ["h"] undefined]+ bF = vcat $ map (\f -> let z = concat $ (f^..attr.folded.getAttr) in text $ printf "_F%s = %s f" z z)+ $ fnubs ++ [Rule undefined [Attr "h"] undefined]+ bG = vcat $ map (\f -> let z = concat $ (f^..attr.folded.getAttr) in text $ printf "_G%s = %s g" z z)+ $ fnubs ++ [Rule undefined [Attr "h"] undefined] {- bF = text (printf "Sig%s" (g^.name)) <> (encloseSep lbrace rbrace comma . map text . (++["h_F"]) . map (("_F"++) . concat . _fun) $ fnubs)@@ -137,30 +143,34 @@ <> (encloseSep lbrace rbrace comma . map text . (++["h_G"]) . map (("_G"++) . concat . _fun) $ fnubs) <> text " =g" -}- fnubs = nubBy ((==) `on` _fun) . sort $ g^..rules.folded+ fnubs = nubBy ((==) `on` _attr) . sort $ g^..rules.folded -productFun (Rule l f rs) = text (concat f) <> text " = \\" <> vars <> text " -> " <> parens (callF <> comma <> callG)+productFun (Rule l f rs) = text (concat $ f^..folded.getAttr) <> text " = \\" <> vars <> text " -> " <> parens (callF <> comma <> callG) where vars = hsep $ zipWith mkVars rs vs- callF = text (concat $ "_F" : f) <+> (hcat . punctuate space . map text $ take (length rs) vs)- callG = let ns = map snd . filter (isSymbN . fst) $ zip rs vs+ callF = text (concat $ "_F" : (f^..folded.getAttr)) <+> (hcat . punctuate space . map text $ take (length rs) vs)+ callG = let ns = map snd . filter (isSyntactic . fst) $ zip rs vs in text . genS $ zip rs vs vs = let az = ['a'..'z'] ; bs = [[]] ++ [ a:b | b<-bs, a<-az ] in drop 1 bs mkVars r v- | isSymbT r = text v- | isSymbN r = parens (text v <> comma <> text (v++"N"))+ | isTerminal r = text v+ | isSyntactic r = parens (text v <> comma <> text (v++"N")) genS zs = let go (ns,as) (r,v)- | isSymbT r = (ns, as ++ [v])- | isSymbN r = (ns++ [v++"N", ">>= Data.Vector.Fusion.Stream.Monadic.concatMap (\\", v, "->"], as ++ [v])- postAddBrackets = (++ (replicate (length . filter isSymbN . map fst $ zs) ')'))+ | isTerminal r = (ns, as ++ [v])+ | isSyntactic r = (ns++ [v++"N", ">>= Data.Vector.Fusion.Stream.Monadic.concatMap (\\", v, "->"], as ++ [v])+ postAddBrackets = (++ (replicate (length . filter isSyntactic . map fst $ zs) ')')) in postAddBrackets . concat . intersperse " " . uncurry (++)- . foldl' go ([],["Data.Vector.Fusion.Stream.Monadic.singleton $", (concat $ "_S" : f)])+ . foldl' go ([],["Data.Vector.Fusion.Stream.Monadic.singleton $", (concat $ "_S" : (f^..folded.getAttr))]) $ zs +{- test = printDoc $ grammarHaskell asG where printDoc :: Doc -> IO () printDoc d = displayIO stdout (renderPretty 0.8 160 $ d <> linebreak)+<<<<<<< HEAD+-}+-}
FormalLanguage/CFG/PrettyPrint/LaTeX.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE PatternGuards #-} module FormalLanguage.CFG.PrettyPrint.LaTeX ( renderFile@@ -22,8 +18,10 @@ renderLaTeX :: Int -> Grammar -> LaTeX-renderLaTeX = renderGrammar+renderLaTeX = error "renderLaTeX" -- renderGrammar +{-+ -- | Transform a grammar to some LaTeX code. renderGrammar :: LaTeXC l => Int -> Grammar -> l@@ -35,9 +33,11 @@ -- | Transform a single 'Symb'. This will produce a column of terminal / -- non-terminal symbols.+--+-- TODO inside/outside renderNtT :: LaTeXC l => Symb -> l-renderNtT (Symb xs) = ll <> (mci $ map go xs) <> rr+renderNtT (Symb io xs) = ll <> (mci $ map go xs) <> rr where go (T s ) = render s go (N s e)@@ -65,4 +65,5 @@ to' c = if c > len `div` 2 then "" else to in mci [ ll & to <> lr & rl & to' c <> rr | (ll,lr) <- as | ((rl,rr),c) <- zip bs [1..] ]+-}
+ FormalLanguage/CFG/QQ.hs view
@@ -0,0 +1,90 @@++-- | This QuasiQuoter turns the description of formal grammars into+-- ADPfusion-based code.+--+-- TODO use Quote.quoteFile to be able to read files as well++module FormalLanguage.CFG.QQ where++import Control.Applicative ((<$>),(<*>),empty)+import Control.Monad hiding (mapM)+import Control.Monad.Trans.State.Strict (evalStateT)+import Data.ByteString.Char8 (pack)+import Data.Default (def)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Trifecta.Delta (Delta (Directed))+import Text.Trifecta (parseString,Parser)+import Text.Trifecta.Result (Result (..))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Control.Lens+import Data.List (transpose,sort,group)++-- ghc 7.8 / 7.10 split++import Data.Traversable (mapM)+import Data.Foldable (concat)+import Prelude hiding (mapM,concat)++import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.Outside+import FormalLanguage.CFG.Parser+import FormalLanguage.CFG.PrettyPrint.ANSI+import FormalLanguage.CFG.TH++++formalLangFile = quoteFile formalLanguage++-- |++formalLanguage = QuasiQuoter+ { quoteDec = parseFormalLanguage empty+ , quoteExp = error "there is only a Dec quoter"+ , quotePat = error "there is only a Dec quoter"+ , quoteType = error "there is only a Dec quoter"+ }++-- |++parseFormalLanguage :: GrammarParser Parser () -> String -> Q [Dec]+parseFormalLanguage ps s = do+ loc <- location+ let (lpos,cpos) = loc_start loc+ -- let r = parseString ((evalStateT . runGrammarP) grammar def) (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0) $ trim s+ let r = parseString ((evalStateT . runGrammarParser) (parseEverything ps) def) (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0) $ trim s+ case r of+ (Failure f) -> do+ runIO . printDoc $ f+ error "aborting parseFormalLanguage"+ (Success g) -> do+ let l = uniquePrefixLength g+-- let gO = outsideFromInside g+-- runIO . printDoc . grammarDoc $ g+-- runIO . printDoc . grammarDoc $ gO+-- thCodeGen g+ -- (++) <$> thCodeGen g <*> thCodeGen gO+ -- TODO here, we should know how many grammars we have and be able to+ -- determine the required prefix to make everything unique in terms+ -- of attribute functions+ concat <$> mapM (thCodeGen l) g++-- |++trim ('\n':xs) = trim xs+trim xs = xs++-- | Determine the length of the unique prefix we need for algebra+-- functions.++uniquePrefixLength :: Seq Grammar -> Int+uniquePrefixLength xs+ | l == 0 = 0+ | l == 1 = 0+ | otherwise = go 1 . transpose $ xs^..folded.grammarName+ where l = Seq.length xs+ go :: Int -> [String] -> Int+ go acc [] = error $ "for whatever reason, there are two grammars with the same name!" ++ show xs+ go acc (xs:xss) = if (maximum . map length . group $ sort xs) > 1 then go (acc+1) xss else acc+
− FormalLanguage/CFG/QuickCheck.hs
@@ -1,4 +0,0 @@---- | Create random grammars.--module FormalLanguage.CFG.QuickCheck where
FormalLanguage/CFG/TH.hs view
@@ -1,219 +1,367 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE PatternGuards #-} --- |+-- | Template Haskell system for translating formal grammars into real+-- Haskell code based on ADPfusion. ----- TODO we should check if it is possible to go a bit ``lower'' to the more raw--- stuff, instead of trying to rebuild the top-level ADPfusion syntax. Thats--- mostly for the RHS of rules.+-- If you want automatic algebra products, ADPfusion provides these.+-- @makeAlgebraProductH ['h] ''SigName@ where @SigName@ is the+-- auto-generted signature name, will generate the algebra product. ----- TODO we should build the algebra product automatically (but that piece of TH--- should go into ADPfusion)+-- When will build the grammar, the types and variables are @newName@s+-- while attribute functions names are deterministic and potentially+-- non-unique. -module FormalLanguage.CFG.TH where+module FormalLanguage.CFG.TH+ ( thCodeGen+ ) where -import Data.Char (toUpper,toLower) import Control.Applicative import Control.Arrow ((&&&))-import Control.Lens hiding (Strict)+import Control.Exception (assert)+import Control.Lens hiding (Strict, (...), outside) import Control.Monad+import Control.Monad.State.Strict as M import Control.Monad.Trans.Class-import Data.Array.Repa.Index+import Data.Char (toUpper,toLower)+import Data.Default import Data.Function (on) import Data.List (intersperse,nub,nubBy,groupBy) import Data.Maybe import Data.Vector.Fusion.Stream.Monadic (Stream)+import GHC.Exts (the) import Language.Haskell.TH-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (lift) import qualified Data.Map as M import qualified Data.Set as S+import qualified Text.PrettyPrint.ANSI.Leijen as PP+import Text.Printf+import Control.Monad.Reader import ADP.Fusion ( (%), (|||), (...), (<<<) )-import qualified ADP.Fusion.Multi as ADP+import qualified ADP.Fusion as ADP+import Data.PrimitiveArray (Z(..), (:.)(..)) -import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.PrettyPrint.ANSI --- * Local data ctors we use to build up signature and grammar--data TheTT = TheTT- { _ttType :: TyVarBndr- , _ttName :: Name- , _ttPat :: Pat- }- deriving (Show)+-- * @StateT CfgState Q@ monad and wrapper for TH-based grammar+-- construction. -makeLenses ''TheTT+-- | The state we carry around. Contains all the bound names, and lookup+-- tables for functions, terminals and syntactic variables.+--+-- NOTE the defaults all start out undefined, making sure anything invalid+-- explodes in our face.+--+-- TODO if we allow multiple different choice function, we'll have to+-- extend @_qChoiceFun@ -data TheF = TheF- { _fName :: Name- , _fVar :: Exp- , _fStrict :: Strict- , _fType :: Type+data CfgState = CfgState+ -- external stuff+ { _qGrammar :: Grammar -- ^ the input grammar+ -- some basic names+ , _qElemTyName :: Name -- ^ stream type name, as in @Stream m qElemTyName@+ , _qGrammarName :: Name -- ^ the name for the body of the grammar+ , _qMTyName :: Name -- ^ monad type name, as in @h :: Stream MTyName ...@+ , _qRetTyName :: Name -- ^ choice return type name, as in @h :: Stream m qElemTyName -> m qRetTyName@+ , _qSigName :: Name -- ^ the name of the signature type and data constructor, both (signatures need to have a single data constructor)+ -- attribute functions and choice; for now we allow only one choice+ -- function+ , _qAttribFuns :: M.Map [AttributeFunction] VarStrictType -- ^ map from the composed name to the template haskell attribute function @(Var,Strict,Type)@ (functions are currently stored as @[String]@ in @Grammar.hs@+ , _qChoiceFun :: VarStrictType -- ^ the choice function+ -- syntactic variables+ , _qPartialSyntVarNames :: M.Map Symbol Name -- ^ syntactic-id to var name -- partially applied table / syntactic+ , _qInsideSyntVarNames :: M.Map Symbol Name -- ^ for outside grammars, these are the var-names for inside syn-vars+ , _qFullSyntVarNames :: M.Map Symbol Name -- ^ type variable names for the fully applied grammar body / where part+ -- everything on terminals+ , _qTermAtomVarNames :: M.Map (String,Int) Name -- ^ (Term-id,Dimension) to var name+ , _qTermAtomTyNames :: M.Map String Name -- ^ the type name for each unique terminal symbol (that is: the scalar terminals in each dimension)+ , _qTermSymbExp :: M.Map Symbol (Type,Exp) -- ^ associate a terminal @Symb@ with a complete @Type@ and @Exp@+ , _qPrefix :: String -- ^ prefix for attribute functions }- deriving (Show) -makeLenses ''TheF+makeLenses ''CfgState -fVarStrictType :: Lens' TheF VarStrictType-fVarStrictType = lens get set where- get :: TheF -> VarStrictType- get f = (f^.fName, f^.fStrict, f^.fType)- set :: TheF -> VarStrictType -> TheF- set f (v,s,t) = f { _fName = v, _fStrict = s, _fType = t }+instance Default CfgState where+ def = CfgState+ { _qGrammar = error "def / grammar"+ , _qGrammarName = error "def / grammarname"+ , _qElemTyName = error "def / elemty"+ , _qRetTyName = error "def / retty"+ , _qMTyName = error "def / mty"+ , _qSigName = error "def / signame"+ , _qTermAtomTyNames = error "def / termtynames"+ , _qFullSyntVarNames = error "def / synbodynames"+ , _qAttribFuns = error "def / attribfuns"+ , _qChoiceFun = error "def / choicefun"+ , _qTermSymbExp = error "def / termsymbexp"+ , _qTermAtomVarNames = error "def / termsingvarnames"+ , _qPartialSyntVarNames = error "def / partsyntvarnames"+ , _qInsideSyntVarNames = error "def / insidesyntvarnames"+ , _qPrefix = error "def / prefix"+ } -data TheN = TheN- { _nName :: Name- , _nVar :: Exp- , _nPat :: Pat- }- deriving (Show)+-- | The type of our little stateful @Q@ computations -makeLenses ''TheN+type TQ z = StateT CfgState Q z -data TheT = TheT- { _tNames :: [Name]- , _tVar :: Exp- , _tType :: Type- }- deriving (Show) -makeLenses ''TheT -data TheS = TheS- { _sString :: String- , _sName :: Name- , _sVarP :: Pat- , _sConT :: Type- }--makeLenses ''TheS-+-- * TH functions +-- | Entry point for generation of @Grammar@ and @Signature@ code. Will+-- also stuff the 'Grammar' into the state data. A bunch of TH names are+-- generated here and become part of the state, as they are used in+-- multiple places. --- * Builder functions+thCodeGen :: Int -> Grammar -> Q [Dec]+thCodeGen prefixLen g = do+ let _qGrammar = g+ _qMTyName <- newName "m"+ _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)+ _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)+ -- TODO inside synvars in outside context+ evalStateT codeGen def{_qGrammar, _qMTyName, _qElemTyName, _qRetTyName, _qTermAtomTyNames, _qPartialSyntVarNames, _qInsideSyntVarNames, _qPrefix} --- | Build the signature type and data constructor+-- | Actually create signature, grammar, inline pragma. -genTheS s = do- let n = "Sig" ++ s- return $ TheS n (mkName n) (VarP . mkName . headLower $ n) (ConT . mkName $ n)+codeGen :: TQ [Dec]+codeGen = do+ -- build up the terminal symbol lookup+ qTermAtomVarNames <~ M.fromList <$> dimensionalTermSymbNames+ qTermSymbExp <~ M.fromList <$> (mapM grammarTermExpression =<< uniqueTerminalSymbols <$> use qGrammar)+ -- create attribute function bindings (needed by signature and grammar)+ qAttribFuns <~ (use (qGrammar.rules) >>= (fmap M.fromList . mapM attributeFunctionType . S.toList))+ -- create choice function+ qChoiceFun <~ choiceFunction+ -- create signature+ sig <- signature+ -- create grammar+ gra <- grammar+ -- create inlining code+ inl <- use qGrammarName >>= \gname -> lift $ pragInlD gname Inline FunLike AllPhases+ -- outside grammars use the inside signature?!+ g <- use qGrammar+ if False -- isOutside $ g^.outside -- considering to just use unsafeCoerce on inside algebras+ then return [gra,inl]+ else return [sig,gra,inl] --- | the new generator+-- | Create the signature. Will also set the signature name. -newGen :: Grammar -> Q [Dec]-newGen g = do- m <- newName "m"- x <- newName "x"- r <- newName "r"- ix <- newName "ix"- ns <- M.fromList <$> (mapM genN $ collectSymbN g)- tt <- M.fromList <$> (mapM genTT . nub $ g^..tsyms.folded.symb.folded.tnName)- ts <- M.fromList <$> (mapM (genT tt) $ collectSymbT g)- fs <- M.fromList <$> (mapM (genF x ts) . nubBy ((==) `on` _fun) $ g^..rules.folded)- h <- genHfun m x r- sg <- genTheS $ g^.name- runIO $ print fs- sig <- dataD (cxt [])- (sg^.sName)- (PlainTV m:PlainTV x:PlainTV r:(tt^..folded.ttType))- [recC (sg^.sName) ((map return $ fs^..folded.fVarStrictType) ++ [return h])- ]+signature :: TQ Dec+signature = do+ m <- use qMTyName+ x <- use qElemTyName+ r <- use qRetTyName+ termNames <- use qTermAtomTyNames+ sigName <- (mkName . ("Sig" ++)) <$> use (qGrammar.grammarName)+ fs <- use qAttribFuns+ h <- use qChoiceFun+ qSigName .= sigName+ lift $ dataD (cxt [])+ sigName+ (PlainTV m : PlainTV x : PlainTV r : (map PlainTV $ termNames^..folded))+ [recC sigName ((map return $ fs^..folded) ++ [return h])] []- let graArgs = (recP (sg^.sName) ((return (h^._1, VarP $ h^._1)):[return (n, VarP n) | n <- fs^..folded.fName]))- : (map (return . view nPat) $ ns^..folded)- ++ (map (return . view ttPat) $ tt^..folded)- let graBody = normalB . tupE . map (genBodyPair h ix ns ts fs) . groupBy ((==)`on`_lhs) $ g^..rules.folded- gra <- funD (mkName $ "g" ++ g^.name) [clause graArgs graBody []]- inl <- pragInlD (mkName $ "g" ++ g^.name) Inline FunLike AllPhases- return [sig,gra,inl] --- | The body is a series of pairs, built here--genBodyPair h ix ns ts fs rs = do- let r = head rs- let rhs = lamE [varP ix]- $ appE ( uInfixE (foldl1 (\acc z -> uInfixE acc (varE '(|||)) z) . map (genBodyRhs ns ts fs) $ rs)- (varE '(...))- (varE $ h^._1) )- (varE ix)- tupE [return . view nVar $ ns M.! (r^.lhs), rhs]---- | the right-hand sides involved in each rule--genBodyRhs ns ts fs (Rule _ f rs) = appE (appE (varE '(<<<)) (return . view fVar $ fs M.! f))- . foldl1 (\acc z -> uInfixE acc (varE '(%)) z) . map genS $ rs- where genS s- | isSymbT s = return . view tVar $ ts M.! s- | isSymbN s = return . view nVar $ ns M.! s+-- | The grammar requires three types of arguments. First we need to bind+-- an algebra. Then we bind a list of non-terminals. Finally we bind a list+-- of terminals.+--+-- Once this function is called, it will print out the order of arguments!+--+-- TODO how about we wrap the non-terminals and terminals each in a tuple? --- | the objective function @h@ is always of the same type, we need to make--- sure that stream payload and return here are different for things like--- classified DP.+grammarArguments :: TQ [PatQ]+grammarArguments = do+ g <- use qGrammar+ signame <- use qSigName+ h <- use qChoiceFun+ fs <- use qAttribFuns+ tavn <- use qTermAtomVarNames+ psyn <- use qPartialSyntVarNames+ isyn <- use qInsideSyntVarNames+ -- bind algebra+ let alg = recP signame [ fieldPat n (varP n) | (n,_,_) <- h:(fs^..folded) ]+ -- bind partially applied non-terminals+ let syn = [ varP s | s <- psyn^..folded ]+ -- bind fully applied non-terminals+ let isn = [ bangP $ varP s | s <- isyn^..folded ]+ -- bind terminals+ let ter = [ bangP $ varP t | t <- tavn^..folded ]+ --+ gname <- showName <$> use qGrammarName+ let ppSynt [x] = PP.red $ PP.text x+ ppSynt xs = PP.list $ map (ppSynt . (:[])) xs+ ppTerm (n,k) = PP.yellow . PP.text $ printf "%s,%d" n k+ pp = PP.dullgreen $ PP.text (printf "%s $ALGEBRA" gname)+ sy = PP.encloseSep (PP.text " ") (PP.empty) (PP.text " ") (runReader (mapM symbolDoc $ M.keys psyn) g)+ iy = if M.null isyn then PP.text "" else PP.encloseSep (PP.text " ") (PP.empty) (PP.text " ") (runReader (mapM symbolDoc $ M.keys isyn) g)+ te = PP.encloseSep (PP.text " ") (PP.empty) (PP.text " ") (map (\s -> ppTerm $ s) $ M.keys tavn)+ lift . runIO . printDoc $ pp PP.<> sy PP.<> iy PP.<> te PP.<> PP.hardline+ return $ alg : syn ++ isn ++ ter -genHfun :: Name -> Name -> Name -> Q VarStrictType-genHfun m x r = do- let n = "h"- let strm = ConT ''Stream- let args = AppT ArrowT . AppT (AppT strm (VarT m)) $ VarT x- let rtrn = AppT (VarT m) (VarT r)- return (mkName n, NotStrict, AppT args rtrn)+-- | Fully apply each partial syntactic variable to the corresponding+-- right-hand side. First, build up the map of fully applied names, then+-- associate each one.+--+-- @+-- Z:.s:.t+-- where s = s' (f >>> t ... h)+-- t = t' (f >>> s ... h)+-- @ --- | Generate all the information for single terminals+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+ -- TODO now we actually need to *ALSO* add symbols for the inside stuff,+ -- if this is an outside grammar.+ mapM grammarBodySyn bodySynNames -genTT :: String -> Q (String,TheTT)-genTT t = do- nn <- newName t- return (t, TheTT (PlainTV nn) nn (VarP nn))+-- | Fully bind each 'Symb' (which is partially applied, coming in as an+-- argument in the grammar) to the correct right-hand side. --- | Generate all the function information. Note that we do not create a new--- name here, because users need to be able to easily identify all the--- signature functions.+grammarBodySyn :: (Symbol,Name) -> TQ DecQ+grammarBodySyn (s,n) = do+ hname <- use (qChoiceFun._1)+ partial <- use qPartialSyntVarNames+ ix <- lift $ newName "ix"+ -- all rules that have @s@ on the left-hand side+ fs <- (filter ((s==) . _lhs) . S.elems) <$> use (qGrammar.rules)+ rs <- mapM grammarBodyRHS fs+ let rhs = assert (not $ null rs) $+ appE ( uInfixE (foldl1 (\acc z -> uInfixE acc (varE '(|||)) z) rs)+ (varE '(...))+ (varE hname) )+ (varE ix)+ return $ valD (varP n) (normalB $ appE (varE $ M.findWithDefault (error "grammarBodySyn") s partial) (lamE [varP ix] rhs)) [] -genF :: Name -> M.Map Symb TheT -> Rule -> Q ([String],TheF)-genF tyN theT r = do- let nn = mkName . headLower . concat . map headUpper $ r^.fun- let args = map (AppT ArrowT . genFArg tyN theT) $ r^.rhs- return (r^.fun, TheF nn (VarE nn) NotStrict (foldr AppT (VarT tyN) args))+-- | Build up the rhs for each rule.+--+-- Requires using the fully bound syntactic variable name! --- | builds up a function argument+grammarBodyRHS :: Rule -> TQ ExpQ+grammarBodyRHS (Rule _ f rs) = do+ -- bundle up terminals and non-terminals+ 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 rhs = assert (not $ null rs) $ foldl1 (\acc z -> uInfixE acc (varE '(%)) z) . map genSymbol $ rs+ -- apply evaluation function+ Just (fname,_,_) <- use (qAttribFuns . at f)+ return $ appE (appE (varE '(<<<)) (varE $ fname)) rhs -genFArg :: Name -> M.Map Symb TheT -> Symb -> Type-genFArg tyN theT s- | isSymbT s = view tType $ theT M.! s- | isSymbN s = VarT tyN- | otherwise = error $ "incompatible symbol: " ++ show s+-- | Terminal symbols are usually compound types, built up from different+-- terminals a la @M :| t1 :| t2 :| t3@. We here build up the type of these+-- and their expression. --- | associate each non-terminal with a new name for the variable in the grammar+grammarTermExpression :: Symbol -> TQ (Symbol, (Type,Exp))+grammarTermExpression s = do+ ttypes <- use qTermAtomTyNames+ tavn <- use qTermAtomVarNames+ 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)+ | xs <- z = foldl (\acc z -> [t| $acc :. $(genType [z]) |]) [t| Z |] xs+ 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)+ | 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)+ }) |])+ [| ADP.M |] $ zip [0..] xs+ ty <- lift . genType $ s^.getSymbolList+ ex <- lift . genExp $ s^.getSymbolList+ return (s, (ty,ex)) -genN :: Symb -> Q (Symb,TheN)-genN s = do- nn <- newName "n"- return (s, TheN nn (VarE nn) (VarP nn))+-- | Each terminal symbol is bound to some input. Since we might have the+-- same name in different dimensions, we now explicitly annotate with+-- a dimensional index. This means that each atomic terminal is annotated+-- with the corresponding dimension. --- | builds up a terminal symbol, in 1-dim stuff we just have the terminal--- symbol; in multi-dim cases we build up using ADPfusion stuff.+dimensionalTermSymbNames :: TQ [((String,Int),Name)]+dimensionalTermSymbNames = do+ g <- use qGrammar+ ys <- forM (uniqueBindableTermsWithTape g) $ \(t,d) -> do+ let sn = t^.name.getSteName+ let dm = d^.getTape+ ( (sn,dm) , ) <$> (lift $ newName $ "term" ++ sn ++ show dm)+ return ys -genT :: M.Map String TheTT -> Symb -> Q (Symb,TheT)-genT tt s@(Symb [z]) = do- let n = view ttName $ tt M.! (z^.tnName)- return $ (s, TheT [n] (VarE n) (VarT n))-genT tt s@(Symb zs) = do- let ns = map (view ttName . (tt M.!) . view tnName) zs- k <- foldl (\acc z -> uInfixE acc (varE '(ADP.:!)) z) (varE 'T) . map varE $ ns- let t = foldl (\l r -> AppT (AppT (ConT '(:.)) l) r) (ConT 'Z) (map VarT ns)- return $ (s, TheT ns k t)+-- | Build the full grammar. Generate a name (the grammar name prefixed+-- with a @"g"@), the arguments, and the body of the grammar. +grammar :: TQ Dec+grammar = do+ gn <- (mkName . ("g" ++) . _grammarName) <$> use qGrammar+ qGrammarName .= gn+ args <- grammarArguments+ bodyWhere <- grammarBodyWhere+ bodyNames <- use qFullSyntVarNames+ let body = normalB . foldl (\acc z -> [| $acc :. $z |]) [|Z|] . map varE $ bodyNames^..folded+ lift $ funD gn [clause args body bodyWhere] +-- | Given a rule, create the name and type for the attribute function+-- being used.+--+-- TODO we currently assume that should we ever have @f <<< a b@ and also+-- @f <<< c d@ then the types match. We should actually group up rules by+-- function name, then take the set of rules with same name and check if+-- the types will actually match! However, one could argue that this should+-- way earlier in the grammar parser and not here.+--+-- TODO currently using @mkName@ instead of @newName@. This allows us to+-- share the signature between grammars, but might be problematic if names+-- overlap... We should combine the two generators for @g@ and @gO@ into+-- one. Then, we should be able to re-use names. --- * helper functions+attributeFunctionType :: Rule -> TQ ([AttributeFunction],VarStrictType)+attributeFunctionType r = do+ let (f:fs) = r^..attr.folded+ elemTyName <- use qElemTyName+ terminal <- use qTermSymbExp+ let argument :: Symbol -> Type+ argument s+ | isSyntactic s = VarT elemTyName+ | isSynTerm s = VarT elemTyName+ | isTerminal s = fst $ terminal M.! 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+ return (f:fs, (nm,NotStrict,tp)) -headUpper [] = []-headUpper (x:xs) = toUpper x : xs+-- | Build the choice function. Basically @Stream m s -> m r@. -headLower [] = []-headLower (x:xs) = toLower x : xs+choiceFunction :: TQ VarStrictType+choiceFunction = do+ elemTyName <- use qElemTyName+ retTyName <- use qRetTyName+ mTyName <- use qMTyName+ let args = AppT ArrowT $ AppT (AppT (ConT ''Stream) (VarT mTyName)) (VarT elemTyName)+ let rtrn = AppT (VarT mTyName) (VarT retTyName)+ prefix <- use qPrefix+ let hFun = if null prefix then "h" else prefix ++ "H"+ return (mkName hFun, NotStrict, AppT args rtrn)
− GrammarPP.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RecordWildCards #-}---- | This small utility allows us to turn a formal language description into--- either a LaTeX source file or a Haskell module.--module Main where--import System.Console.CmdArgs-import System.IO (openFile, hClose, IOMode (..))-import Text.PrettyPrint.ANSI.Leijen (hPutDoc)--import FormalLanguage.CFG.Grammar-import FormalLanguage.CFG.Parser-import FormalLanguage.CFG.PrettyPrint.ANSI (printDoc, grammarDoc)-import FormalLanguage.CFG.PrettyPrint.Haskell (grammarHaskell)-import FormalLanguage.CFG.PrettyPrint.LaTeX (renderFile, renderLaTeX)----data Options- = LaTeX- { inFile :: String- , outFile ::String- }- | Ansi- { inFile :: String- }- | Haskell- { inFile :: String- , outFile :: String- }- deriving (Show,Data,Typeable)--optionLatex = LaTeX- { inFile = ""- , outFile = ""- }--optionAnsi = Ansi- { inFile = ""- }--optionHaskell = Haskell- { inFile = ""- , outFile = ""- }--main = do- o <- cmdArgs $ modes [optionLatex,optionAnsi]- print o- pr <- case (inFile o) of- "" -> getContents >>= return . parseGrammar "stdin"- fn -> readFile fn >>= return . parseGrammar fn- case pr of- Failure f -> printDoc f- Success s -> case o of- LaTeX{..} -> case outFile of- "" -> error "need to set output file name"- fn -> renderFile fn $ renderLaTeX 2 s- Ansi {..} -> printDoc $ grammarDoc s- Haskell{..} -> case outFile of- "" -> printDoc $ grammarHaskell s- fn -> do h <- openFile fn WriteMode- hPutDoc h $ grammarHaskell s- hClose h-
+ README.md view
@@ -0,0 +1,14 @@+# FormalGrammars++[](https://travis-ci.org/choener/FormalGrammars)++[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)++++#### Contact++Christian Hoener zu Siederdissen+choener@bioinf.uni-leipzig.de+http://www.bioinf.uni-leipzig.de/~choener/+
− changelog
@@ -1,10 +0,0 @@-0.0.0.2----------Cleaned up the TH generator. Should be easier now to build more complex-auto-generators--0.0.0.1----------Basic operations on context-free formal grammars.
+ changelog.md view
@@ -0,0 +1,24 @@+0.2.0.0+-------++- completely rewritten parsing system+- makes use of newer ADPfusion 0.4.0+- travis-ci integration++0.1.0.0+-------++- fixed dependencies+- major version bump+- new TH code generator using ADPfusion 0.3++0.0.0.2+-------++- cleaned up the TH generator. Should be easier now to build more complex+ auto-generators++0.0.0.1+-------++- basic operations on context-free formal grammars.
+ src/GrammarPP.hs view
@@ -0,0 +1,66 @@++-- | This small utility allows us to turn a formal language description into+-- either a LaTeX source file or a Haskell module.++module Main where++import System.Console.CmdArgs+import System.IO (openFile, hClose, IOMode (..))+import Text.PrettyPrint.ANSI.Leijen (hPutDoc)+import Data.Foldable (toList)++import FormalLanguage.CFG.Grammar+import FormalLanguage.CFG.Parser+import FormalLanguage.CFG.PrettyPrint.ANSI (printDoc, genGrammarDoc)+import FormalLanguage.CFG.PrettyPrint.Haskell (grammarHaskell)+import FormalLanguage.CFG.PrettyPrint.LaTeX (renderFile, renderLaTeX)++++data Options+ = LaTeX+ { inFile :: String+ , outFile ::String+ }+ | Ansi+ { inFile :: String+ }+ | Haskell+ { inFile :: String+ , outFile :: String+ }+ deriving (Show,Data,Typeable)++optionLatex = LaTeX+ { inFile = ""+ , outFile = ""+ }++optionAnsi = Ansi+ { inFile = ""+ }++optionHaskell = Haskell+ { inFile = ""+ , outFile = ""+ }++main = do+ o <- cmdArgs $ modes [{- optionLatex, -} optionAnsi]+-- print o+ pr <- case (inFile o) of+ "" -> getContents >>= return . parse+ fn -> readFile fn >>= return . parse+ case pr of+ Failure f -> printDoc f+ Success s -> case o of+-- LaTeX{..} -> case outFile of+-- "" -> error "need to set output file name"+-- fn -> renderFile fn $ renderLaTeX 2 s+ Ansi {..} -> mapM_ (printDoc . genGrammarDoc) $ toList s+-- Haskell{..} -> case outFile of+-- "" -> printDoc $ grammarHaskell s+-- fn -> do h <- openFile fn WriteMode+-- hPutDoc h $ grammarHaskell s+-- hClose h+
+ src/NeedlemanWunsch.hs view
@@ -0,0 +1,104 @@++-- | Needleman-Wunsch global alignment algorithm.++module Main where++import Control.Applicative ()+import Control.Monad+import Control.Monad.ST+import Data.Char (toUpper,toLower)+import Data.List (take)+import Data.Vector.Fusion.Util+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Unboxed as VU+import Data.Vector.Unboxed (Vector)+import Text.Printf++import ADP.Fusion+import Data.PrimitiveArray as PA hiding (map,toList)++import FormalLanguage.CFG++++-- | Define signature and grammar++[formalLanguage|+Verbose++Grammar: Global+N: X+T: l+T: u+S: [X,X]+[X,X] -> done <<< [e,e]+[X,X] -> align <<< [X,X] [l,u]+[X,X] -> indel <<< [X,X] [-,u]+[X,X] -> delin <<< [X,X] [l,-]+//++Emit: Global+|]+++makeAlgebraProduct ''SigGlobal++-- |++score :: Monad m => SigGlobal m Int Int Char Char+score = SigGlobal+ { done = \ (Z:.():.()) -> 0+ , align = \ x (Z:.a :.b ) -> if a==b then x+1 else -999999+ , indel = \ x (Z:.():.b ) -> x - 2+ , delin = \ x (Z:.a :.()) -> x - 2+ , h = SM.foldl' max (-999999)+ }+{-# INLINE score #-}++-- | +--+-- NOTE The alignment needs to be reversed to print out.++pretty :: Monad m => SigGlobal m (String,String) [(String,String)] Char Char+pretty = SigGlobal+ { done = \ (Z:.():.()) -> ("","")+ , align = \ (x,y) (Z:.a :.b ) -> (x ++ [a] ,y ++ [b]) + , indel = \ (x,y) (Z:.():.b ) -> (x ++ "-" ,y ++ [b]) + , delin = \ (x,y) (Z:.a :.()) -> (x ++ [a] ,y ++ "-") + , h = SM.toList+ }+{-# Inline pretty #-}++runNeedlemanWunsch :: Int -> String -> String -> (Int,[(String,String)])+runNeedlemanWunsch k i1' i2' = (d, take k . unId $ axiom b) where+ i1 = VU.fromList i1'+ i2 = VU.fromList i2'+ !(Z:.t) = runNeedlemanWunschForward i1 i2+ d = unId $ axiom t+ !(Z:.b) = gGlobal (score <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i1) (chr i2)+{-# NoInline runNeedlemanWunsch #-}++-- | Decoupling the forward phase for CORE observation.++runNeedlemanWunschForward :: Vector Char -> Vector Char -> Z:.(ITbl Id Unboxed (Z:.PointL:.PointL) Int)+runNeedlemanWunschForward i1 i2 = let n1 = VU.length i1; n2 = VU.length i2 in mutateTablesDefault $+ gGlobal score+ (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))+ (chr i1) (chr i2)+{-# NoInline runNeedlemanWunschForward #-}++main = do+ ls <- lines <$> getContents+ let eats [] = return ()+ eats [x] = return ()+ eats (a:b:xs) = do+ putStrLn a+ putStrLn b+ let (k,ys) = runNeedlemanWunsch 1 a b+ forM_ ys $ \(y1,y2) -> printf "%s %5d\n%s\n" y1 k y2+ eats xs+ eats ls+
+ src/Nussinov.hs view
@@ -0,0 +1,122 @@++-- | The Nussinov RNA secondary structure prediction problem.++module Main where++import Control.Applicative+import Control.Monad+import Control.Monad.ST+import Data.Char (toUpper,toLower)+import Data.List+import Data.Vector.Fusion.Util+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import Text.Printf+import Unsafe.Coerce (unsafeCoerce)++import ADP.Fusion+import Data.PrimitiveArray as PA hiding (map)++import FormalLanguage++++-- | Define signature and grammar++[formalLanguage|+Verbose++Grammar: Nussinov+N: X+T: c+S: X+X -> unp <<< X c+X -> jux <<< X c X c+X -> nil <<< e+//++Outside: Vonissun+Source: Nussinov+//++Emit: Nussinov+Emit: Vonissun+|]++++makeAlgebraProduct ''SigNussinov+makeAlgebraProduct ''SigVonissun++bpmax :: Monad m => SigNussinov m Int Int Char+bpmax = SigNussinov+ { nUnp = \ x c -> x+ , nJux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999+ , nNil = \ () -> 0+ , nH = SM.foldl' max 0+ }+{-# INLINE bpmax #-}++bpmaxV :: Monad m => SigVonissun m Int Int Char+bpmaxV = undefined++pairs !c !d+ = c=='A' && d=='U'+ || c=='C' && d=='G'+ || c=='G' && d=='C'+ || c=='G' && d=='U'+ || c=='U' && d=='A'+ || c=='U' && d=='G'+{-# INLINE pairs #-}++pretty :: Monad m => SigNussinov m String [String] Char+pretty = SigNussinov+ { nUnp = \ x c -> x ++ "."+ , nJux = \ x c y d -> x ++ "(" ++ y ++ ")"+ , nNil = \ () -> ""+ , nH = SM.toList+ }+{-# INLINE pretty #-}++prettyV :: Monad m => SigVonissun m String [String] Char+prettyV = undefined++runNussinov :: Int -> String -> (Int,[String]) -- ,Int,[String])+runNussinov k inp = (d, take k . unId $ axiom b) where+ i = VU.fromList . Prelude.map toUpper $ inp+ n = VU.length i+ !(Z:.t) = mutateTablesDefault+ $ gNussinov bpmax+ (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))+ (chr i)+ :: Z:.ITbl Id Unboxed Subword Int+ d = unId $ axiom t+ !(Z:.b) = gNussinov (bpmax <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i)+{-# NoInline runNussinov #-}++runVonissun :: Int -> String -> (Int,[String])+runVonissun k inp = (d, []) where -- take k . unId $ axiom b) where+ i = VU.fromList . Prelude.map toUpper $ inp+ n = VU.length i+ !(Z:.t) = mutateTablesDefault+ $ gVonissun bpmaxV+ (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-999999) []))+ (undefined :: ITbl Id Unboxed Subword Int)+ (chr i)+ :: Z:.ITbl Id Unboxed (Outside Subword) Int+ d = unId $ axiom t+-- !(Z:.b) = gVonissun (bpmaxV <|| prettyV) (toBacktrack t (undefined :: Id a -> Id a)) (undefined :: Backtrack (ITbl Id Unboxed Subword Int) Id Id String) (chr i)+{-# NoInline runVonissun #-}++++main = do+ ls <- lines <$> getContents+ forM_ ls $ \l -> do+ putStrLn l+ let (k,[x]) = runNussinov 1 l+ printf "%s %5d\n" x k+
+ tests/parsing.gra view
@@ -0,0 +1,41 @@++{-+CPG island grammar example, adapted from 'Biological Sequence Analysis' (Durbin et al)++Let us start by giving the grammar for CPG islands.+Also: Pretty comments ;-)+-}++Grammar: CPG -- the name of the grammar++N: P -- islands 'Plus'+N: M -- continents 'Minus'+N: S -- start non-terminal++T: n -- read a single nucleotide++S: S -- symbol to start with++S -> start <<< P -- we could both in island,+S -> start <<< M -- or not island++P -> nil <<< e -- no input left+P -> isl <<< P n -- stay on the island+P -> toisl <<< M n -- to island++M -> nil <<< e -- no input left here+M -> cntnt <<< M n -- stay on the continent+M -> frmisl <<< P n -- from island+//++-- Derive outside grammar, named GPC, from known source grammar.++-- Outside: GPC+-- Source: CPG+-- //++-- Emit both the inside and the outside grammar.++Emit: CPG+-- Emit: GPC+