diff --git a/FormalGrammars.cabal b/FormalGrammars.cabal --- a/FormalGrammars.cabal +++ b/FormalGrammars.cabal @@ -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 + preprint: @ - 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. + @ + . + @ + Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler. + Product Grammars for Alignment and Folding. + 2014. IEEE/ACM Transactions on Computational Biology and Bioinformatics. 99. + + @ + . + @ + Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler. + Algebraic Dynamic Programming over General Data Structures. + 2015. submitted. + @ + . 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 diff --git a/FormalLanguage.hs b/FormalLanguage.hs --- a/FormalLanguage.hs +++ b/FormalLanguage.hs @@ -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 diff --git a/FormalLanguage/CFG.hs b/FormalLanguage/CFG.hs --- a/FormalLanguage/CFG.hs +++ b/FormalLanguage/CFG.hs @@ -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 + diff --git a/FormalLanguage/CFG/Grammar.hs b/FormalLanguage/CFG/Grammar.hs --- a/FormalLanguage/CFG/Grammar.hs +++ b/FormalLanguage/CFG/Grammar.hs @@ -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) + +-} diff --git a/FormalLanguage/CFG/Grammar/Types.hs b/FormalLanguage/CFG/Grammar/Types.hs new file mode 100644 --- /dev/null +++ b/FormalLanguage/CFG/Grammar/Types.hs @@ -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 + diff --git a/FormalLanguage/CFG/Grammar/Util.hs b/FormalLanguage/CFG/Grammar/Util.hs new file mode 100644 --- /dev/null +++ b/FormalLanguage/CFG/Grammar/Util.hs @@ -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 + diff --git a/FormalLanguage/CFG/Outside.hs b/FormalLanguage/CFG/Outside.hs new file mode 100644 --- /dev/null +++ b/FormalLanguage/CFG/Outside.hs @@ -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 + ] + +-} + diff --git a/FormalLanguage/CFG/Parser.hs b/FormalLanguage/CFG/Parser.hs --- a/FormalLanguage/CFG/Parser.hs +++ b/FormalLanguage/CFG/Parser.hs @@ -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 + +-} + diff --git a/FormalLanguage/CFG/PrettyPrint.hs b/FormalLanguage/CFG/PrettyPrint.hs --- a/FormalLanguage/CFG/PrettyPrint.hs +++ b/FormalLanguage/CFG/PrettyPrint.hs @@ -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 diff --git a/FormalLanguage/CFG/PrettyPrint/ANSI.hs b/FormalLanguage/CFG/PrettyPrint/ANSI.hs --- a/FormalLanguage/CFG/PrettyPrint/ANSI.hs +++ b/FormalLanguage/CFG/PrettyPrint/ANSI.hs @@ -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 diff --git a/FormalLanguage/CFG/PrettyPrint/Haskell.hs b/FormalLanguage/CFG/PrettyPrint/Haskell.hs --- a/FormalLanguage/CFG/PrettyPrint/Haskell.hs +++ b/FormalLanguage/CFG/PrettyPrint/Haskell.hs @@ -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 +-} +-} diff --git a/FormalLanguage/CFG/PrettyPrint/LaTeX.hs b/FormalLanguage/CFG/PrettyPrint/LaTeX.hs --- a/FormalLanguage/CFG/PrettyPrint/LaTeX.hs +++ b/FormalLanguage/CFG/PrettyPrint/LaTeX.hs @@ -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..] ] +-} diff --git a/FormalLanguage/CFG/QQ.hs b/FormalLanguage/CFG/QQ.hs new file mode 100644 --- /dev/null +++ b/FormalLanguage/CFG/QQ.hs @@ -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 + diff --git a/FormalLanguage/CFG/QuickCheck.hs b/FormalLanguage/CFG/QuickCheck.hs deleted file mode 100644 --- a/FormalLanguage/CFG/QuickCheck.hs +++ /dev/null @@ -1,4 +0,0 @@ - --- | Create random grammars. - -module FormalLanguage.CFG.QuickCheck where diff --git a/FormalLanguage/CFG/TH.hs b/FormalLanguage/CFG/TH.hs --- a/FormalLanguage/CFG/TH.hs +++ b/FormalLanguage/CFG/TH.hs @@ -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) diff --git a/GrammarPP.hs b/GrammarPP.hs deleted file mode 100644 --- a/GrammarPP.hs +++ /dev/null @@ -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 - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# FormalGrammars + +[![Build Status](https://travis-ci.org/choener/FormalGrammars.svg?branch=master)](https://travis-ci.org/choener/FormalGrammars) + +[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/) + + + +#### Contact + +Christian Hoener zu Siederdissen +choener@bioinf.uni-leipzig.de +http://www.bioinf.uni-leipzig.de/~choener/ + diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -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. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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. diff --git a/src/GrammarPP.hs b/src/GrammarPP.hs new file mode 100644 --- /dev/null +++ b/src/GrammarPP.hs @@ -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 + diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs new file mode 100644 --- /dev/null +++ b/src/NeedlemanWunsch.hs @@ -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 + diff --git a/src/Nussinov.hs b/src/Nussinov.hs new file mode 100644 --- /dev/null +++ b/src/Nussinov.hs @@ -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 + diff --git a/tests/parsing.gra b/tests/parsing.gra new file mode 100644 --- /dev/null +++ b/tests/parsing.gra @@ -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 +