FormalGrammars 0.2.1.1 → 0.4.0.0
raw patch · 17 files changed
Files
- FormalGrammars.cabal +118/−154
- FormalLanguage/CFG/Grammar/Types.hs +61/−22
- FormalLanguage/CFG/Grammar/Util.hs +1/−1
- FormalLanguage/CFG/Outside.hs +2/−2
- FormalLanguage/CFG/Parser.hs +13/−355
- FormalLanguage/CFG/PrettyPrint.hs +2/−2
- FormalLanguage/CFG/PrettyPrint/ANSI.hs +1/−1
- FormalLanguage/CFG/PrettyPrint/LaTeX.hs +0/−69
- FormalLanguage/CFG/QQ.hs +18/−11
- FormalLanguage/CFG/TH.hs +81/−52
- FormalLanguage/CFG/TH/Internal.hs +23/−0
- README.md +1/−1
- changelog.md +28/−0
- src/GrammarPP.hs +0/−66
- src/NeedlemanWunsch.hs +0/−104
- src/Nussinov.hs +0/−122
- tests/properties.hs +8/−0
FormalGrammars.cabal view
@@ -1,49 +1,44 @@+cabal-version: 2.2 name: FormalGrammars-version: 0.2.1.1-author: Christian Hoener zu Siederdissen, 2013-2015-copyright: Christian Hoener zu Siederdissen, 2013-2015+version: 0.4.0.0+author: Christian Hoener zu Siederdissen, 2013-2019+copyright: Christian Hoener zu Siederdissen, 2013-2019 homepage: https://github.com/choener/FormalGrammars bug-reports: https://github.com/choener/FormalGrammars/issues maintainer: choener@bioinf.uni-leipzig.de category: Formal Languages, Bioinformatics-license: GPL-3+license: GPL-3.0-only license-file: LICENSE build-type: Simple stability: experimental-cabal-version: >= 1.10.0-tested-with: GHC == 7.8.4, GHC == 7.10.2+tested-with: GHC == 8.6.4 synopsis: (Context-free) grammars in formal language theory description: <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming> .- Context-free grammars in formal language theory are sets of- production rules, non-terminal and terminal symbols. This- library provides basic data types and functions to manipulate- such grammars.+ Context-free grammars in formal language theory are sets of production rules,+ non-terminal and terminal symbols. This library provides basic data types and+ functions to manipulate such grammars. .- Grammars can be defined in a small domain-specific language- 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.+ Grammars can be defined in a small domain-specific language 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.+ This library also provides the machinery that transforms an Inside grammar into the+ corresponding Outside grammar. .- Starting with version 0.2.1 it is possible to write multiple- context-free grammars within this framework.+ Starting with version 0.2.1 it is possible to write multiple context-free grammars+ within this framework. .- In addition, TemplateHaskell and QuasiQuoting functionality- allow embedding thusly defined grammars in Haskell programs.- ADPfusion then turns such a grammar into an efficient dynamic- program. It is also possible to generate Haskell modules that+ In addition, TemplateHaskell and QuasiQuoting functionality allow embedding thusly+ defined grammars in Haskell programs. ADPfusion then turns such a grammar into an+ efficient dynamic program. It is also possible to generate Haskell modules that contain the resulting grammar, signature and algebra product. .- Alternatives are ansi- or LaTeX-based pretty-printing for users- that want to implement their CFG in another language than- Haskell.+ Alternatives are ansi- or LaTeX-based pretty-printing for users that want to+ implement their CFG in another language than Haskell. .- Formal background can be found in a number of papers which are- given in the README.+ Formal background can be found in a number of papers which are given in the README. . @@ -60,51 +55,46 @@ default: False manual: True -flag debug+flag debugdump description: dump intermediate Core files default: False manual: True +flag llvm+ description: use llvm+ default: False+ manual: True -library- build-depends: base >= 4.7 && < 4.9- , ADPfusion >= 0.4.1 && < 0.5.1- , ansi-wl-pprint >= 0.6.7 && < 0.6.8- , bytestring >= 0.10 && < 0.11++common deps+ build-depends: base >= 4.7 && < 5.0+ , ansi-wl-pprint >= 0.6.7+ , bytestring >= 0.10 , containers- , data-default >= 0.5 && < 0.6- , HaTeX >= 3.16 && < 3.17- , lens >= 4.0 && < 5.0- , mtl >= 2.0 && < 3.0- , parsers >= 0.12 && < 0.13- , PrimitiveArray >= 0.6.0 && < 0.7.1- , semigroups >= 0.16 && < 0.17+ , data-default >= 0.5+-- , HaTeX >= 3.16+ , lens >= 4.0+ , mtl >= 2.0+ , parsers >= 0.12.5+ , semigroups >= 0.16 , template-haskell- , text >= 1.0 && < 1.3- , transformers >= 0.3 && < 0.5- , trifecta >= 1.5 && < 1.6- , unordered-containers >= 0.2 && < 0.3- , vector >= 0.10 && < 0.12- 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.QQ--- FormalLanguage.CFG.QuickCheck- FormalLanguage.CFG.TH+ , text >= 1.0+ , transformers >= 0.3+-- trifecta switches from ansi-wl-pprint to pretty in v.2.1+ , trifecta >= 1.7.1.1 && < 2.1+ , unordered-containers >= 0.2+ , vector >= 0.10+ --+ , ADPfusion == 0.6.0.*+ , PrimitiveArray == 0.10.0.* default-language: Haskell2010- default-extensions: DeriveDataTypeable+ default-extensions: BangPatterns+ , CPP , DataKinds+ , DeriveDataTypeable+ , DerivingStrategies , FlexibleContexts , FlexibleInstances , GeneralizedNewtypeDeriving@@ -112,7 +102,9 @@ , MultiParamTypeClasses , NamedFieldPuns , NoMonomorphismRestriction+ , PartialTypeSignatures , PatternGuards+ , PolyKinds , QuasiQuotes , RankNTypes , RecordWildCards@@ -120,115 +112,87 @@ , StandaloneDeriving , TemplateHaskell , TupleSections+ , TypeApplications , TypeFamilies , TypeOperators+ , UnicodeSyntax , ViewPatterns ghc-options: -O2 -funbox-strict-fields --- A Simple pretty-printer for formal grammars.--executable GrammarPP- build-depends: base- , ansi-wl-pprint- , cmdargs >= 0.10 && < 0.11- , FormalGrammars- hs-source-dirs:- src- default-language:- Haskell2010- default-extensions: DeriveDataTypeable- , RecordWildCards- main-is:- GrammarPP.hs+library+ import:+ deps+ 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.QQ+ FormalLanguage.CFG.TH+ FormalLanguage.CFG.TH.Internal -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+--executable NeedlemanWunschFG+-- import:+-- deps+-- if flag(examples)+-- buildable:+-- True+-- build-depends: base+-- --+-- , FormalGrammars+-- else+-- buildable:+-- False+-- hs-source-dirs:+-- src+-- main-is:+-- NeedlemanWunsch.hs+-- ghc-options:+-- -funfolding-use-threshold1000+-- -funfolding-keeness-factor1000+-- -flate-dmd-anal+-- -fspec-constr-count=100+-- if flag(debugdump)+-- ghc-options:+-- -ddump-cmm+-- -ddump-simpl+-- -ddump-stg+-- -ddump-to-file+-- -dshow-passes+-- -dsuppress-all+-- if flag(llvm)+-- ghc-options:+-- -fllvm+-- -optlo-O3 -executable NeedlemanWunschFG- if flag(examples)- buildable:- True- build-depends: base- , ADPfusion- , containers- , FormalGrammars- , PrimitiveArray- , template-haskell- , vector- else- buildable:- False- hs-source-dirs:- src+test-suite properties+ import:+ deps+ type:+ exitcode-stdio-1.0 main-is:- NeedlemanWunsch.hs- default-language:- Haskell2010- default-extensions: BangPatterns- , FlexibleContexts- , FlexibleInstances- , MultiParamTypeClasses- , QuasiQuotes- , TemplateHaskell- , TypeFamilies- , TypeOperators+ properties.hs 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+ -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs:+ tests+ build-depends: base+ --+ , FormalGrammars
FormalLanguage/CFG/Grammar/Types.hs view
@@ -1,9 +1,13 @@ -- | The data types that define a CFG. -module FormalLanguage.CFG.Grammar.Types where+module FormalLanguage.CFG.Grammar.Types+ ( module FormalLanguage.CFG.Grammar.Types+ , LocalGlobal(..)+ ) where import Control.Lens hiding (Index,index)+import Data.Data (Data,Typeable) import Data.Default import Data.Map.Strict (Map) import Data.Semigroup@@ -11,12 +15,14 @@ import Data.String import qualified Data.Map.Strict as M import qualified Data.Set as S-import Data.Data (Data,Typeable) +import ADP.Fusion.Core.Term.Epsilon (LocalGlobal(..)) + newtype IndexName = IndexName { _getIndexName :: String }- deriving (Show,Eq,Ord,IsString,Data,Typeable)+ deriving stock (Show,Eq,Ord,Data,Typeable)+ deriving newtype (IsString) makeLenses ''IndexName @@ -56,8 +62,9 @@ -- | Newtype wrapper for symbol names. -newtype SymbolName = SymbolName { _getSteName :: String }- deriving (Show,Eq,Ord,IsString,Data,Typeable)+newtype SymbolName = SymbolName { _getSteName ∷ String }+ deriving stock (Show,Eq,Ord,Data,Typeable)+ deriving newtype (IsString) makeLenses ''SymbolName @@ -67,7 +74,8 @@ -- still have the same @SymbolName@ but different type and input! newtype Tape = Tape { _getTape :: Int }- deriving (Show,Eq,Ord,Enum,Num,Data,Typeable)+ deriving stock (Show,Eq,Ord,Data,Typeable)+ deriving newtype (Enum,Num) makeLenses ''Tape @@ -100,7 +108,7 @@ -- | 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+ | Epsilon LocalGlobal deriving (Show,Eq,Ord,Data,Typeable) makeLenses ''SynTermEps@@ -112,7 +120,8 @@ -- over dimensional concatenation. newtype Symbol = Symbol { _getSymbolList :: [SynTermEps] }- deriving (Show,Eq,Ord,Monoid,Semigroup,Data,Typeable)+ deriving stock (Show,Eq,Data,Typeable)+ deriving newtype (Ord,Semigroup,Monoid) makeLenses ''Symbol @@ -121,7 +130,8 @@ -- | The name of an attribute function newtype AttributeFunction = Attr { _getAttr :: String }- deriving (Show,Eq,Ord,IsString,Data,Typeable)+ deriving stock (Show,Eq,Ord,Data,Typeable)+ deriving newtype (IsString) makeLenses ''AttributeFunction @@ -140,19 +150,30 @@ +-- | Indicate wether we are a handwritten @Inside@ grammar, or an @Outside@+-- grammar derived @fromInside@.+ data DerivedGrammar = Inside- | Outside String- deriving (Show,Eq,Data,Typeable)+ -- ^ Indicates being Inside+ | Outside { _fromInside ∷ Grammar }+ -- ^ Indicates being Outside, with original Inside+ deriving (Show,Data,Typeable) +instance Eq DerivedGrammar where+ Inside == Inside = True+ Inside == Outside _ = False+ Outside _ == Inside = False+ Outside x == Outside y = _grammarName x == _grammarName y+ 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@@ -164,18 +185,35 @@ -- can easily rename terminals. -- -- TODO better way to handle indexed symbols?+--+-- TODO include "String" name to handle sharing signatures (and thereby+-- algebras!). This makes sense only when sharing the more complex signature,+-- until I start allowing signature merges. 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 IndexName Index -- ^ any global variables- , _indices :: Map IndexName Index -- ^ active indices- , _grammarName :: String -- ^ grammar name- , _write :: Bool -- ^ some grammar file requested this grammar to be expanded into code -- TODO remove, we have an emission queue+ { _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, if so provide @fromInside@.+ , _rules :: Set Rule+ -- ^ set of production rules+ , _start :: Symbol+ -- ^ start symbol+ , _params :: Map IndexName Index+ -- ^ any global variables+ , _indices :: Map IndexName Index+ -- ^ active indices+ , _grammarName :: String+ -- ^ grammar name+ , _write :: Bool+ -- ^ some grammar file requested this grammar to be expanded into code+ --+ -- TODO remove, we have an emission queue } deriving (Show,Data,Typeable) @@ -193,5 +231,6 @@ , _write = False } +makeLenses ''DerivedGrammar makeLenses ''Grammar
FormalLanguage/CFG/Grammar/Util.hs view
@@ -54,7 +54,7 @@ -- | Epsilon-only symbols. isEpsilon :: Symbol -> Bool-isEpsilon = allOf folded (\case Epsilon -> True; _ -> False) . _getSymbolList+isEpsilon = allOf folded (\case Epsilon _ -> True; _ -> False) . _getSymbolList -- | Dimension of the grammar. Rather costly, because we check for dimensional -- consistency.
FormalLanguage/CFG/Outside.hs view
@@ -31,7 +31,7 @@ -- (linear grammars are context-free as well). -- not $ isContextFree g = Nothing | otherwise = Just $ Grammar {..}- where _outside = Outside (g^.grammarName)+ where _outside = Outside g _rules = S.fromList $ epsrule : (concatMap genOutsideRules $ g^..rules.folded) _grammarName = "" -- will be set in the parser _params = g^.params@@ -85,7 +85,7 @@ -- | genEpsilonRule :: [AttributeFunction] -> Symbol -> Rule-genEpsilonRule epsfun s = Rule (outsideSymb s) epsfun [(Symbol $ replicate (length $ s^.getSymbolList) Epsilon)]+genEpsilonRule epsfun s = Rule (outsideSymb s) epsfun [(Symbol $ replicate (length $ s^.getSymbolList) $ Epsilon Global)] -- |
FormalLanguage/CFG/Parser.hs view
@@ -16,8 +16,10 @@ import Control.Lens hiding (Index, outside, indices, index) import Control.Monad import Control.Monad.State.Class (MonadState (..))+import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict hiding (get) import Data.ByteString.Char8 (pack)+import Data.Data.Lens import Data.Default import Data.List (nub,genericIndex,mapAccumL) import Data.Map.Strict (Map)@@ -36,12 +38,9 @@ import Text.Trifecta import Text.Trifecta.Delta (Delta (Directed)) -import Data.Data.Lens- 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} @@ -66,12 +65,13 @@ } -test = parseFromFile ((evalStateT . runGrammarParser) (parseEverything empty) def{_verbose = True}) "tests/pseudo.gra"-+test ∷ IO ()+test = do+ p ← parseFromFile (evalStateT (parseEverything empty) def{_verbose = True}) "./deps/FormalGrammars/tests/pseudo.gra"+ print p --- 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 = parseString (evalStateT (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@@ -182,7 +182,7 @@ fgIdents = set styleReserved rs emptyIdents where rs = H.fromList [ "Grammar:", "Outside:", "Source:", "NormStartEps:", "Emit:", "Help", "Verbose"- , "N:", "Y:", "T:", "S:", "->", "=", "<<<", "-", "e", "ε"+ , "N:", "Y:", "T:", "S:", "->", "=", "<<<", "-", "e", "ε", "l", "λ" ] -- |@@ -296,16 +296,12 @@ let rminus = (\k -> [Index s k IMinus [] 1]) <$ reserve fgIdents "-" <*> natural let rplus = (\k -> [Index s k IPlus [] 1]) <$> (option 0 $ reserve fgIdents "+" *> natural) -- the option here is for @+0@ try req <|> try rminus <|> rplus-{--parseIndex e = braces $ commaSep ix where- ix = (\v -> Index v [] 0) <$> some alphaNum--} -- | knownTermVar :: EvalReq -> Stately m Symbol knownTermVar e = Symbol <$> do- ((:[]) <$> (eps <|> tv)) <|> (brackets $ commaSep (del <|> eps <|> tv))+ ((:[]) <$> (eps <|> tv)) <|> (brackets $ commaSep (del <|> eps <|> loc <|> tv)) where tv = flip (<?>) "known terminal variable" . try $ do i <- ident fgIdents t <- use (current . termvars . at i)@@ -315,13 +311,9 @@ -- (and probably for split cases, but these are even more -- weird) return $ if isJust t then Term i [] else SynVar i [] 1 0- {-- if isJust t- then return $ Term i []- else return $ Epsilon- -} del = Deletion <$ reserve fgIdents "-"- eps = Epsilon <$ (reserve fgIdents "e" <|> reserve fgIdents "ε")+ eps = Epsilon Global <$ (reserve fgIdents "e" <|> reserve fgIdents "ε")+ loc = Epsilon Local <$ (reserve fgIdents "l" <|> reserve fgIdents "λ") -- | Parses an already known symbol, either syntactic or terminal. --@@ -393,344 +385,10 @@ -- | -type Parse m a = (TokenParsing m, MonadState GrammarEnv (Unlined m), MonadState GrammarEnv m, MonadPlus m) => m a+type Parse m a = (TokenParsing m, MonadState GrammarEnv m, MonadPlus m) => m a+type Parse' a = StateT GrammarEnv Parser 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--- | Enum [String]- deriving (Show)---- | The --data GrammarState = GrammarState- { _nsys :: M.Map String Enumerated- , _tsys :: S.Set String- , _esys :: S.Set String- , _grammarNames :: S.Set String- }- deriving (Show)--instance Default GrammarState where- def = GrammarState- { _nsys = def- , _tsys = def- , _esys = def- , _grammarNames = def- }--makeLenses ''GrammarState---- | Parse a single grammar.--grammar :: Parse Grammar-grammar = do- 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- _rules <- (S.fromList . concat) <$> some rule- reserveGI "//"- grammarNames <>= S.singleton _name- return Grammar { .. }---- | Start symbol. Only a single symbol may be given------ TODO for indexed symbols make sure we actually have one index to start with.--startSymbol :: Parse Symb-startSymbol = do- reserveGI "S:"- name :: String <- identGI- -- TODO go and allow indexed NTs as start symbols, with one index given- -- return $ nsym1 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.--nts :: Parse [Symb]-nts = do- reserveGI "N:"- name <- identGI- enumed <- option Sing $ braces enumeration- let zs = expandNT name enumed- nsys <>= M.singleton name enumed- return zs---- | expand set of non-terminals based on type of enumerations--expandNT :: String -> Enumerated -> [Symb]-expandNT name = go where- 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--enumeration = ZeroBased <$> natural--- <|> Enum <$> sepBy1 identGI (string ",")---- | Parse declared terminal symbols.--ts :: Parse [Symb]-ts = do- reserveGI "T:"- n <- identGI- let z = Symb Inside [T n]- tsys <>= S.singleton n- return [z]---- | Parse epsilon symbols--epsP :: Parse TN-epsP = do- reserveGI "E:"- e <- identGI- esys <>= S.singleton e- return E---- | Parse a single rule. Some rules come attached with an index. In that case,--- each rule is inflated according to its modulus (or more general the set of--- indices indicated.------ TODO add @fun@ to each PR--rule :: P m => m [Rule] -- Parse [Rule]-rule = do- lhs <- runUnlined $ parsePreNN- reserveGI "->"- fun :: String <- identGI- reserveGI "<<<"- -- rhs <- runUnlined $ some (try (lift $ parsePreNN) <|> (lift $ parsePreTT))- rhs <- runUnlined $ some (try parsePreNN <|> try parsePreTT <|> parsePreEE)- whiteSpace- s <- get- return $ generateRules s lhs fun rhs---- | Actually create a rule given both lhs and rhs. This means we need to--- expand rules according to what we allow.------ TODO need to handle epsilons correctly--generateRules :: GrammarState -> PreSymb -> String -> [PreSymb] -> [Rule]-generateRules gs lhs fun rhs = map buildRules js where- -- gives (index,NT) list; from (NT,(index,integer)) list- is = nub . map swap . over (mapped._2) indexName $ (lhs : rhs) ^.. folded.folded._OnlyIndexedPreN- js = sequence $ map (expandIndex $ gs^.nsys) is- expandIndex ns (i,n) =- let expand Sing = error "expanded index on singular"- expand (ZeroBased z) = [0 .. (z-1)]- in map (i,) . expand $ ns M.! n- buildTNE _ (PreE s) = E- buildTNE _ (PreT s) = T s- buildTNE _ (PreN s NotIndexed) = N s Singular- buildTNE zs (PreN s (FixedInPreN k)) =- let ZeroBased m = (gs^.nsys) M.! s- in N s (IntBased k m)- buildTNE zs (PreN s (IndexedPreN t k)) =- let Just z = lookup t zs- ZeroBased m = (gs^.nsys) M.! s- l :: Integer = (z+k) `mod` m- in N s (IntBased l m)- buildRules j = Rule (Symb Inside $ map (buildTNE j) lhs) [fun] (map (Symb Inside . map (buildTNE j)) rhs)--data IndexedPreN- = NotIndexed- | FixedInPreN Integer- | IndexedPreN String Integer- deriving (Show,Eq,Ord)--indexName (IndexedPreN s i) = s--_IndexedPreN :: Prism' IndexedPreN (String,Integer)-_IndexedPreN = prism (uncurry IndexedPreN) $ \case (IndexedPreN s i) -> Right (s,i)- other -> Left other--data PreTNE- = PreN String IndexedPreN- | PreT String- | PreE String- deriving (Show,Eq,Ord)--_PreN :: Prism' PreTNE (String,IndexedPreN)-_PreN = prism (uncurry PreN) $ \case (PreN s i) -> Right (s,i)- other -> Left other--_OnlyIndexedPreN :: Prism' PreTNE (String,IndexedPreN)-_OnlyIndexedPreN = prism (uncurry PreN) $ \case (PreN s (IndexedPreN t i)) -> Right (s, IndexedPreN t i)- other -> Left other--_PreT :: Prism' PreTNE String-_PreT = prism PreT $ \case (PreT s) -> Right s- other -> Left other--_PreE :: Prism' PreTNE String-_PreE = prism PreE $ \case (PreE s) -> Right s- other -> Left other--type PreSymb = [PreTNE]----parsePreN :: P m => m PreTNE-parsePreN = lift (use nsys) >>= \ks -> (PreN <$> (choice . map string . M.keys $ ks) <*> parseIndexedPreN)----parsePreT :: P m => m PreTNE-parsePreT = PreT <$> (lift (use tsys) >>= choice . map string . S.elems)----parsePreE :: P m => m PreTNE-parsePreE = PreE <$> (lift (use esys) >>= choice . map string . S.elems)----parseIndexedPreN :: P m => m IndexedPreN-parseIndexedPreN = option NotIndexed ( (try . braces $ IndexedPreN <$> identGI <*> option 0 integer)- <|> (braces $ FixedInPreN <$> integer)- )---- parsePreNN :: P m => m [PreTNE]-parsePreNN = do- ns <- (:[]) <$> parsePreN <* whiteSpace <|> listP (try parsePreN <|> parsePreE)- guard (notNullOf (folded._PreN) ns) <?> "no non-terminal encountered"- return ns----parsePreTT :: P m => m [PreTNE]-parsePreTT = do- ts <- (:[]) <$> parsePreT <* whiteSpace <|> listP (try parsePreT <|> parsePreE)- guard (notNullOf (folded._PreT) ts) <?> "no terminal encountered"- return ts--parsePreEE = do- es <- (:[]) <$> parsePreE <* whiteSpace <|> listP parsePreE- guard (allOf (folded._PreT) (const True) es) <?> ""- return es---- | Parses a list of a la @[a,b,c]@--listP = brackets . commaSep------ * Monadic Parsing Machinery---- | Parser with 'GrammarState'--newtype GrammarParser m a = GrammarP { runGrammarP :: StateT GrammarState m a }- deriving ( Monad- , MonadPlus- , Alternative- , Applicative- , Functor- , MonadState GrammarState- , TokenParsing- , CharParsing- , 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- , MonadPlus m- , TokenParsing m- ) => GrammarParser m a---- | Parsing where we stop at a newline (which needs to be parsed explicitly)--type ParseU a = (Monad m- , MonadPlus m- , TokenParsing m- ) => Unlined (GrammarParser m) a--type P m = ( Monad m- , MonadPlus m- , Alternative m- , Parsing m- , TokenParsing m- , MonadState GrammarState m- )---- | grammar identifiers--grammarIdentifiers = set styleReserved rs emptyIdents where- rs = H.fromList ["Grammar:", "N:", "T:", "E:"]---- | partial binding of 'reserve' to idents--reserveGI = reserve grammarIdentifiers--identGI = ident grammarIdentifiers----parseGrammar :: String -> String -> Result Grammar-parseGrammar fname cnts = parseString- ((evalStateT . runGrammarP) grammar def)- (Directed (B.pack fname) 0 0 0 0)- cnts-------- test stuff-----testGrammar = unlines- [ "Grammar: Align"- , "N: X{2}"- , "N: Y{2}"- , "N: Z"- , "T: a"- , "T: e"- , "E: ε"- , "S: X"- , "[X{i},Y{j}] -> many <<< [X{j+1},Y{i-1}]"- , "[X{i},Y{i}] -> eeee <<< [e,e]"- , "[X{1},Y{0}] -> blar <<< [X{0},Y{1}]"- , "[X{1},Y{0}] -> blub <<< [X{0},Y{i}]"- , "Z -> step <<< Z a Z a Z"--- , "Z -> done <<< ε" -- this shouldn't actually be done, as @E@ symbols are to denote that nothing happens (so this is actually rather undefined)--- , "X -> stand <<< X"--- , "[X] -> oned <<< [X]"--- , "X -> eps <<< epsilon"- , "//"- ]--testParsing :: Result Grammar-testParsing = parseString- ((evalStateT . runGrammarP) grammar def)- (Directed (B.pack "testGrammar") 0 0 0 0)- testGrammar--asG = let (Success g) = testParsing in g---}
FormalLanguage/CFG/PrettyPrint.hs view
@@ -2,10 +2,10 @@ module FormalLanguage.CFG.PrettyPrint ( module FormalLanguage.CFG.PrettyPrint.ANSI , module FormalLanguage.CFG.PrettyPrint.Haskell- , module FormalLanguage.CFG.PrettyPrint.LaTeX+-- , module FormalLanguage.CFG.PrettyPrint.LaTeX ) where import FormalLanguage.CFG.PrettyPrint.ANSI import FormalLanguage.CFG.PrettyPrint.Haskell-import FormalLanguage.CFG.PrettyPrint.LaTeX+--import FormalLanguage.CFG.PrettyPrint.LaTeX
FormalLanguage/CFG/PrettyPrint/ANSI.hs view
@@ -57,7 +57,7 @@ steDoc (SynVar n i s k) = indexDoc i >>= return . blue . (text (n^.getSteName) <>) steDoc (SynTerm n i ) = indexDoc i >>= return . magenta . (text (n^.getSteName) <>) steDoc (Term n i ) = return . green . text $ n^.getSteName-steDoc (Epsilon ) = return . red . text $ "ε"+steDoc (Epsilon _ ) = return . red . text $ "ε" steDoc (Deletion ) = return . red . text $ "-" indexDoc :: [Index] -> Reader Grammar Doc
− FormalLanguage/CFG/PrettyPrint/LaTeX.hs
@@ -1,69 +0,0 @@--module FormalLanguage.CFG.PrettyPrint.LaTeX- ( renderFile- , renderLaTeX- ) where--import Control.Lens hiding ((&), to)-import Data.List (intersperse)-import Data.Set (toList)-import Data.Text (pack)-import Text.LaTeX.Base-import Text.LaTeX.Base.Class-import Text.LaTeX.Base.Syntax-import Text.LaTeX.Packages.AMSMath hiding (align)--import FormalLanguage.CFG.Grammar----renderLaTeX :: Int -> Grammar -> LaTeX-renderLaTeX = error "renderLaTeX" -- renderGrammar--{----- | Transform a grammar to some LaTeX code.--renderGrammar :: LaTeXC l => Int -> Grammar -> l-renderGrammar k g -- (Grammar ps gname)- | k == 1 = align xs- | k == 2 = align2 xs- where -- subsubsection (raw $ pack gname) <> raw "\n" <> align2 xs <> raw "\n" where- xs = [ (renderNtT l, mconcat (map renderNtT r)) | Rule l _ r <- toList (g^.rules) ]---- | Transform a single 'Symb'. This will produce a column of terminal /--- non-terminal symbols.------ TODO inside/outside--renderNtT :: LaTeXC l => Symb -> l-renderNtT (Symb io xs) = ll <> (mci $ map go xs) <> rr- where- go (T s ) = render s- go (N s e)- | Singular <- e = render s- | IntBased k zs <- e = render s !: (raw . pack $ show k)- go (E ) = render "-"--- | Enumerated k zs <- e = render s !: (raw . pack $ k)- ll = raw "\\begingroup \\left ( \\begin{smallmatrix}"- rr = raw "\\end{smallmatrix} \\right ) \\endgroup" where- render x- | x == "empty" = varepsilon- | null x = epsilon -- raw $ pack "-"- | otherwise = raw $ pack x--mci = mconcat . intersperse (raw "\\\\\n")--align :: LaTeXC l => [(l,l)] -> l-align = (liftL $ TeXEnv "align*" []) . go where- go xs = mci [ l & to <> r | (l,r) <- xs ]--align2 :: LaTeXC l => [(l,l)] -> l-align2 = (liftL $ TeXEnv "align*" []) . go where- go xs = let len = length xs- (as,bs) = splitAt ((len +1) `div` 2) $ xs ++ repeat ("","")- to' c = if c > len `div` 2 then "" else to- in- mci [ ll & to <> lr & rl & to' c <> rr | (ll,lr) <- as | ((rl,rr),c) <- zip bs [1..] ]--}-
FormalLanguage/CFG/QQ.hs view
@@ -7,19 +7,20 @@ module FormalLanguage.CFG.QQ where import Control.Applicative ((<$>),(<*>),empty)+import Control.Lens hiding (outside) import Control.Monad hiding (mapM) import Control.Monad.Trans.State.Strict (evalStateT) import Data.ByteString.Char8 (pack) import Data.Default (def)+import Data.List (nub)+import Data.List (transpose,sort,group)+import Data.Sequence (Seq) import Language.Haskell.TH import Language.Haskell.TH.Quote+import qualified Data.Sequence as Seq 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)+import Text.Trifecta.Result (Result (..), ErrInfo (..)) -- ghc 7.8 / 7.10 split @@ -48,14 +49,14 @@ -- | -parseFormalLanguage :: GrammarParser Parser () -> String -> Q [Dec]+parseFormalLanguage ∷ Parse' () -> 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+ let r = parseString (evalStateT (parseEverything ps) def) (Directed (pack "via QQ") (fromIntegral lpos) 0 0 0) $ trim s case r of- (Failure f) -> do+ (Failure (ErrInfo f _)) -> do runIO . printDoc $ f error "aborting parseFormalLanguage" (Success g) -> do@@ -77,14 +78,20 @@ -- | Determine the length of the unique prefix we need for algebra -- functions.+--+-- TODO only go over inside grammars! unless the inside grammar for an outside+-- grammar has not been emitted. uniquePrefixLength :: Seq Grammar -> Int uniquePrefixLength xs- | l == 0 = 0- | l == 1 = 0- | otherwise = go 1 . transpose $ xs^..folded.grammarName+-- | l == 0 = 0+-- | l == 1 = 0+ | otherwise = go 0 . transpose $ nub [ getName x | x ← xs^..folded ] 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+ getName x+ | Outside gI ← x^.outside = gI^.grammarName+ | otherwise = x^.grammarName
FormalLanguage/CFG/TH.hs view
@@ -30,20 +30,22 @@ import Data.Vector.Fusion.Stream.Monadic (Stream) import Debug.Trace import GHC.Exts (the)-import Language.Haskell.TH+import Language.Haskell.TH hiding (dataD) 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 qualified GHC.TypeLits as Kind+import Data.Foldable (toList) -import ADP.Fusion ( (%), (|||), (...), (<<<) )+import ADP.Fusion.Core ( (%), (|||), (...), (<<<) ) import Data.PrimitiveArray (Z(..), (:.)(..))-import qualified ADP.Fusion as ADP+import qualified ADP.Fusion.Core as ADP import FormalLanguage.CFG.Grammar import FormalLanguage.CFG.PrettyPrint.ANSI+import FormalLanguage.CFG.TH.Internal @@ -78,7 +80,7 @@ , _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)+ , _qTermAtomTyNames :: M.Map (String,Int) 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 }@@ -123,7 +125,7 @@ _qMTyName <- newName "m" _qElemTyName <- newName "s" _qRetTyName <- newName "r"- _qTermAtomTyNames <- M.fromList <$> (mapM (\t -> (t,) <$> newName ("t_" ++ t)) $ g^..termvars.folded.name.getSteName)+ _qTermAtomTyNames <- M.fromList <$> (mapM (\(name,tape) -> ((name,tape),) <$> newNameTerm "t" name tape) $ terminalsWithTape g) -- g^..termvars.folded.name.getSteName) _qPartialSyntVarNames <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("s_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSyntacticSymbols g) _qInsideSyntVarNames <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("i_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSynTermSymbols g) let _qPrefix = over _head toLower $ take prefixLen (g^.grammarName)@@ -138,6 +140,7 @@ codeGen :: TQ [Dec] codeGen = do+ g ← use qGrammar -- build up the terminal symbol lookup qTermAtomVarNames <~ M.fromList <$> dimensionalTermSymbNames qTermSymbExp <~ M.fromList <$> (mapM grammarTermExpression =<< uniqueTerminalSymbols <$> use qGrammar)@@ -151,29 +154,47 @@ 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]+ return $ toList sig ++ [gra,inl] -- | Create the signature. Will also set the signature name.+--+-- TODO check if signature has already been emitted (from inside, say). If so,+-- don't do anything. This goes by signature name. -signature :: TQ Dec+signature :: TQ (Maybe 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])]- []+ g ← use qGrammar+ let gName = case g^.outside of+ Inside → g^.grammarName+ Outside gI → gI^.grammarName+ -- we can not lookup signatures in the environment, because everything is emitted in one go...+ -- hence we query the environment if such a signature has already been emitted...+ -- lkupName ← lift $ lookupValueName ("Sig" ++ gName)+ -- lift . runIO $ print (gName, lkupName)+ -- case lkupName of+ -- Just theName → do+ -- qSigName .= theName+ -- return Nothing+ -- Nothing → do+ case g^.outside of+ Outside gI → do+ lift . runIO $ putStrLn "WARNING: using workaround for Inside/Outside sharing which REQUIRES emitting the inside grammar!"+ qSigName .= (mkName $ "Sig" ++ gI^.grammarName)+ return Nothing+ Inside → do+ gType ← use (qGrammar.outside)+ 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 $ Just <$> dataD (cxt [])+ sigName+ (PlainTV m : PlainTV x : PlainTV r : (map PlainTV $ termNames^..folded))+ [recC sigName ((map return $ fs^..folded) ++ [return h])] -- | 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@@ -195,7 +216,7 @@ -- 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 ]+ let syn = [ bangP $ varP s | s <- psyn^..folded ] -- bind fully applied non-terminals let isn = [ bangP $ varP s | s <- isyn^..folded ] -- bind terminals@@ -251,7 +272,11 @@ (varE '(...)) (varE hname) ) (varE ix)- return $ valD (varP n) (normalB $ appE (varE $ M.findWithDefault (error "grammarBodySyn") s partial) (lamE [varP ix] rhs)) []+ let sname = M.findWithDefault (error $ "grammarBodySyn: name not found for: " ++ show s) s partial+ -- use @TW@ to combine the table @varE sname@ and the rule RHS @lamE...@+ let bdy = [| ADP.TW $(varE sname) $(lamE [varP ix] rhs) |]+ -- return $ valD (varP n) (normalB $ appE (varE $ M.findWithDefault (error "grammarBodySyn") s partial) (lamE [varP ix] rhs)) []+ return $ valD (varP n) (normalB bdy) [] -- | Build up the rhs for each rule. --@@ -288,7 +313,7 @@ where go acc Deletion = [| $(acc) ADP.:| ADP.Deletion |] go acc sv | Just n <- M.lookup (Symbol [sv]) synNames = [| $(acc) ADP.:| $(varE n) |]- | otherwise = error $ "genSymbol:stacked: " ++ show s+ | otherwise = error $ "genSymbol:stacked: " ++ show (s,synTermNames) -- | catch-all error genSymbol s = error $ "genSymbol: " ++ show s let rhs = assert (not $ null rs) $ foldl1 (\acc z -> uInfixE acc (varE '(%)) z) . map genSymbol $ rs@@ -307,46 +332,47 @@ elemTyName <- use qElemTyName synNames <- use qFullSyntVarNames -- just the name of the fully applied symbol g <- use qGrammar- let genType :: [SynTermEps] -> TypeQ- genType z--- | Symb Outside _ <- z = error $ printf "terminal symbol %s with OUTSIDE annotation!\n" (show z)+ let genType :: Int -> [SynTermEps] -> TypeQ+ genType tape z | [Deletion] <- z = [t| () |]- | [Epsilon ] <- z = [t| () |]- | [Term tnm tidx] <- z- , Just v <- M.lookup (tnm^.getSteName) ttypes = varT v+ | [Epsilon _] <- z = [t| () |] | [Term tnm tidx] <- z- {- , Just v <- M.lookup (tnm^.getSteName) (error "bla") -} = varT elemTyName- | xs <- z = foldl (\acc z -> [t| $acc :. $(genType [z]) |]) [t| Z |] xs+ , Just v <- M.lookup (tnm^.getSteName,tape) ttypes = varT v -- single dimension only, set dim to 0+ | [Term tnm tidx] <- z = varT elemTyName+ | xs <- z = foldl (\acc (tape',z) -> [t| $acc :. $(genType tape' [z]) |]) [t| Z |] (zip [0..] xs) let genSingleExp :: Int -> SynTermEps -> ExpQ genSingleExp _ Deletion = [| ADP.Deletion |]- genSingleExp _ Epsilon = [| ADP.Epsilon |]+ genSingleExp _ (Epsilon Global) = [| ADP.Epsilon @Global |]+ genSingleExp _ (Epsilon Local) = [| ADP.Epsilon @Local |] genSingleExp _ (((`M.lookup` synNames) . Symbol . (:[])) -> Just n) = error $ show n genSingleExp k (Term tnm tidx) | Just n <- M.lookup (tnm^.getSteName,k) tavn = varE n -- TODO this one is dangerous but currently necessary for split -- systems- | Just n <- M.lookup (tnm^.getSteName,0) tavn = varE n+ | Just n <- M.lookup (tnm^.getSteName,k) tavn = varE n | otherwise = error $ show ("genSingleExp:Term: ",k,tnm,tidx, tavn) genSingleExp _ err = error $ "genSingleExp: " ++ show (s,err) let genExp :: [SynTermEps] -> ExpQ genExp z--- | Symb Outside _ <- z = error $ printf "terminal symbol %s with OUTSIDE annotation!\n" (show z) | [Deletion] <- z = [| ADP.Deletion |] -- TODO ???- | [Epsilon ] <- z = [| ADP.Epsilon |]+ | [Epsilon Global] <- z = [| ADP.Epsilon @Global |]+ | [Epsilon Local] <- z = [| ADP.Epsilon @Local |] | [Term tnm tidx] <- z , Just v <- M.lookup (tnm^.getSteName,0) tavn = varE v | xs <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(genSingleExp k z) |]) [| ADP.M |] $ zip [0..] xs-{- - | xs <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(case z of { Deletion -> [| ADP.Deletion |]- ; Epsilon -> [| ADP.Epsilon |]- ; Term tnm tidx -> varE $ M.findWithDefault (error $ "genExp: " ++ show (tnm^.getSteName,k)) (tnm^.getSteName,k) tavn- }) |])- [| ADP.M |] $ zip [0..] xs -}- ty <- lift . genType $ s^.getSymbolList+ ty <- lift . genType 0 $ s^.getSymbolList ex <- lift . genExp $ s^.getSymbolList return (s, (ty,ex)) +-- | Given a grammar, gives us each terminal on each tape.++terminalsWithTape :: Grammar -> [(String,Int)]+terminalsWithTape = map go . filter isTerm . uniqueTermsWithTape -- uniqueBindableTermsWithTape+ where go (t,d) = (t^.name.getSteName,d^.getTape)+ isTerm (Term{},_) = True+ isTerm _ = False+ -- | 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@@ -355,12 +381,13 @@ 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)+ ys <- forM (terminalsWithTape g) $ \(name,tape) -> do+ ( (name,tape) , ) <$> (lift $ newNameTerm "term" name tape) return ys +--newNameTerm :: String -> Int -> TQ Name+newNameTerm prefix name tape = newName $ prefix ++ "_" ++ name ++ "_" ++ show tape ++ "_"+ -- | Build the full grammar. Generate a name (the grammar name prefixed -- with a @"g"@), the arguments, and the body of the grammar. @@ -414,7 +441,8 @@ then attrFun else prefix ++ over _head toUpper attrFun tp <- lift $ foldr appT (varT elemTyName) $ map (appT arrowT . argument) $ r^.rhs- return (f:fs, (nm,NotStrict,tp))+ ns <- lift $ bang noSourceUnpackedness noSourceStrictness+ return (f:fs, (nm,ns,tp)) -- | Build the choice function. Basically @Stream m s -> m r@. @@ -427,5 +455,6 @@ 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)+ ns <- lift $ bang noSourceUnpackedness noSourceStrictness+ return (mkName hFun, ns, AppT args rtrn)
+ FormalLanguage/CFG/TH/Internal.hs view
@@ -0,0 +1,23 @@++-- | Support for different Template Haskell versions.++module FormalLanguage.CFG.TH.Internal where++import qualified Language.Haskell.TH.Lib as TH+import Language.Haskell.TH+++#if MIN_VERSION_base(4,10,0)+dataD ctxt tc tvs cons = TH.dataD ctxt tc tvs Nothing cons []+#else+#if MIN_VERSION_base(4,9,0)+--dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> CxtQ -> DecQ+--+-- NOTE the last argument would be @mapM conT xs@ if we actually had any+-- @xs@ to work with.+dataD ctxt tc tvs cons = TH.dataD ctxt tc tvs Nothing cons (return [])+#else+dataD ctxt tc tvs cons = TH.dataD ctxt tc tvs cons []+#endif+#endif+
README.md view
@@ -29,7 +29,7 @@ [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf) 1. Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler *Algebraic dynamic programming for multiple context-free languages* - 2015, submitted + 2016, Theoretical Computer Science [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)
changelog.md view
@@ -1,3 +1,31 @@+0.3.2.0+-------++- parsers 0.12.5 added mtl instances for Unlined, etc. We remove our own+ instances and require 0.12.5 as the new minimal version+- bang -> notStrict (GHC 8 only)++0.3.1.1+-------++- removed most upper bounds, and version bumped stuff++0.3.1.0+-------++- This version only works together with ADPfusion-0.5.2, this update improves+ performance for all grammars.++0.3.0.0+-------++- Major change in terminal symbol handling: In 0.2.x.y versions, when you named+ a terminal (say 'c') then each occurance of 'c' had the same type. This was+ *independent* of the tape the symbol occured on. Starting with 0.3.0.0 if you+ have a terminal with the same name on different tapes, then you will have to+ give each type explicitly. This requires a bit more typing for homogenous+ grammars, but makes heterogenous multi-tape grammars much more flexible.+ 0.2.1.0 -------
− src/GrammarPP.hs
@@ -1,66 +0,0 @@---- | This small utility allows us to turn a formal language description into--- either a LaTeX source file or a Haskell module.--module Main where--import System.Console.CmdArgs-import System.IO (openFile, hClose, IOMode (..))-import Text.PrettyPrint.ANSI.Leijen (hPutDoc)-import Data.Foldable (toList)--import FormalLanguage.CFG.Grammar-import FormalLanguage.CFG.Parser-import FormalLanguage.CFG.PrettyPrint.ANSI (printDoc, genGrammarDoc)-import FormalLanguage.CFG.PrettyPrint.Haskell (grammarHaskell)-import FormalLanguage.CFG.PrettyPrint.LaTeX (renderFile, renderLaTeX)----data Options- = LaTeX- { inFile :: String- , outFile ::String- }- | Ansi- { inFile :: String- }- | Haskell- { inFile :: String- , outFile :: String- }- deriving (Show,Data,Typeable)--optionLatex = LaTeX- { inFile = ""- , outFile = ""- }--optionAnsi = Ansi- { inFile = ""- }--optionHaskell = Haskell- { inFile = ""- , outFile = ""- }--main = do- o <- cmdArgs $ modes [{- optionLatex, -} optionAnsi]--- print o- pr <- case (inFile o) of- "" -> getContents >>= return . parse- fn -> readFile fn >>= return . parse- case pr of- Failure f -> printDoc f- Success s -> case o of--- LaTeX{..} -> case outFile of--- "" -> error "need to set output file name"--- fn -> renderFile fn $ renderLaTeX 2 s- Ansi {..} -> mapM_ (printDoc . genGrammarDoc) $ toList s--- Haskell{..} -> case outFile of--- "" -> printDoc $ grammarHaskell s--- fn -> do h <- openFile fn WriteMode--- hPutDoc h $ grammarHaskell s--- hClose h-
− src/NeedlemanWunsch.hs
@@ -1,104 +0,0 @@---- | Needleman-Wunsch global alignment algorithm.--module Main where--import Control.Applicative ()-import Control.Monad-import Control.Monad.ST-import Data.Char (toUpper,toLower)-import Data.List (take)-import Data.Vector.Fusion.Util-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Unboxed as VU-import Data.Vector.Unboxed (Vector)-import Text.Printf--import ADP.Fusion-import Data.PrimitiveArray as PA hiding (map,toList)--import FormalLanguage.CFG------ | Define signature and grammar--[formalLanguage|-Verbose--Grammar: Global-N: X-T: l-T: u-S: [X,X]-[X,X] -> done <<< [e,e]-[X,X] -> align <<< [X,X] [l,u]-[X,X] -> indel <<< [X,X] [-,u]-[X,X] -> delin <<< [X,X] [l,-]-//--Emit: Global-|]---makeAlgebraProduct ''SigGlobal---- |--score :: Monad m => SigGlobal m Int Int Char Char-score = SigGlobal- { done = \ (Z:.():.()) -> 0- , align = \ x (Z:.a :.b ) -> if a==b then x+1 else -999999- , indel = \ x (Z:.():.b ) -> x - 2- , delin = \ x (Z:.a :.()) -> x - 2- , h = SM.foldl' max (-999999)- }-{-# INLINE score #-}---- | ------ NOTE The alignment needs to be reversed to print out.--pretty :: Monad m => SigGlobal m (String,String) [(String,String)] Char Char-pretty = SigGlobal- { done = \ (Z:.():.()) -> ("","")- , align = \ (x,y) (Z:.a :.b ) -> (x ++ [a] ,y ++ [b]) - , indel = \ (x,y) (Z:.():.b ) -> (x ++ "-" ,y ++ [b]) - , delin = \ (x,y) (Z:.a :.()) -> (x ++ [a] ,y ++ "-") - , h = SM.toList- }-{-# Inline pretty #-}--runNeedlemanWunsch :: Int -> String -> String -> (Int,[(String,String)])-runNeedlemanWunsch k i1' i2' = (d, take k . unId $ axiom b) where- i1 = VU.fromList i1'- i2 = VU.fromList i2'- !(Z:.t) = runNeedlemanWunschForward i1 i2- d = unId $ axiom t- !(Z:.b) = gGlobal (score <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i1) (chr i2)-{-# NoInline runNeedlemanWunsch #-}---- | Decoupling the forward phase for CORE observation.--runNeedlemanWunschForward :: Vector Char -> Vector Char -> Z:.(ITbl Id Unboxed (Z:.PointL:.PointL) Int)-runNeedlemanWunschForward i1 i2 = let n1 = VU.length i1; n2 = VU.length i2 in mutateTablesDefault $- gGlobal score- (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))- (chr i1) (chr i2)-{-# NoInline runNeedlemanWunschForward #-}--main = do- ls <- lines <$> getContents- let eats [] = return ()- eats [x] = return ()- eats (a:b:xs) = do- putStrLn a- putStrLn b- let (k,ys) = runNeedlemanWunsch 1 a b- forM_ ys $ \(y1,y2) -> printf "%s %5d\n%s\n" y1 k y2- eats xs- eats ls-
− src/Nussinov.hs
@@ -1,122 +0,0 @@---- | The Nussinov RNA secondary structure prediction problem.--module Main where--import Control.Applicative-import Control.Monad-import Control.Monad.ST-import Data.Char (toUpper,toLower)-import Data.List-import Data.Vector.Fusion.Util-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import Text.Printf-import Unsafe.Coerce (unsafeCoerce)--import ADP.Fusion-import Data.PrimitiveArray as PA hiding (map)--import FormalLanguage------ | Define signature and grammar--[formalLanguage|-Verbose--Grammar: Nussinov-N: X-T: c-S: X-X -> unp <<< X c-X -> jux <<< X c X c-X -> nil <<< e-//--Outside: Vonissun-Source: Nussinov-//--Emit: Nussinov-Emit: Vonissun-|]----makeAlgebraProduct ''SigNussinov-makeAlgebraProduct ''SigVonissun--bpmax :: Monad m => SigNussinov m Int Int Char-bpmax = SigNussinov- { nUnp = \ x c -> x- , nJux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999- , nNil = \ () -> 0- , nH = SM.foldl' max 0- }-{-# INLINE bpmax #-}--bpmaxV :: Monad m => SigVonissun m Int Int Char-bpmaxV = undefined--pairs !c !d- = c=='A' && d=='U'- || c=='C' && d=='G'- || c=='G' && d=='C'- || c=='G' && d=='U'- || c=='U' && d=='A'- || c=='U' && d=='G'-{-# INLINE pairs #-}--pretty :: Monad m => SigNussinov m String [String] Char-pretty = SigNussinov- { nUnp = \ x c -> x ++ "."- , nJux = \ x c y d -> x ++ "(" ++ y ++ ")"- , nNil = \ () -> ""- , nH = SM.toList- }-{-# INLINE pretty #-}--prettyV :: Monad m => SigVonissun m String [String] Char-prettyV = undefined--runNussinov :: Int -> String -> (Int,[String]) -- ,Int,[String])-runNussinov k inp = (d, take k . unId $ axiom b) where- i = VU.fromList . Prelude.map toUpper $ inp- n = VU.length i- !(Z:.t) = mutateTablesDefault- $ gNussinov bpmax- (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))- (chr i)- :: Z:.ITbl Id Unboxed Subword Int- d = unId $ axiom t- !(Z:.b) = gNussinov (bpmax <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i)-{-# NoInline runNussinov #-}--runVonissun :: Int -> String -> (Int,[String])-runVonissun k inp = (d, []) where -- take k . unId $ axiom b) where- i = VU.fromList . Prelude.map toUpper $ inp- n = VU.length i- !(Z:.t) = mutateTablesDefault- $ gVonissun bpmaxV- (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-999999) []))- (undefined :: ITbl Id Unboxed Subword Int)- (chr i)- :: Z:.ITbl Id Unboxed (Outside Subword) Int- d = unId $ axiom t--- !(Z:.b) = gVonissun (bpmaxV <|| prettyV) (toBacktrack t (undefined :: Id a -> Id a)) (undefined :: Backtrack (ITbl Id Unboxed Subword Int) Id Id String) (chr i)-{-# NoInline runVonissun #-}----main = do- ls <- lines <$> getContents- forM_ ls $ \l -> do- putStrLn l- let (k,[x]) = runNussinov 1 l- printf "%s %5d\n" x k-
+ tests/properties.hs view
@@ -0,0 +1,8 @@++module Main where++++main :: IO ()+main = return ()+