packages feed

platinum-parsing (empty) → 0.1.0.0

raw patch · 46 files changed

+4259/−0 lines, 46 filesdep +HStringTemplatedep +basedep +binarysetup-changed

Dependencies added: HStringTemplate, base, binary, clock, containers, data-hash, directory, fgl, hspec, mtl, optparse-applicative, parsec, platinum-parsing, text, vector, yaml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,58 @@+# platinum-parsing+www.platinum-parsing.org++Platinum Parsing is an all-around solution for conceiving, developping and building a compiler or an interpreter, or just a part of it. It's composed of two parts: the Framework, written in Haskell, and the CLI (Command Line Interface), exposing the functionalities of the Framework.++## Features+- Purely functional, written in Haskell+- Generic approach to compilation+- Full EBNF grammar support+- Tokens definition with built-in RegEx+- Grammar validation on source file+- Dynamic AST generation+- LALR table and DFA generation+- Built-in lexer and parser+- Customisable template export+- CLI and Atom integration+- And more ... \*++\* Platinum Parsing is a recent project aimed to grow, you can find development axis in the _Issues_ menu.++## Getting started+Platinum Parsing is built with the famous [Haskell Tool Stack](https://www.haskellstack.org/), you will need to install it before continuing.++NB: if you prefer to use `cabal` instead of `stack`, feel free to do so.++Platinum Parsing is available on [Hackage](https://hackage.haskell.org/), thus you can install it with the command:++  ```console+  $ stack install platinum-parsing+  ```++This will cause the CLI to be accessible in your terminal, try: `$ pp --help`++If you want to use the Framework directly in your Haskell project, add to your `<project-name>.cabal` file the following line, and run a `$ stack build` afterwards:++  ```yaml+  build-depends: platinum-parsing+  ```++Last option is to clone this repository and build the project by yourself:++  ```console+  $ git clone git@github.com:chlablak/platinum-parsing.git+  or+  $ git clone https://github.com/chlablak/platinum-parsing.git++  $ cd platinum-parsing+  $ stack init+  $ stack build+  ```++## Further reading+- Platinum Parsing has an [Atom](https://atom.io/) integration (plugin) for ease of development, available [here](https://atom.io/packages/platinum-parsing-atom).+- The library documentation is available on the Hackage [package](https://hackage.haskell.org/package/platinum-parsing).+- More documentation (examples, references, ...) can be found in the `doc/` [folder](doc/).++## Contributing+If you have any question, proposition or contribution, feel free to use the _Issues_ menu.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cli/Args.hs view
@@ -0,0 +1,82 @@+{-|+Module      : Args+Description : CLI arguments record+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}++module Args+    ( Args(..)+    , CommonArgs(..)+    , CommandArgs(..)+    , EbnfArgs(..)+    , LalrArgs(..)+    , NewArgs(..)+    , BuildArgs(..)+    ) where++-- |Global arguments+data Args = Args CommonArgs CommandArgs+  deriving Show++-- |Common arguments+data CommonArgs = CommonArgs+  { setLevel :: Int     -- ^Verbosity level+  , silent   :: Bool    -- ^Verbosity off+  , useWork  :: Bool    -- ^Use '.pp-work/' directory+  , path     :: String  -- ^Working directory path+  }+    deriving Show++-- |Allowed commands+data CommandArgs+  = EbnfCmd EbnfArgs    -- ^EBNF command+  | LalrCmd LalrArgs    -- ^LALR command+  | NewCmd NewArgs      -- ^New command+  | BuildCmd BuildArgs  -- ^Build command+    deriving Show++-- |EBNF command arguments+data EbnfArgs = EbnfArgs+  { ebnfFile      :: String   -- ^Input file+  , showMinified  :: Bool     -- ^Print the minified grammar to output+  , showRules     :: Bool     -- ^Print the obtained rules+  , showFirstSet  :: Bool     -- ^Print the first set+  , doCheck       :: Bool     -- ^Search for errors in grammar+  , showLexical   :: Bool     -- ^Print lexical rules+  , showRegexfied :: Bool     -- ^Print the regexfied lexical rules+  }+    deriving Show++-- |LALR command arguments+data LalrArgs = LalrArgs+  { lalrFile       :: String  -- ^Input file+  , showCollection :: Bool    -- ^Print the items sets collection+  , showSetI       :: Int     -- ^Print a specific items set+  , showTable      :: Bool    -- ^Print the LALR table+  , testWith       :: String  -- ^Test the LALR table on a source file+  , template       :: String  -- ^Specify a template+  , showDfa        :: Bool    -- ^Print the DFA+  , showAst        :: Bool    -- ^Print the parsed AST+  , astHtml        :: String  -- ^Output the AST to HTML list+  }+    deriving Show++-- |New command arguments+newtype NewArgs = NewArgs+  { projectName :: String   -- ^Project name+  }+    deriving (Show)++-- |Build command arguments+data BuildArgs = BuildArgs+  { disableTemplate :: Bool   -- ^Disable template compilation+  , disableTest     :: Bool   -- ^Disable tests+  , buildTestWith   :: String -- ^Test the LALR table on a source file+  , buildShowAst    :: Bool   -- ^Print the parsed AST+  , buildAstHtml    :: String -- ^Output the AST to HTML list+  }+    deriving (Show)
+ cli/Cmd/Build.hs view
@@ -0,0 +1,125 @@+{-|+Module      : Cmd.Build+Description : CLI for the `pp build` command+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}++module Cmd.Build+    ( commandArgs+    , dispatch+    ) where++import           Args+import qualified Cmd.Ebnf+import qualified Cmd.Lalr+import           Control.Monad       (unless, when)+import           Data.Semigroup      ((<>))+import qualified Log+import           Options.Applicative+import qualified Project++-- |Command arguments+commandArgs :: Parser CommandArgs+commandArgs = BuildCmd <$> buildArgs+  where+    buildArgs = BuildArgs+      <$> switch ( long "no-template"+        <> help "Disable templates compilation" )+      <*> switch ( long "no-test"+        <> help "Disable tests execution" )+      <*> strOption ( long "test-with"+        <> short 't'+        <> metavar "FILENAME"+        <> value ""+        <> help "Test the grammar on a source file" )+      <*> switch ( long "ast"+        <> help "Print the parsed AST (with --test-with)" )+      <*> strOption ( long "ast-to-html"+        <> metavar "FILENAME"+        <> value ""+        <> help "Output the parsed AST to HTML list" )++-- |Command dispatch+dispatch :: Args -> Log.Logger+dispatch (Args cargs0 (BuildCmd args)) = do+  Log.pushTag "build"++  -- Parse pp.yaml+  p <- Project.get+  case p of+    Project.NoProject -> Log.err "no project in current directory"+    Project.MalformedProject err -> Log.err $ "malformed project: " ++ err+    _ -> do+      Log.info $ "build project: " ++ Project.projectName p+      let cargs = mergeCArgs cargs0 p+      let file = head $ Project.projectGrammars p++      -- EBNF checks+      Log.info "EBNF checks:"+      let ebnf = EbnfArgs file False False False True False False+      Cmd.Ebnf.dispatch $ Args cargs $ EbnfCmd ebnf++      checkOk <- Log.ok+      when checkOk $ do++        -- LALR generation+        Log.info "LALR generation:"+        let lalr = LalrArgs file False (-1) False (buildTestWith args) "" False (buildShowAst args) (buildAstHtml args)+        Cmd.Lalr.dispatch $ Args cargs $ LalrCmd lalr++        genOk <- Log.ok+        when genOk $ do++          -- Templates compilation+          unless (disableTemplate args) $ do+            Log.info "Templates compilation:"+            Log.autoFlush False+            mapM_ (buildTemplate cargs lalr) $ Project.projectTemplates p+            Log.autoFlush True++          -- Tests+          unless (disableTest args) $ do+            Log.info "Tests execution:"+            Log.autoFlush False+            mapM_ (buildTest cargs lalr) $ Project.projectTests p+            Log.autoFlush True++  -- End+  Log.popTag+  return ()++-- |Compute the correct common args+mergeCArgs :: CommonArgs -> Project.Project -> CommonArgs+mergeCArgs (CommonArgs l s _ p) pr =+  CommonArgs l s (Project.projectUseWork pr) p++-- |Build template+buildTemplate :: CommonArgs -> LalrArgs -> Project.ProjectTemplate -> Log.Logger+buildTemplate cargs (LalrArgs l1 l2 l3 l4 l5 _ l7 l8 l9) t = do+  Log.pushTag "template"+  Log.info $ Project.templateFile t ++ " > " ++ Project.templateDst t+  Log.flushAll+  let args = LalrArgs l1 l2 l3 l4 l5 (Project.templateFile t) l7 l8 l9+  Cmd.Lalr.dispatch $ Args cargs $ LalrCmd args+  Log.flushOutToFile $ Project.templateDst t+  Log.popTag++-- |Build test+buildTest :: CommonArgs -> LalrArgs -> Project.ProjectTest -> Log.Logger+buildTest cargs (LalrArgs l1 l2 l3 l4 _ l6 l7 _ l9) t = do+  Log.pushTag "test"+  Log.info $ Project.testFile t ++ if Project.testAstDst t /= ""+                                   then " > " ++ Project.testAstDst t+                                   else ""+  Log.flushAll+  let args = LalrArgs l1 l2 l3 l4 (Project.testFile t) l6 l7 (Project.testAstDst t /= "") l9+  Cmd.Lalr.dispatch $ Args cargs $ LalrCmd args+  if Project.testAstDst t /= "" then+    Log.flushOutToFile $ Project.testAstDst t+  else+    Log.flushOutOnly+  Log.popTag
+ cli/Cmd/Ebnf.hs view
@@ -0,0 +1,112 @@+{-|+Module      : Cmd.Ebnf+Description : CLI for the `pp ebnf` command+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}++module Cmd.Ebnf+    ( commandArgs+    , dispatch+    ) where++import           Args+import           Control.Monad       (when)+import qualified Data.Map.Strict     as Map+import           Data.Semigroup      ((<>))+import qualified Log+import           Options.Applicative+import qualified PP+import qualified PP.Grammars.Ebnf    as Ebnf++-- |Command arguments+commandArgs :: Parser CommandArgs+commandArgs = EbnfCmd <$> ebnfArgs+  where+    ebnfArgs = EbnfArgs+      <$> strOption ( long "file"+        <> short 'f'+        <> metavar "FILENAME"+        <> help "Input file" )+      <*> switch ( long "minify"+        <> help "Print the minified grammar" )+      <*> switch ( long "rules"+        <> help "Print the obtained rules" )+      <*> switch ( long "first"+        <> help "Print the first set" )+      <*> switch ( long "check"+        <> help "Search for errors" )+      <*> switch ( long "lexical"+        <> help "Print lexical rules" )+      <*> switch ( long "regexfy"+        <> help "Print regexfied lexical rules" )++-- |Command dispatch+dispatch :: Args -> Log.Logger+dispatch (Args _ (EbnfCmd args)) = do+  Log.pushTag "ebnf"+  input <- Log.io $ readFile $ ebnfFile args+  case PP.parseAst input :: (PP.To Ebnf.Syntax) of+    Left err -> do+      Log.err $ "error in file '" ++ ebnfFile args ++ "':"+      Log.err $ show err+      Log.abort+    Right ast -> do+      -- Flag `--minify`+      when (showMinified args) $ do+        Log.info "minified:"+        Log.out $ PP.stringify ast++      r <- Log.io $ PP.rules' $ PP.lexify ast+      case r of+        Left err -> do+          Log.err $ "cannot make rules: " ++ err+          Log.abort+        Right r -> do+          let (prs, lrs) = PP.separate r++          -- Flag `--lexical`+          when (showLexical args) $ do+            Log.info "lexical rules:"+            mapM_ (Log.out . show) lrs++          -- Flag `--regexfy`+          when (showRegexfied args) $ do+            Log.info "regexfied lexical rules:"+            mapM_ (Log.out . show) $ PP.regexfy lrs++          case PP.extend prs of+            Left err -> do+              Log.err "cannot extend the input grammar:"+              Log.err err+              Log.abort+            Right g' -> do+              let rs = PP.ruleSet g'+              let fs = PP.firstSet rs++              -- Flag `--rules`+              when (showRules args) $ do+                Log.info "rules:"+                mapM_ (Log.out . show) g'++              -- Flag `--first`+              when (showFirstSet args) $ do+                Log.info "first set:"+                mapM_ (Log.out . show) $ Map.toList fs++              -- Flag `--check`+              when (doCheck args) $ do+                let (err, warn) = PP.check rs+                Log.pushTag "check"+                Log.info "errors:"+                mapM_ Log.info err+                Log.info "warnings:"+                mapM_ Log.info warn+                Log.popTag++  -- End+  Log.popTag+  return ()
+ cli/Cmd/Lalr.hs view
@@ -0,0 +1,219 @@+{-|+Module      : Cmd.Lalr+Description : CLI for the `pp lalr` command+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}++module Cmd.Lalr+    ( commandArgs+    , dispatch+    ) where++import           Args+import           Control.Monad              (when)+import qualified Data.Graph.Inductive.Graph as Gr+import qualified Data.Map.Strict            as Map+import           Data.Semigroup             ((<>))+import qualified Data.Set                   as Set+import qualified Data.Vector                as Vector+import qualified Log+import           Options.Applicative+import qualified PP+import qualified PP.Builders.Lalr           as Builder+import qualified PP.Grammars.Ebnf           as Grammar+import qualified PP.Lexers.Dfa              as Lexer+import qualified PP.Parsers.Lr              as Parser+import qualified PP.Templates.Dfa           as DfaTemplate+import qualified PP.Templates.Lr            as LrTemplate+import qualified Work++-- |Command arguments+commandArgs :: Parser CommandArgs+commandArgs = LalrCmd <$> lalrArgs+  where+    lalrArgs = LalrArgs+      <$> strOption ( long "file"+        <> short 'f'+        <> metavar "FILENAME"+        <> help "Input file" )+      <*> switch ( long "collection"+        <> help "Print the items sets collection" )+      <*> option auto ( long "set"+        <> metavar "I"+        <> value (-1)+        <> help "Print a specific items set" )+      <*> switch ( long "table"+        <> help "Print the LALR parsing table" )+      <*> strOption ( long "test-with"+        <> short 't'+        <> metavar "FILENAME"+        <> value ""+        <> help "Test the table on a source file" )+      <*> strOption ( long "template"+        <> metavar "FILENAME"+        <> value ""+        <> help "Specify a template file to use" )+      <*> switch ( long "dfa"+        <> help "Print the DFA" )+      <*> switch ( long "ast"+        <> help "Print the parsed AST (with --test-with)" )+      <*> strOption ( long "ast-to-html"+        <> metavar "FILENAME"+        <> value ""+        <> help "Output the parsed AST to HTML list" )++-- |Command dispatch+dispatch :: Args -> Log.Logger+dispatch (Args cargs (LalrCmd args)) = do+  Log.pushTag "lalr"+  input <- Log.io $ readFile $ lalrFile args+  case PP.parseAst input :: (PP.To Grammar.Syntax) of+    Left err -> do+      Log.err $ "error in file '" ++ lalrFile args ++ "':"+      Log.err $ show err+      Log.abort+    Right ast -> do+      r <- Log.io $ PP.rules' $ PP.lexify ast+      case r of+        Left err ->  do+          Log.err $ "cannot make rules: " ++ err+          Log.abort+        Right rules -> do+          let (prs, lrs) = PP.separate rules+          case PP.extend prs of+            Left err -> do+              Log.err "cannot extend the input grammar:"+              Log.err err+              Log.abort+            Right g' -> do+              let rs = PP.ruleSet g'+              let (errors, warnings) = PP.check rs+              mapM_ Log.warn warnings+              if errors /= [] then do+                Log.err "errors found in rules:"+                mapM_ Log.err errors+                Log.abort+              else do+                let fs = PP.firstSet rs+                Log.pushTask "compute collection and table"+                c <- Work.reuse (useWork cargs)+                                (lalrFile args)+                                "collection"+                                (Log.io $ return $ PP.collection rs fs)+                     :: Log.LoggerIO (PP.LrCollection Builder.LalrItem)++                -- Flag '--collection'+                when (showCollection args) $+                  printCollection c++                -- Flag '--set'+                when (showSetI args /= (-1)) $+                  printSet (showSetI args) $ c Vector.! showSetI args++                t <- Work.reuse (useWork cargs)+                                (lalrFile args)+                                "table"+                                (Log.io $ return $ PP.table c)+                case t of+                  Left err -> do+                    Log.popTask+                    Log.err "grammar is not LALR:"+                    mapM_ Log.err err+                    Log.abort+                  Right t -> do+                    Log.popTask++                    -- Flag '--table'+                    when (showTable args) $ do+                      Log.info "table:"+                      printTable t++                    Log.pushTask "compute DFA"+                    dfa' <- Work.reuse (useWork cargs)+                                       (lalrFile args)+                                       "dfa"+                                       (Log.io $ Lexer.createDfa' lrs)+                    case dfa' of+                      Left err -> do+                        Log.popTask+                        Log.err $ "cannot create DFA: " ++ err+                        Log.abort+                      Right dfa -> do+                        Log.popTask++                        -- Flag `--dfa`+                        when (showDfa args) $+                          printDfa dfa++                        -- Flag '--test-with'+                        when (testWith args /= "") $ do+                          source <- Log.io $ readFile $ testWith args+                          let lconfig = Lexer.dfaConfig source dfa+                          let tokens = PP.output $ PP.consume lconfig+                          let cfg = PP.parse' t $ PP.config t tokens :: [Parser.LrConfig]++                          -- Flag `--ast`+                          when (showAst args) $ do+                            Log.info "parsed AST:"+                            Log.out $ Parser.prettyAst $ Parser.lrAst $ head cfg++                          -- Flag `--ast-to-html`+                          when (astHtml args /= "") $ do+                            Log.info $ "AST to HTML: " ++ astHtml args+                            Log.io $ writeFile (astHtml args) (astToHtml $ Parser.lrAst $ head cfg)++                          printCfg cfg++                        -- Flag '--template'+                        when (template args /= "") $ do+                          te <- Log.io $ readFile $ template args+                          let c1 = LrTemplate.context t+                          let c2 = DfaTemplate.context dfa+                          let compiled = PP.compile (PP.mergeContext c1 c2) te+                          Log.info "compiled template:"+                          Log.out compiled++  -- End+  Log.popTag+  return ()++-- |Pretty print for collection+printCollection :: PP.LrCollection Builder.LalrItem -> Log.Logger+printCollection c = do+  Log.info "collection:"+  Vector.imapM_ printSet c++-- |Pretty print for set+printSet :: Int -> PP.LrSet Builder.LalrItem -> Log.Logger+printSet i is = do+  Log.info $ "items set " ++ show i ++ ":"+  mapM_ (Log.out . show) $ Set.toList is++-- |Pretty print for table+printTable :: PP.LrTable -> Log.Logger+printTable = Log.out . Map.showTree++-- |Pretty print for configuration+printCfg :: [Parser.LrConfig] -> Log.Logger+printCfg = printCfg' . head+  where+    printCfg' (Parser.LrConfig c _ a i _) = do+      Log.out $ "after " ++ show c ++ " iterations: "+      case a of+        PP.LrAccept -> Log.out "input accepted"+        _           -> Log.out $ "error at " ++ show (take 20 (str i))+    str = concatMap (\(PP.OToken2 v _) -> v)++-- |Pretty print for DFA+printDfa :: PP.DfaGraph -> Log.Logger+printDfa = Log.out . Gr.prettify++-- |Print the AST to HTML+astToHtml :: Parser.LrAst -> String+astToHtml (Parser.LrAstRoot xs) = "<ul>" ++ concatMap astToHtml xs ++ "</ul>"+astToHtml (Parser.LrAstNonTerm r xs) = "<li>" ++ r ++ "<ul>" ++ concatMap astToHtml xs ++ "</ul></li>"+astToHtml (Parser.LrAstTerm t) = "<li>" ++ show t ++ "</li>"
+ cli/Cmd/New.hs view
@@ -0,0 +1,50 @@+{-|+Module      : Cmd.New+Description : CLI for the `pp new` command+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}++module Cmd.New+    ( commandArgs+    , dispatch+    ) where++import           Args+import           Control.Monad       (when)+import           Data.Semigroup      ((<>))+import qualified Log+import           Options.Applicative+import qualified Project+import           System.Directory+import           System.IO++-- |Command arguments+commandArgs :: Parser CommandArgs+commandArgs = NewCmd <$> newArgs+  where+    newArgs = NewArgs+      <$> strOption ( long "name"+        <> short 'n'+        <> metavar "NAME"+        <> help "Project name" )++-- |Command dispatch+dispatch :: Args -> Log.Logger+dispatch (Args _ (NewCmd args)) = do+  Log.pushTag "new"++  let name = projectName args+  Log.info $ "create project into directory: " ++ name+  Log.io $ createDirectory name+  Log.io $ writeFile (name ++ "/grammar.ebnf") "(* Here comes the grammar *)"+  Log.io $ writeFile (name ++ "/.gitignore") ".pp-work/"+  let p = Project.Project name "0.0.0" "A short description" ["grammar.ebnf"] [] True []+  Project.set p++  -- End+  Log.popTag+  return ()
+ cli/Log.hs view
@@ -0,0 +1,235 @@+{-|+Module      : Log+Description : Logging system for the CLI+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module Log+    ( Logger+    , LoggerIO+    -- ** High-API+    , start+    , ok+    , setLevel+    , getLevel+    , flushAll+    , flushOutOnly+    , flushOutToFile+    , pushTag+    , popTag+    , pushTask+    , popTask+    , autoFlush+    -- ** Low-API+    , pushMsg+    , pushOut+    -- **Shortcuts+    , io+    , none+    , off+    , fatal+    , err+    , warn+    , info+    , debug+    , trace+    , abort+    , out+    , getLog+    , task+    ) where++import           Control.Monad.State+import           Data.Char+import           System.Clock++-- |Alias+type Tag = String+type Level = Int+type Task = String++-- |Logging messages+data Message+  = PushMsg Level String  -- ^Push a new message with a specific level+  | PushOut String        -- ^Push a new message to output+  | PushTag Tag           -- ^Push a new tag+  | PopTag                -- ^Pop the top tag+  | SetLevel Level        -- ^Set veborsity level+  | AutoFlush Bool        -- ^Set auto flush on/off+  | None                  -- ^Nothing to do+    deriving Show++-- |Logger+type Log = (Bool, Level, [Tag], [(Task, TimeSpec)], [Message], Bool)+type Logger = StateT Log IO ()+type LoggerIO a = StateT Log IO a++-- |IO operation+io :: IO a -> LoggerIO a+io = liftIO++-- |Pre-defined shortcuts+off = setLevel 1000+fatal m = do { pushTag "fatal"; pushMsg 60 m; popTag; ko }+err m = do { pushTag "error"; pushMsg 50 m; popTag }+warn m = do { pushTag "warning"; pushMsg 40 m; popTag }+info m = do { pushTag "info"; pushMsg 30 m; popTag }+debug m = do { pushTag "debug"; pushMsg 20 m; popTag }+trace m = do { pushTag "trace"; pushMsg 10 m; popTag }+abort = fatal "aborting..."+out = pushOut+getLog = (False, 0 :: Int, [], [], [], True)+task x = x `seq` x++-- |Start a new logger+start :: Level -> Tag -> Logger+start l t = put (False, l, [t], [], [], True)++-- |Is the logger ok ?+ok :: LoggerIO Bool+ok = do+  (_, _, _, _, _, v) <- get+  Log.io $ return v++-- |Set logger to KO+ko :: Logger+ko = do+  (af, l, ts, ks, ms, _) <- get+  put (af, l, ts, ks, ms, False)++-- |Get level+getLevel :: LoggerIO Int+getLevel = do+  (_, l, _, _, _, _) <- get+  Log.io $ return l++-- |Nothing to do+none :: Logger+none = do+  (af, l, ts, ks, ms, v) <- get+  put (af, l, ts, ks, None : ms, v)++-- |Push a new tag+pushTag :: Tag -> Logger+pushTag t = do+  (af, l, ts, ks, ms, v) <- get+  put (af, l, ts, ks, PushTag t : ms, v)++-- |Pop the top tag+popTag :: Logger+popTag = do+  (af, l, ts, ks, ms, v) <- get+  put (af, l, ts, ks, PopTag : ms, v)++-- |Push a new message with a specific level+pushMsg :: Level -> String -> Logger+pushMsg l m = do+  (af, l2, ts, ks, ms, v) <- get+  put (af, l2, ts, ks, PushMsg l m : ms, v)+  when af flushAll++-- |Push a new message to be outputed+pushOut :: String -> Logger+pushOut m = do+  (af, l, ts, ks, ms, v) <- get+  put (af, l, ts, ks, PushOut m : ms, v)+  when af flushAll++-- |Set verbosity level+setLevel :: Int -> Logger+setLevel l = do+  (af, l, ts, ks, ms, v) <- get+  put (af, l, ts, ks, SetLevel l : ms, v)++-- |Set auto flush on/off+autoFlush :: Bool -> Logger+autoFlush value = do+  (af, l, ts, ks, ms, v) <- get+  put (af, l, ts, ks, AutoFlush value : ms, v)+  when value flushAll++-- |Push a new task+pushTask :: Task -> Logger+pushTask k = do+  (af, l, ts, ks, ms, v) <- get+  start <- io $ getTime Monotonic+  put (af, l, ts, (k,start):ks, ms, v)+  pushTag "task"+  pushTag "start"+  pushMsg 30 k+  popTag+  popTag++-- |Pop the top task+popTask :: Logger+popTask = do+  (af, l, ts, (k,start):ks, ms, v) <- get+  put (af, l, ts, ks, ms, v)+  end <- io $ getTime Monotonic+  let TimeSpec { sec = _, nsec = nsec } = diffTimeSpec start end+  pushTag "task"+  pushTag "end"+  pushMsg 30 $ "in " ++ show (div nsec 1000000) ++ "ms, " ++ k+  popTag+  popTag++-- |Flush the logger to output+flushAll :: Logger+flushAll = do+  (af, l, ts, ks, ms, v) <- get+  flushAll' (af, l, ts, ks, reverse ms, v)+  where+    flushAll' l@(_, _, _, _, [], v) = put l+    flushAll' (af, l, ts, ks, PushMsg l2 m:ms, v) = do+      when (l <= l2) $ do+        io $ putTag ts+        io $ putStrLn m+      flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, PushOut m:ms, v) = do+      io $ putStrLn m+      flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, PushTag t:ms, v) = flushAll' (af, l, t:ts, ks, ms, v)+    flushAll' (af, l, _:ts, ks, PopTag:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, _, ts, ks, SetLevel l:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (_, l, ts, ks, AutoFlush af:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, None:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    putTag ts =+      putStr $ concatMap (\t -> "[" ++ map toUpper t ++ "]") (reverse ts) ++ " "++-- |Flush the output to a file+flushOutToFile :: FilePath -> Logger+flushOutToFile f = do+  (af, l, ts, ks, ms, v) <- get+  io $ writeFile f ""+  flushAll' (af, l, ts, ks, reverse ms, v)+  where+    flushAll' l@(_, _, _, _, [], v) = put l+    flushAll' (af, l, ts, ks, PushMsg l2 m:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, PushOut m:ms, v) = do+      io $ appendFile f $ m ++ "\n"+      flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, PushTag t:ms, v) = flushAll' (af, l, t:ts, ks, ms, v)+    flushAll' (af, l, _:ts, ks, PopTag:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, _, ts, ks, SetLevel l:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (_, l, ts, ks, AutoFlush af:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, None:ms, v) = flushAll' (af, l, ts, ks, ms, v)++-- |Flush output only+flushOutOnly :: Logger+flushOutOnly = do+  (af, l, ts, ks, ms, v) <- get+  flushAll' (af, l, ts, ks, reverse ms, v)+  where+    flushAll' l@(_, _, _, _, [], v) = put l+    flushAll' (af, l, ts, ks, PushMsg l2 m:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, PushOut m:ms, v) = do+      io $ putStrLn m+      flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, PushTag t:ms, v) = flushAll' (af, l, t:ts, ks, ms, v)+    flushAll' (af, l, _:ts, ks, PopTag:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, _, ts, ks, SetLevel l:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (_, l, ts, ks, AutoFlush af:ms, v) = flushAll' (af, l, ts, ks, ms, v)+    flushAll' (af, l, ts, ks, None:ms, v) = flushAll' (af, l, ts, ks, ms, v)
+ cli/Main.hs view
@@ -0,0 +1,87 @@+{-|+Module      : Main+Description : Command Line Interface for Platinum Parsing+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable++This module is the entry point for the pp-cli tool.+For more informations about this tool, please look at:+  https://github.com/chlablak/platinum-parsing+-}++module Main where++import           Args+import qualified Cmd.Build+import qualified Cmd.Ebnf+import qualified Cmd.Lalr+import qualified Cmd.New+import           Control.Monad       (void)+import           Control.Monad.State+import           Data.Semigroup      ((<>))+import qualified Log+import           Options.Applicative+import qualified Work++main :: IO ()+main = do+  args <- execParser opts+  void $ execStateT (dispatch args) Log.getLog+  where+    opts = info (args <**> helper)+      ( fullDesc+      <> progDesc "Platinum Parsing CLI"+      <> header "tools for helping PP projects" )++-- |Dispatch arguments to commands+dispatch :: Args -> Log.Logger+dispatch args@(Args cargs _) = do+  Log.start (if silent cargs then 1000000 else setLevel cargs) "pp"+  Log.autoFlush True+  Log.info "starting..."+  Log.info $ "verbosity: " +++    (if setLevel cargs == 0 then "all" else show (setLevel cargs))+  Work.path $ path cargs+  when (useWork cargs) Work.initialize+  dispatch' args+  Log.info "bye."+  where+    dispatch' :: Args -> Log.Logger+    dispatch' a@(Args _ (EbnfCmd _))  = Cmd.Ebnf.dispatch a+    dispatch' a@(Args _ (LalrCmd _))  = Cmd.Lalr.dispatch a+    dispatch' a@(Args _ (NewCmd _))   = Cmd.New.dispatch a+    dispatch' a@(Args _ (BuildCmd _)) = Cmd.Build.dispatch a++-- |Arguments+args :: Parser Args+args = Args <$> commonArgs <*> commandArgs++-- |Common arguments+commonArgs :: Parser CommonArgs+commonArgs = CommonArgs+  <$> option auto ( long "verbosity"+    <> short 'v'+    <> metavar "LEVEL"+    <> value 30+    <> help "Set verbosity level" )+  <*> switch ( long "silent"+    <> short 's'+    <> help "Verbosity off" )+  <*> switch ( long "work"+    <> short 'w'+    <> help "Use '.pp-work/' directory" )+  <*> strOption ( long "path"+    <> metavar "PATH"+    <> value "."+    <> help "Change working directory path" )++-- |Commands arguments+commandArgs :: Parser CommandArgs+commandArgs = hsubparser+  (  command "ebnf" (info Cmd.Ebnf.commandArgs (progDesc "Manipulate EBNF grammars"))+  <> command "lalr" (info Cmd.Lalr.commandArgs (progDesc "Generate LALR parsing table"))+  <> command "new" (info Cmd.New.commandArgs (progDesc "Create a new PP project"))+  <> command "build" (info Cmd.Build.commandArgs (progDesc "Build a PP project")))
+ cli/Project.hs view
@@ -0,0 +1,103 @@+{-|+Module      : Project+Description : Project system for PP ('pp.yaml' file)+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+{-# LANGUAGE OverloadedStrings #-}+module Project+    ( Project(..)+    , ProjectTemplate(..)+    , ProjectTest(..)+    , get+    , set+    ) where++import qualified Args+import           Control.Monad+import           Data.Maybe+import           Data.Yaml        ((.:), (.=))+import qualified Data.Yaml        as Y+import qualified Log+import           System.Directory+import           System.IO++-- |Project file+pFile :: String -> FilePath+pFile d = d ++ "/pp.yaml"++-- |Project configuration+data Project = Project+  { projectName        :: String+  , projectVersion     :: String+  , projectDescription :: String+  , projectGrammars    :: [String]+  , projectTemplates   :: [ProjectTemplate]+  , projectUseWork     :: Bool+  , projectTests       :: [ProjectTest]+  }+  | NoProject+  | MalformedProject String+    deriving (Eq, Show)+data ProjectTemplate = ProjectTemplate+  { templateFile :: String+  , templateDst  :: String+  } deriving (Eq, Show)+data ProjectTest = ProjectTest+  { testFile   :: String+  , testAstDst :: String+  } deriving (Eq, Show)++instance Y.FromJSON Project where+  parseJSON (Y.Object v) = Project <$> v .: "name"+                                   <*> v .: "version"+                                   <*> v .: "description"+                                   <*> v .: "grammars"+                                   <*> v .: "templates"+                                   <*> v .: "use-work"+                                   <*> v .: "tests"+instance Y.ToJSON Project where+  toJSON v = Y.object [ "name" .= projectName v+                      , "version" .= projectVersion v+                      , "description" .= projectDescription v+                      , "grammars" .= projectGrammars v+                      , "templates" .= projectTemplates v+                      , "use-work" .= projectUseWork v+                      , "tests" .= projectTests v]++instance Y.FromJSON ProjectTemplate where+  parseJSON (Y.Object v) = ProjectTemplate <$> v .: "file"+                                           <*> v .: "destination"+instance Y.ToJSON ProjectTemplate where+  toJSON v = Y.object [ "file" .= templateFile v+                      , "destination" .= templateDst v]++instance Y.FromJSON ProjectTest where+  parseJSON (Y.Object v) = ProjectTest <$> v .: "file"+                                       <*> v .: "ast"+instance Y.ToJSON ProjectTest where+  toJSON v = Y.object [ "file" .= testFile v+                      , "ast" .= testAstDst v]++-- |Get project config+get :: Log.LoggerIO Project+get = do+  let f = pFile "."+  e <- Log.io $ doesFileExist f+  if e then do+    p <- Log.io (Y.decodeFileEither f :: IO (Either Y.ParseException Project))+    case p of+      Left err -> return $ MalformedProject $ show err+      Right q  -> return q+  else+    return NoProject++-- |Set project config+set :: Project -> Log.Logger+set p = do+  e <- Log.io $ doesFileExist $ pFile "."+  let f = if e then "." else projectName p+  Log.io $ Y.encodeFile (pFile f) p
+ cli/Work.hs view
@@ -0,0 +1,173 @@+{-|+Module      : Work+Description : Work system for PP ('.pp-work/' directory)+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+{-# LANGUAGE OverloadedStrings #-}+module Work+    ( initialize+    , reuse+    , path+    ) where++import           Control.Monad+import           Data.Binary+import           Data.Hash+import           Data.Maybe+import qualified Data.Text        as T+import           Data.Yaml        ((.:), (.=))+import qualified Data.Yaml        as Y+import qualified Log+import           System.Directory+import           System.IO++-- |Work's directory+wDir :: FilePath -> FilePath+wDir p = ".pp-work/" ++ p+wDir2 a b = wDir a ++ "/" ++ b+wFile = wDir "work.yaml"++-- |Change working directory+path :: FilePath -> Log.Logger+path p = do+  e <- Log.io $ doesDirectoryExist p+  if e then do+    Log.io $ setCurrentDirectory p+    Log.info $ "working directory set to: " ++ p+  else+    Log.err $ "path doesn't exist: " ++ p++-- |Initialize module if necessary+initialize :: Log.Logger+initialize = do+  cwd <- Log.io getCurrentDirectory+  Log.info $ "current working directory: " ++ cwd+  e <- exists $ wDir ""+  unless e $ do+    Log.info $ "create directory: " ++ wDir ""+    Log.io $ createDirectory $ wDir ""+    Log.io $ writeFile wFile ""++-- |Reuse previous computation, if any+reuse :: (Binary a) => Bool -> FilePath -> String -> Log.LoggerIO a -> Log.LoggerIO a+reuse w p k c = do+  Log.pushTag "work"+  r <-  if w then do+          m <- modified p k+          if m then do+            Log.info $ show (p, k) ++ " modified, use computation and save"+            computeAndSave p k c+          else do+            Log.info $ show (p, k) ++ " not modified"+            e <- exists' p k+            if e then do+              Log.info "use previous work"+              load p k+            else do+              Log.info "no previous work, use computation and save"+              computeAndSave p k c+        else do+          Log.info "disabled, use computation"+          c+  Log.popTag+  return r+  where+    computeAndSave p k c = do+      v <- c+      save p k v+      register p k+      return v++-- |Save a binary file+save :: (Binary a) => FilePath -> String -> a -> Log.Logger+save p k v = do+  (n, _) <- getHash p+  Log.io $ createDirectoryIfMissing False (wDir n)+  Log.io $ encodeFile (wDir2 n k) v++-- |Load a binary file+load :: (Binary a) => FilePath -> String -> Log.LoggerIO a+load p k = do+  (n, _) <- getHash p+  Log.io $ decodeFile $ wDir2 n k++-- |Check if a file exists+exists :: FilePath -> Log.LoggerIO Bool+exists p = Log.io $ doesPathExist p+exists' p k = do+  (n, _) <- getHash p+  exists $ wDir2 n k++-- |Register a file state+register :: FilePath -> String -> Log.Logger+register p k = do+  (n, v) <- getHash p+  c <- getConfig+  setConfig $ case filter (\f -> fileid f == n) (files c) of+    [] -> Config $ ConfigFile p n [ConfigHash k v] : files c+    [f] -> Config $ ConfigFile p n+      (ConfigHash k v : filter (\h -> hashname h /= k) (filehash f))+        : filter (\f -> fileid f /= n) (files c)++-- |Check if a file has changed+modified :: FilePath -> String -> Log.LoggerIO Bool+modified p k = do+  (n, v) <- getHash p+  c <- getConfig+  case filter (\f -> fileid f == n) (files c) of+    [] -> return True+    [f] -> case filter (\h -> hashname h == k) (filehash f) of+      []  -> return True+      [h] -> return $ hashvalue h /= v++-- |Get the hash of a file+getHash :: FilePath -> Log.LoggerIO (String, String)+getHash p = do+  f <- Log.io $ readFile p+  return (hash' p, hash' f)+  where+    hash' = show . asWord64 . hash++-- |Working file structure+newtype Config = Config+  { files :: [ConfigFile]+  } deriving (Eq, Show)+data ConfigFile = ConfigFile+  { filepath :: FilePath+  , fileid   :: String+  , filehash :: [ConfigHash]+  } deriving (Eq, Show)+data ConfigHash = ConfigHash+  { hashname  :: String+  , hashvalue :: String+  } deriving (Eq, Show)++instance Y.FromJSON Config where+  parseJSON (Y.Object v) = Config <$> v .: "files"+  parseJSON _            = return $ Config []+instance Y.ToJSON Config where+  toJSON v = Y.object ["files" .= files v]++instance Y.FromJSON ConfigFile where+  parseJSON (Y.Object v) = ConfigFile <$> v .: "path" <*> v .: "id" <*> v .: "hash"+instance Y.ToJSON ConfigFile where+  toJSON v = Y.object ["path" .= filepath v, "id" .= fileid v, "hash" .= filehash v]++instance Y.FromJSON ConfigHash where+  parseJSON (Y.Object v) = ConfigHash <$> v .: "name" <*> v .: "value"+instance Y.ToJSON ConfigHash where+  toJSON v = Y.object ["name" .= hashname v, "value" .= hashvalue v]++-- |Get the config+getConfig :: Log.LoggerIO Config+getConfig = do+  c <- Log.io $ Y.decodeFile wFile+  return $ fromMaybe (Config []) c++-- |Set the config+setConfig :: Config -> Log.Logger+setConfig c = Log.io $ Y.encodeFile wFile c
+ platinum-parsing.cabal view
@@ -0,0 +1,103 @@+name:                platinum-parsing+version:             0.1.0.0+synopsis:            General Framework for compiler development.+description:         Platinum Parsing provides many tools for the development of compiler (including transpiler or interpreter), based on the well-known Dragon Book (2nd edition). This package is in progress, please take a look at the github repository for more details.+homepage:            https://github.com/chlablak/platinum-parsing+license:             BSD3+license-file:        LICENSE+author:              chlablak+maintainer:          chlablak@gmail.com+copyright:           2017, Patrick Champion+category:            compiler, compilation, parser, lexer, lalr, framework, cli+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     PP+                     , PP.Builder+                     , PP.Builders.Lalr+                     , PP.Builders.Lr1+                     , PP.Builders.Dfa+                     , PP.Builders.Nfa+                     , PP.Grammar+                     , PP.Grammars.Ebnf+                     , PP.Grammars.Lexical+                     , PP.Grammars.LexicalHelper+                     , PP.Lexer+                     , PP.Lexers.Dfa+                     , PP.Parser+                     , PP.Parsers.Lr+                     , PP.Rule+                     , PP.Template+                     , PP.Templates.Dfa+                     , PP.Templates.Lr+  build-depends:       base >= 4.7 && < 5+                     , parsec >= 3.1 && < 3.2+                     , text >= 1.2 && < 1.3+                     , containers >= 0.5 && < 0.6+                     , vector >= 0.11 && < 0.12+                     , HStringTemplate >= 0.8 && < 0.9+                     , fgl >= 5.5 && < 5.6+                     , mtl >= 2.2 && < 2.3+                     , binary >= 0.8 && < 0.9+  default-language:    Haskell2010++executable pp+  hs-source-dirs:      cli+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  other-modules:       Args+                     , Cmd.Ebnf+                     , Cmd.Lalr+                     , Cmd.New+                     , Cmd.Build+                     , Log+                     , Work+                     , Project+  build-depends:       base >= 4.7 && < 5+                     , platinum-parsing+                     , optparse-applicative >= 0.13 && < 0.14+                     , vector >= 0.11 && < 0.12+                     , containers >= 0.5 && < 0.6+                     , mtl >= 2.2 && < 2.3+                     , clock >= 0.7 && < 0.8+                     , fgl >= 5.5 && < 5.6+                     , directory >= 1.3 && < 1.4+                     , binary >= 0.8 && < 0.9+                     , data-hash >= 0.2 && < 0.3+                     , yaml >= 0.8 && < 0.9+                     , text >= 1.2 && < 1.3+  default-language:    Haskell2010++test-suite pp-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:       PPTest.Builders.Lalr+                     , PPTest.Builders.Lr1+                     , PPTest.Builders.Dfa+                     , PPTest.Builders.Nfa+                     , PPTest.Grammars.Ebnf+                     , PPTest.Grammars.Lexical+                     , PPTest.Grammars.LexicalHelper+                     , PPTest.Lexers.Dfa+                     , PPTest.Other.LexerDfaParserLr+                     , PPTest.Rule+                     , PPTest.Parsers.Lr+                     , PPTest.Templates.Lr+                     , PPTest.Templates.Dfa+                     , PPTest.Template+  build-depends:       base >= 4.7 && < 5+                     , platinum-parsing+                     , hspec >= 2.4 && < 2.5+                     , containers >= 0.5 && < 0.6+                     , vector >= 0.11 && < 0.12+                     , fgl >= 5.5 && < 5.6+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/chlablak/platinum-parsing
+ src/PP.hs view
@@ -0,0 +1,28 @@+{-|+Module      : PP+Description : Global import for all PP functionnalities+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable++This module imports all functionnalities of Platinum Parsing.+For more informations about this tool, please look at:+  https://github.com/chlablak/platinum-parsing+-}+module PP+    ( module PP.Builder+    , module PP.Grammar+    , module PP.Lexer+    , module PP.Parser+    , module PP.Rule+    , module PP.Template+    ) where++import           PP.Builder+import           PP.Grammar+import           PP.Lexer+import           PP.Parser+import           PP.Rule+import           PP.Template
+ src/PP/Builder.hs view
@@ -0,0 +1,153 @@+{-|+Module      : PP.Builder+Description : Common behavior for defined builders+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}+module PP.Builder+    ( -- *(LA)LR+      LrTable(..)+    , action+    , action'+    , LrAction(..)+    , LrCollection(..)+    , LrSet(..)+    , LrBuilder(..)+      -- *NFA+    , NfaGraph(..)+    , NfaNode(..)+    , NfaSymbol(..)+    , NfaBuilder(..)+      -- *DFA+    , DfaGraph(..)+    , DfaNode(..)+    , DfaSymbol(..)+    , DfaBuilder(..)+    ) where++import           Control.Monad+import           Data.Binary+import qualified Data.Graph.Inductive.Graph        as Gr+import qualified Data.Graph.Inductive.PatriciaTree as Gr+import qualified Data.Map.Strict                   as Map+import           Data.Maybe+import qualified Data.Set                          as Set+import qualified Data.Vector                       as Vector+import           PP.Lexer                          (OToken (..))+import           PP.Rule++-- |All LR parsers have the same table format+type LrTable = Map.Map (Int, Rule) LrAction++-- |Get a LrAction from a LrTable (Rule version)+action :: LrTable -> Int -> Rule -> LrAction+action t i r    = fromMaybe LrError (Map.lookup (i, r) t)++-- |Get a LrAction from a LrTable (OToken version)+action' :: LrTable -> Int -> [OToken] -> LrAction+action' t i []                = action t i Empty+action' t i (OToken1 []:_)    = action t i Empty+action' t i (OToken1 (x:_):_) = action t i $ Term x+action' t i (OToken2 _ s:_)   = action t i $ TermToken s++-- |LR actions for a LR parser+data LrAction+  = LrShift Int+  | LrReduce Rule+  | LrGoto Int+  | LrError+  | LrAccept+    deriving(Eq)++instance Show LrAction where+  show (LrShift i)  = "shift " ++ show i+  show (LrReduce r) = "reduce " ++ show r+  show (LrGoto i)   = "goto " ++ show i+  show LrError      = "error"+  show LrAccept     = "accept"++instance Binary LrAction where+  put (LrShift i)  = putWord8 0 >> put i+  put (LrReduce r) = putWord8 1 >> put r+  put (LrGoto i)   = putWord8 2 >> put i+  put LrError      = putWord8 3+  put LrAccept     = putWord8 4+  get = do+    tag <- getWord8+    case tag of+      0 -> fmap LrShift get+      1 -> fmap LrReduce get+      2 -> fmap LrGoto get+      3 -> return LrError+      4 -> return LrAccept++-- |LR items set collection+type LrCollection item = Vector.Vector (LrSet item)++instance (Binary item) => Binary (LrCollection item) where+  put c = put $ Vector.toList c+  get = fmap Vector.fromList get++-- |LR items set+type LrSet item = Set.Set item++-- |LR parser common functions+class Ord item => LrBuilder item where+  -- |Build the items set collection+  collection :: RuleSet -> FirstSet -> LrCollection item+  -- |Build the parsing table+  table :: LrCollection item -> Either [String] LrTable++-- |Nondeterministic finite automaton (NFA)+type NfaGraph = Gr.Gr NfaNode NfaSymbol++-- |NFA node type+data NfaNode = NfaInitial | NfaNode | NfaFinal String deriving (Eq, Ord, Show, Read)++-- |NFA symbol type+data NfaSymbol = NfaValue Char | NfaEmpty deriving (Eq, Ord, Show, Read)++-- |NFA builders+class NfaBuilder from where+  buildNfa :: from -> NfaGraph+  buildNfa' :: String -> from -> NfaGraph++-- |Deterministic finite automaton (DFA)+type DfaGraph = Gr.Gr DfaNode DfaSymbol++-- |DFA node type+data DfaNode = DfaInitial | DfaNode | DfaFinal String deriving (Eq, Ord, Show, Read)++-- |DFA symbol type+newtype DfaSymbol = DfaValue Char deriving (Eq, Ord, Read)++instance Show DfaSymbol where+  show (DfaValue c) = show c++instance Binary DfaGraph where+  put g = put (Gr.labNodes g) >> put (Gr.labEdges g)+  get = liftM2 Gr.mkGraph get get++instance Binary DfaNode where+  put DfaInitial   = putWord8 0+  put DfaNode      = putWord8 1+  put (DfaFinal s) = putWord8 2 >> put s+  get = do+    tag <- getWord8+    case tag of+      0 -> return DfaInitial+      1 -> return DfaNode+      2 -> fmap DfaFinal get++instance Binary DfaSymbol where+  put (DfaValue c) = put c+  get = fmap DfaValue get++-- |DFA builders+class DfaBuilder from where+  buildDfa :: from -> DfaGraph
+ src/PP/Builders/Dfa.hs view
@@ -0,0 +1,101 @@+{-|+Module      : PP.Builders.Dfa+Description : Builder for DFA+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}+module PP.Builders.Dfa+    (+    ) where++import qualified Data.Graph.Inductive.Graph as Gr+import qualified Data.List                  as L+import qualified Data.Map.Strict            as Map+import           Data.Maybe+import           PP.Builder++instance DfaBuilder NfaGraph where+  buildDfa nfa = removeDeadState $ Gr.mkGraph nodes edges+    where+      nodes = map (\k -> (k, findType k)) indices+      indices = L.nub $ map (\((k, _), _) -> k) ilist+      edges = map (\((k, NfaValue a), v) -> (k, v, DfaValue a)) ilist+      ilist = map (\((k, a), v) -> ((index k, a), index v)) list+      index = (Map.!) $ Map.fromList $ zip unique [0..]+      rindex = (Map.!) $ Map.fromList $ zip [0..] unique+      unique = L.nub $ map (\((k, _), _) -> k) list+      list = Map.toList $ buildSubSet nfa+      findType i = foldl findType' DfaNode $ map (toDfa . findType'') $ rindex i+      findType' DfaInitial _   = DfaInitial+      findType' _ DfaInitial   = DfaInitial+      findType' (DfaFinal n) _ = DfaFinal n+      findType' _ (DfaFinal n) = DfaFinal n+      findType' _ _            = DfaNode+      findType'' i = fromMaybe NfaNode $ Gr.lab nfa i+      toDfa NfaNode      = DfaNode+      toDfa NfaInitial   = DfaInitial+      toDfa (NfaFinal n) = DfaFinal n++-- |Build a transition table with "subset" algorithm+-- Dragon Book (2nd edition, fr), page 140, algorithm 3.20+buildSubSet :: NfaGraph -> Map.Map ([Gr.Node], NfaSymbol) [Gr.Node]+buildSubSet g = buildSubSet' (mark (emptyClosure [initial] g) Map.empty)+                             [emptyClosure [initial] g]         -- not marked+  where+    buildSubSet' acc []     = Map.filterWithKey isNotEmpty acc+    buildSubSet' acc (x:xs) = buildSubSet'' acc x xs (symbols g)+    buildSubSet'' acc _ xs [] = buildSubSet' acc xs+    buildSubSet'' acc x xs (a:as) =+      let u = emptyClosure (transition x a g) g in+        if Map.notMember (u, NfaEmpty) acc then+          buildSubSet'' (mark u $ ins x a u acc) x (u:xs) as+        else+          buildSubSet'' (ins x a u acc) x xs as+    ins d a = Map.insert (d, a)+    mark d = ins d NfaEmpty []+    initial = let [(i, _)] = filter isInitial (Gr.labNodes g) in i+    isInitial (_, NfaInitial) = True+    isInitial _               = False+    isNotEmpty (_, NfaEmpty) _ = False+    isNotEmpty _ _             = True++-- |Returns all symbols in the NFA+symbols :: NfaGraph -> [NfaSymbol]+symbols = L.sort . L.nub . map (\(_, _, v) -> v) . filter isValue . Gr.labEdges+  where+    isValue (_, _, NfaValue _) = True+    isValue _                  = False++-- |Find all nodes reachable by an empty symbol, for each starting nodes+emptyClosure :: [Gr.Node] -> NfaGraph -> [Gr.Node]+emptyClosure ns g = emptyClosure' ns ns+  where+    emptyClosure' acc []     = L.sort acc+    emptyClosure' acc (x:xs) = emptyClosure'' acc xs (suc x)+    emptyClosure'' acc ns []     = emptyClosure' acc ns+    emptyClosure'' acc ns (u:us) =+      if u `notElem` acc then+        emptyClosure'' (u:acc) (u:ns) us+      else+        emptyClosure'' acc ns us+    suc n = transition [n] NfaEmpty g++-- |Find successors nodes of starting nodes, linked by the symbol+transition :: [Gr.Node] -> NfaSymbol -> NfaGraph -> [Gr.Node]+transition ns s g = L.sort $ L.nub $ map fst $ filter (\(_, l) -> l == s) suc+  where+    suc = concat [Gr.lsuc g i | i <- ns]++-- |Remove dead states in the DFA+removeDeadState :: DfaGraph -> DfaGraph+removeDeadState g = Gr.labnfilter isNotDead g+  where+    isNotDead (n, DfaNode) =+      let (_, _, _, suc) = Gr.context g n in+        any (\(_, i) -> i /= n) suc+    isNotDead _            = True
+ src/PP/Builders/Lalr.hs view
@@ -0,0 +1,143 @@+{-|+Module      : PP.Builders.Lalr+Description : Builder for LALR parsers+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Builders.Lalr+    ( LalrItem(..)+    ) where++import           Control.Monad+import           Data.Binary+import qualified Data.List       as L+import qualified Data.Map.Strict as Map+import           Data.Maybe+import qualified Data.Set        as Set+import qualified Data.Vector     as Vector+import           PP.Builder+import           PP.Builders.Lr1+import           PP.Rule++-- |LALR item+data LalrItem = LalrItem Rule Int Rule+  deriving (Eq, Ord)++instance Show LalrItem where+  show (LalrItem (Rule a xs) p la) =+    "[" ++ a ++ " -> " ++ right xs p ++ "; " ++ show la ++ "]"+    where+      right :: [Rule] -> Int -> String+      right [] _     = ""+      right xs 0     = "*," ++ right xs (-1)+      right [x] _    = show x+      right (x:xs) p = show x ++ "," ++ right xs (p - 1)++instance Binary LalrItem where+  put (LalrItem r p la) = put r >> put p >> put la+  get = liftM3 LalrItem get get get++-- |LrBuilder instance for LalrItem+instance LrBuilder LalrItem where+  collection rs fs = fusion (collection rs fs :: LrCollection Lr1Item)+  -- Dragon Book (2nd edition, fr), page 243, algorithm 4.56 (without step 1)+  table c = case actions of+    Right act -> Right $ Map.union (Map.fromList act) (Map.fromList gotos)+    Left err  -> Left err+    where+      actions = let act = shifts ++ reduces ++ accepts in+        case conflict [] [] act of+          [] -> Right act+          xs -> Left xs+      conflict _ con [] = con+      conflict acc con ((k, v):xs) = case L.lookup k acc of+        Nothing -> conflict ((k,v):acc) con xs+        Just v2 -> conflict acc ((show k ++ " conflict: " ++ show v ++ " with " ++ show v2) : con) xs+      shifts = [((i, s), LrShift $ fromJust j)+              | i <- [0..(Vector.length c - 1)]+              , let is = c Vector.! i+              , s <- symbol is+              , term s+              , let j = next gs i s+              , isJust j]+      reduces = [((i, la), LrReduce r)+               | i <- [0..(Vector.length c - 1)]+               , let is = c Vector.! i+               , x@(LalrItem r@(Rule s _) _ la) <- reductibles is+               , s /= "__start"]+      accepts = [((i, Empty), LrAccept)+               | i <- [0..(Vector.length c - 1)]+               , let is = c Vector.! i+               , acc is]+      gotos = [((i, s), LrGoto $ fromJust j)+             | i <- [0..(Vector.length c - 1)]+             , let is = c Vector.! i+             , s <- symbol is+             , nonTerm s+             , let j = next gs i s+             , isJust j]+      term (Term _)      = True+      term (TermToken _) = True+      term _             = False+      reductibles is = [x | x <- Set.toList is, reductible x]+      reductible (LalrItem (Rule _ xs) p _) = L.length xs == p + 1+      acc = not . Set.null . Set.filter+        (\(LalrItem (Rule s _) p la) -> s == "__start" && p == 1 && la == Empty)+      nonTerm (NonTerm _) = True+      nonTerm _           = False+      gs = gotoSet c++-- |Construct the GOTO table+type GotoSet = Map.Map (Int, Rule) Int+gotoSet :: LrCollection LalrItem -> GotoSet+gotoSet c = Map.fromList [((i, s), fromJust j)+                        | i <- [0..(Vector.length c - 1)]+                        , let is = c Vector.! i+                        , s <- symbol is+                        , let j = goto c i s+                        , isJust j]++-- |Get the next items set+next :: GotoSet -> Int -> Rule -> Maybe Int+next gs i r = Map.lookup (i, r) gs++-- |Find the next possible symbols+symbol :: LrSet LalrItem -> [Rule]+symbol is = L.sort $ L.nub [x+                          | LalrItem (Rule _ xs) p _ <- Set.toList is+                          , let x = xs !! p+                          , x /= Empty]++-- |Find the next set+goto :: LrCollection LalrItem -> Int -> Rule -> Maybe Int+goto c i = goto' (c Vector.! i)+  where+    goto' is r = case list is r of+      []    -> Nothing+      (x:_) -> find $ inc x+    find x = Vector.findIndex (Set.member x) c+    list is r = [x | x <- Set.toList is, accept x r]+    accept (LalrItem (Rule _ xs) p _) r = xs !! p == r+    inc (LalrItem r p la) = LalrItem r (p + 1) la++-- |Compute the LALR collection from a LR(1) collection+-- Dragon Book (2nd edition, fr), page 246, example 4.60+fusion :: LrCollection Lr1Item -> LrCollection LalrItem+fusion lr1 = Vector.foldl' fusion' Vector.empty lalr+  where+    fusion' acc is = case core acc is of+      []  -> acc+      [_] -> Vector.snoc acc is+      xs  -> Vector.snoc acc (Set.unions xs)+    core acc is = [isx | isx <- Vector.toList lalr, same isx is, unique isx acc]+    unique is acc = L.null [0 | isx <- Vector.toList acc, same is isx]+    same isa isb = component isa == component isb+    component = Set.toList . Set.map (\(LalrItem r p _) -> (r, p))+    lalr = toLalrItem lr1++-- |Transform Lr1Item into LalrItem+toLalrItem :: LrCollection Lr1Item -> LrCollection LalrItem+toLalrItem = Vector.map (Set.map (\(Lr1Item r p la) -> LalrItem r p la))
+ src/PP/Builders/Lr1.hs view
@@ -0,0 +1,84 @@+{-|+Module      : PP.Builders.Lr1+Description : Builder for LR(1) parsers+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Builders.Lr1+    ( Lr1Item(..)+    ) where++import qualified Data.List   as L+import qualified Data.Set    as Set+import qualified Data.Vector as Vector+import           PP.Builder+import           PP.Rule++-- |LR(1) item+data Lr1Item = Lr1Item Rule Int Rule+  deriving (Eq, Ord)++instance Show Lr1Item where+  show (Lr1Item (Rule a xs) p la) =+    "[" ++ a ++ " -> " ++ right xs p ++ "; " ++ show la ++ "]"+    where+      right :: [Rule] -> Int -> String+      right [] _     = ""+      right xs 0     = "*," ++ right xs (-1)+      right [x] _    = show x+      right (x:xs) p = show x ++ "," ++ right xs (p - 1)++-- |LrBuilder instance for Lr1Item+-- Dragon Book (2nd edition, fr), page 239, algorithm 4.53+instance LrBuilder Lr1Item where+  collection rs fs = collection' initialise+    where+      collection' c = case list c of+        [] -> c+        xs -> collection' $ c Vector.++ Vector.fromList xs+      list c = [g+              | is <- Vector.toList c+              , x <- symbol is+              , let g = goto is x rs fs+              , accept g c]+      accept is c = not (Set.null is) && Vector.notElem is c+      symbol is = L.nub [x+                       | Lr1Item (Rule _ xs) p _ <- Set.toList is+                       , let x = xs !! p+                       , x /= Empty]+      initialise =+        Vector.singleton $ closure (Set.singleton start) rs fs+      start = Lr1Item (head $ rule "__start" rs) 0 Empty++  -- |Not impl. yet+  table = undefined++-- |Compute the closure of a items set+closure :: LrSet Lr1Item -> RuleSet -> FirstSet -> LrSet Lr1Item+closure is rs fs = case list is rs fs of+  [] -> is+  xs -> Set.union is $ closure (Set.fromList xs) rs fs+  where+    list is rs fs = [Lr1Item r 0 t+                   | i <- Set.toList is+                   , r <- rule (next i) rs+                   , t <- term i fs]+    next (Lr1Item (Rule _ xs) pos _) = case xs !! pos of+      (NonTerm r) -> r+      _           -> ""+    term (Lr1Item (Rule _ xs) pos la) fs = case xs !! (pos + 1) of+      Empty -> first la fs+      r     -> let r' = first r fs in+        if Empty `L.elem` r'+          then L.nub $ r' ++ first la fs+          else r'++-- |Compute the GOTO of a items set for a given rule+goto :: LrSet Lr1Item -> Rule -> RuleSet -> FirstSet -> LrSet Lr1Item+goto is r = closure $ Set.fromList [inc i | i <- Set.toList is, accept i r]+  where+    inc (Lr1Item r p la) = Lr1Item r (p + 1) la+    accept (Lr1Item (Rule _ xs) p _) r = xs !! p == r
+ src/PP/Builders/Nfa.hs view
@@ -0,0 +1,155 @@+{-|+Module      : PP.Builders.Nfa+Description : Builder for NFA+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Builders.Nfa+    ( combineNfa+    ) where++import qualified Data.Char                  as C+import qualified Data.Graph.Inductive.Graph as Gr+import qualified Data.List                  as L+import           PP.Builder+import           PP.Grammar+import           PP.Grammars.Lexical++-- |Build a NFA from a RegExpr+-- Dragon Book (2nd edition, fr), page 146, algorithm 3.23+instance NfaBuilder RegExpr where+  buildNfa re = buildNfa' (stringify re) re+  buildNfa' n (RegExpr [])  = buildSym n NfaEmpty+  buildNfa' n (RegExpr [x]) = buildNfa' n x+  buildNfa' n (RegExpr xs)  = union n $ map (buildNfa' n) xs+  buildNfa' n (Choice [])   = buildSym n NfaEmpty+  buildNfa' n (Choice [x])  = buildNfa' n x+  buildNfa' n (Choice xs)   = foldl1 concatenate $ map (buildNfa' n) xs+  buildNfa' n (Many0 x)     = kleeneStar $ buildNfa' n x+  buildNfa' n (Many1 x)     = kleenePlus $ buildNfa' n x+  buildNfa' n (Option x)    = option $ buildNfa' n x+  buildNfa' n (Group x)     = buildNfa' n x+  buildNfa' n (Value c)     = buildSym n $ NfaValue c+  buildNfa' n classes       = buildNfa' n $ buildClasses classes++-- |Build a simple NFA+buildSym :: String -> NfaSymbol -> NfaGraph+buildSym n s = Gr.mkGraph [(0,NfaInitial),(1,NfaFinal n)] [(0,1,s)]++-- |Extract values from a class+buildClasses :: RegExpr -> RegExpr+buildClasses (Class xs)     = RegExpr $ L.nub [ c+                                              | x <- xs+                                              , let (RegExpr cs)= buildClasses x+                                              , c <- cs]+buildClasses (Interval a b) = RegExpr [Value c | c <- [a..b]]+buildClasses Any            = RegExpr [ Value c+                                      | c <- [minBound..maxBound]+                                      , C.isAscii c]+buildClasses v@(Value _)    = RegExpr [v]++-- |Concatenate two NFA+concatenate :: NfaGraph -> NfaGraph -> NfaGraph+concatenate a b = Gr.mkGraph (an2 ++ bn) (ae ++ be)+  where+    an2 = map (\n@(i, _) -> if i == final then (i, NfaNode) else n) an+    bn = map (\(i, n) -> (i + final, n)) $ filter isNotInitial $ Gr.labNodes b+    ae = Gr.labEdges a+    be = map (\(i, j, e) -> (i + final, j + final, e)) $ Gr.labEdges b+    final = ifinal a+    an = Gr.labNodes a++-- |Union a list of NFA+union :: String -> [NfaGraph] -> NfaGraph+union n gs = Gr.mkGraph (nodesU ++ nodes3) (edgesU ++ edges2)+  where+    nodes3 = map (\(i, _) -> (i, NfaNode)) nodes2+    nodesU = [(0,NfaInitial),(final,NfaFinal n)]+    edgesU = [ (i,j,NfaEmpty)+             | n <- nodes2+             , isNotNode n+             , let (i,j) = getIJ n]+    nodes2 = concat $ add $ zip diff nodes+    edges2 = concat $ adde $ zip diff edges+    nodes = map Gr.labNodes gs+    edges = map Gr.labEdges gs+    getIJ (j, NfaInitial) = (0, j)+    getIJ (i, NfaFinal _) = (i, final)+    final = last diff+    diff = diff' nodes 1+    diff' [] d     = [d]+    diff' (x:xs) d = d : diff' xs (d + length x)+    add = map add'+    add' (d, xs) = map (add'' d) xs+    add'' d (i, n) = (i + d, n)+    adde = map adde'+    adde' (d, xs) = map (adde'' d) xs+    adde'' d (i, j, n) = (i + d, j + d, n)++-- |For a NFA `x`, returns the NFA for `x*` (Kleene star)+kleeneStar :: NfaGraph -> NfaGraph+kleeneStar g = Gr.mkGraph (nodes2 ++ nodesK) (edges2 ++ edgesK)+  where+    nodesK = [(initial-1,NfaInitial),(final+1,NfaFinal finalN)]+    edgesK = [(initial-1,initial,NfaEmpty),+              (final,final+1,NfaEmpty),+              (initial-1,final+1,NfaEmpty)]+    nodes2 = map (\(i, _) -> (i, NfaNode)) nodes+    edges2 = (final,initial,NfaEmpty) : edges+    final = let [(i, _)] = filter isFinal nodes in i+    finalN = let [(_, NfaFinal n)] = filter isFinal nodes in n+    initial = let [(i, _)] = filter isInitial nodes in i+    nodes = map (\(i, n) -> (i + 1, n)) $ Gr.labNodes g+    edges = map (\(i, j, e) -> (i + 1, j + 1, e)) $ Gr.labEdges g++-- |For a NFA `x`, returns the NFA for `x+` (Kleene plus)+kleenePlus :: NfaGraph -> NfaGraph+kleenePlus g = Gr.delEdge (iinitial g', ifinal g') g'+  where+    g' = kleeneStar g++-- |For a NFA `x`, returns the NFA for `x?`+option :: NfaGraph -> NfaGraph+option g = Gr.delEdge (ifinal g' - 1, iinitial g' + 1) g'+  where+    g' = kleeneStar g++-- |Combine multiple NFA in one+combineNfa :: [NfaGraph] -> NfaGraph+combineNfa gs = Gr.mkGraph (nodesU ++ nodes3) (edgesU ++ edges2)+  where+    nodes3 = map (\n@(i, _) -> if isFinal n then n else (i, NfaNode)) nodes2+    nodesU = [(0,NfaInitial)]+    edgesU = [ (i,j,NfaEmpty)+             | n <- nodes2+             , isInitial n+             , let (i,j) = getIJ n]+    nodes2 = concat $ add $ zip diff nodes+    edges2 = concat $ adde $ zip diff edges+    nodes = map Gr.labNodes gs+    edges = map Gr.labEdges gs+    getIJ (j, NfaInitial) = (0, j)+    diff = diff' nodes 1+    diff' [] d     = []+    diff' (x:xs) d = d : diff' xs (d + length x)+    add = map add'+    add' (d, xs) = map (add'' d) xs+    add'' d (i, n) = (i + d, n)+    adde = map adde'+    adde' (d, xs) = map (adde'' d) xs+    adde'' d (i, j, n) = (i + d, j + d, n)++-- Utilities+iinitial g = let [(i, _)] = filter isInitial (Gr.labNodes g) in i+ifinal g = let [(i, _)] = filter isFinal (Gr.labNodes g) in i+isFinal (_, NfaFinal _) = True+isFinal _               = False+isInitial (_, NfaInitial) = True+isInitial _               = False+isNotNode (_, NfaNode) = False+isNotNode _            = True+isNotInitial (_, NfaInitial) = False+isNotInitial _               = True
+ src/PP/Grammar.hs view
@@ -0,0 +1,47 @@+{-|+Module      : PP.Grammar+Description : Common behavior for defined grammars+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Grammar+    ( To+    , InputGrammar(..)+    , rules'+    ) where++import           Control.Exception+import           Data.Either+import           PP.Rule           (Rule)+import qualified Text.Parsec       as P++-- |Syntactic sugar+-- For exemple: `case PP.parseAst input :: (PP.To Ebnf.Syntax) of ...`+type To ast = Either P.ParseError ast++-- |Type class for grammars+class (Eq ast, Show ast) => InputGrammar ast where+  -- |Entry parser+  parser :: P.Parsec String () ast+  -- |Parse String to AST+  parseAst :: String -> To ast+  parseAst = P.parse parser ""+  -- |AST to String+  stringify :: ast -> String+  stringify = show+  -- |AST to canonical rules+  rules :: ast -> [Rule]+  -- |Transform terminals to lexical rules+  lexify :: ast -> ast+  lexify = id++-- |Exception-safe version of `rules`+rules' :: (InputGrammar ast) => ast -> IO (Either String [Rule])+rules' ast = do+    a <- try (evaluate $ rules ast) :: IO (Either SomeException [Rule])+    case a of+        Left e  -> return $ Left $ head $ lines $ displayException e+        Right r -> return $ Right r
+ src/PP/Grammars/Ebnf.hs view
@@ -0,0 +1,292 @@+{-|+Module      : PP.Grammars.Ebnf+Description : Defines a AST and parser for the EBNF language+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable++AST for the EBNF language.+Based on the grammar given in the ISO/IEC 14977:1996, page 10, part 8.2.+Comments are valid in EBNF, but are not present in this AST.+-}+module PP.Grammars.Ebnf+    ( -- * AST+      Syntax(..)+      -- ** Inner ASTs+    , SyntaxRule(..)+    , DefinitionsList(..)+    , SingleDefinition(..)+    , Term(..)+    , Exception(..)+    , Factor(..)+    , Primary(..)+    , MetaIdentifier(..)+    ) where++import           Control.Applicative                    ((<$>), (<*>))+import qualified Data.List                              as L+import           Data.Maybe+import           Data.Text                              (pack, strip, unpack)+import           PP.Grammar+import           PP.Grammars.LexicalHelper              (LexicalRule,+                                                         lexicalString)+import qualified PP.Rule                                as R+import           Text.ParserCombinators.Parsec+import           Text.ParserCombinators.Parsec.Language (emptyDef)+import qualified Text.ParserCombinators.Parsec.Token    as Token++-- |Start rule+newtype Syntax = Syntax [SyntaxRule]+  deriving (Show, Eq)++-- |Syntax rule+data SyntaxRule+  -- |Defines the sequence of symbols represented by a MetaIdentifier+  = SyntaxRule MetaIdentifier DefinitionsList+  -- |Defines a lexical definition inside the EBNF grammar+  | LexicalInner LexicalRule+    deriving (Show, Eq)++-- |Separates alternative SingleDefinition+newtype DefinitionsList = DefinitionsList [SingleDefinition]+  deriving (Show, Eq)++-- |Separates successive Term+newtype SingleDefinition = SingleDefinition [Term]+  deriving (Show, Eq)++-- |Represents any sequence of symbols that is defined by the Factor+-- but not defined by the Exception+data Term = Term Factor (Maybe Exception)+  deriving (Show, Eq)++-- |A Factor may be used as an Exception if it could be replaced by a+-- Factor containing no MetaIdentifier+newtype Exception = Exception Factor+  deriving (Show, Eq)++-- |The Integer specifies the number of repetitions of the Primay+data Factor = Factor (Maybe Integer) Primary+  deriving (Show, Eq)++-- |Primary+data Primary+  -- |Encloses symbols which are optional+  = OptionalSequence DefinitionsList+  -- |Encloses symbols which may be repeated any number of times+  | RepeatedSequence DefinitionsList+  -- |Allows any DefinitionsList to be a Primary+  | GroupedSequence DefinitionsList+  -- |A Primary can be a MetaIdentifier+  | PrimaryMetaIdentifier MetaIdentifier+  -- |Represents the characters between the quote symbols '...' or "..."+  | TerminalString String+  -- |Empty Primary+  | Empty+    deriving (Show, Eq)++-- |A MetaIdentifier is the name of a syntactic element of the langage being defined+newtype MetaIdentifier = MetaIdentifier String+  deriving (Show, Eq)++-- |Lexer definitions for EBNF+lexer = Token.makeTokenParser def+  where+    def = emptyDef {+        Token.commentStart = "(*"+      , Token.commentEnd = "*)"+      , Token.commentLine = ""+      , Token.nestedComments = False+      , Token.identStart = letter+      , Token.identLetter = alphaNum <|> oneOf "_- "+      , Token.reservedNames = []+      , Token.reservedOpNames = ["=", ";", "|", ",", "-", "*"]+      , Token.caseSensitive = True+    }++identifier = Token.identifier lexer+reservedOp = Token.reservedOp lexer+stringLiteral = Token.stringLiteral lexer+natural = Token.natural lexer+whiteSpace = Token.whiteSpace lexer+parens = Token.parens lexer+braces = Token.braces lexer+angles = Token.angles lexer+brackets = Token.brackets lexer++-- |Syntax parser+syntax :: Parser Syntax+syntax = whiteSpace *> (Syntax <$> many1 syntaxRule) <?> "syntax"++-- |SyntaxRule parser+syntaxRule :: Parser SyntaxRule+syntaxRule = try (SyntaxRule <$> (metaIdentifier <* reservedOp "=")+                             <*> (definitionsList <* reservedOp ";"))+          <|> LexicalInner <$> parser+  <?> "syntax rule"++-- |DefinitionsList parser+definitionsList :: Parser DefinitionsList+definitionsList = DefinitionsList <$> sepBy1 singleDefinition (reservedOp "|")+  <?> "definitions list"++-- |SingleDefinition parser+singleDefinition :: Parser SingleDefinition+singleDefinition = SingleDefinition <$> sepBy1 term (reservedOp ",")+  <?> "single definition"++-- |Term parser+term :: Parser Term+term = Term <$> factor <*> optionMaybe (reservedOp "-" *> exception)+  <?> "term"++-- |Exception parser+exception :: Parser Exception+exception = Exception <$> factor <?> "exception"++-- |Factor parser+factor :: Parser Factor+factor = Factor <$> optionMaybe (natural <* reservedOp "*") <*> primary+  <?> "factor"++-- |Primary parser+primary :: Parser Primary+primary = option Empty (+          OptionalSequence <$> brackets definitionsList+      <|> RepeatedSequence <$> braces definitionsList+      <|> GroupedSequence <$> parens definitionsList+      <|> PrimaryMetaIdentifier <$> metaIdentifier+      <|> TerminalString <$> stringLiteral+          ) -- end of option+  <?> "primary"++-- |MetaIdentifier parser+metaIdentifier :: Parser MetaIdentifier+metaIdentifier = trimMetaIdentifier <$> (angles identifier <|> identifier)+  <?> "meta identifier"+  where+    trimMetaIdentifier = MetaIdentifier . unpack . strip . pack++-- |Lexify an EBNF syntax tree+lexifySyntax :: Syntax -> Syntax+lexifySyntax s = replaceTerm tok $ addLexicalInner tok s+  where+    tok = generateTokens $ findTerm s+    findTerm (Syntax srs) = L.concatMap findTerm' srs+    findTerm' (SyntaxRule _ dl) = findTerm'' dl+    findTerm' (LexicalInner _)  = []+    findTerm'' (DefinitionsList sds) = L.concatMap findTerm''' sds+    findTerm''' (SingleDefinition ts) = L.concatMap findTerm'''' ts+    findTerm'''' (Term f _) = findTerm''''' f+    findTerm''''' (Factor _ p) = findTerm'''''' p+    findTerm'''''' (OptionalSequence dl)      = findTerm'' dl+    findTerm'''''' (RepeatedSequence dl)      = findTerm'' dl+    findTerm'''''' (GroupedSequence dl)       = findTerm'' dl+    findTerm'''''' (PrimaryMetaIdentifier mi) = []+    findTerm'''''' (TerminalString term)      = [term]+    findTerm'''''' Empty                      = []+    generateTokens = map (\t -> (t, "__token_" ++ t)) . L.nub+    addLexicalInner [] s = s+    addLexicalInner ((n, t):ts) (Syntax srs) =+      addLexicalInner ts $ Syntax $ LexicalInner (lexicalString t n) : srs+    replaceTerm [] s                = s+    replaceTerm (t:ts) (Syntax srs) =+      replaceTerm ts $ Syntax $ L.map (replaceTerm' t) srs+    replaceTerm' t (SyntaxRule r dl)   = SyntaxRule r $ replaceTerm'' t dl+    replaceTerm' _ li@(LexicalInner _) = li+    replaceTerm'' t (DefinitionsList sds) =+      DefinitionsList $ L.map (replaceTerm''' t) sds+    replaceTerm''' t (SingleDefinition ts) =+      SingleDefinition $ L.map (replaceTerm'''' t) ts+    replaceTerm'''' t (Term f e) = Term (replaceTerm''''' t f) e+    replaceTerm''''' t (Factor f p) = Factor f $ replaceTerm'''''' t p+    replaceTerm'''''' t (OptionalSequence dl)         =+      OptionalSequence $ replaceTerm'' t dl+    replaceTerm'''''' t (RepeatedSequence dl)         =+      RepeatedSequence $ replaceTerm'' t dl+    replaceTerm'''''' t (GroupedSequence dl)          =+      GroupedSequence $ replaceTerm'' t dl+    replaceTerm'''''' (n, t) ts@(TerminalString s)         =+      if n == s then PrimaryMetaIdentifier (MetaIdentifier t) else ts+    replaceTerm'''''' _ p                         = p++-- * InputGrammar instances for EBNF AST+instance InputGrammar Syntax where+  parser = syntax+  stringify (Syntax [])     = ""+  stringify (Syntax [sr])   = stringify sr+  stringify (Syntax (sr:r)) = stringify sr ++ "\n" ++ stringify (Syntax r)+  rules (Syntax srs) = R.uniformize $ L.concatMap rules srs+  lexify = lexifySyntax++instance InputGrammar SyntaxRule where+  parser = syntaxRule+  stringify (SyntaxRule mi dl) = stringify mi ++ "=" ++ stringify dl ++ ";"+  stringify (LexicalInner lr)  = stringify lr+  rules (SyntaxRule (MetaIdentifier mi) dl) =+    [R.Rule mi [r, R.Empty] | r <- rules dl]+  rules (LexicalInner lr) = rules lr++instance InputGrammar DefinitionsList where+  parser = definitionsList+  stringify (DefinitionsList []) = ""+  stringify (DefinitionsList [sd]) = stringify sd+  stringify (DefinitionsList (sd:r)) =+    stringify sd ++ "|" ++ stringify (DefinitionsList r)+  rules (DefinitionsList sds) = L.concatMap rules sds++instance InputGrammar SingleDefinition where+  parser = singleDefinition+  stringify (SingleDefinition []) = ""+  stringify (SingleDefinition [t]) = stringify t+  stringify (SingleDefinition (t:r)) =+    stringify t ++ "," ++ stringify (SingleDefinition r)+  rules (SingleDefinition [t]) = rules t+  rules (SingleDefinition (t:ts)) =+    [R.Concat [r,n] | r <- rules t, n <- rules (SingleDefinition ts)]++instance InputGrammar Term where+  parser = term+  stringify (Term f Nothing)  = stringify f+  stringify (Term f (Just e)) = stringify f ++ "-" ++ stringify e+  rules (Term f Nothing) = rules f+  rules _                = error "no translation for exception" -- ... yet++instance InputGrammar Exception where+  parser = exception+  stringify (Exception f) = stringify f+  rules _ = undefined -- should not be called, look at the Term instance++instance InputGrammar Factor where+  parser = factor+  stringify (Factor Nothing p)  = stringify p+  stringify (Factor (Just i) p) = show i ++ "*" ++ stringify p+  rules (Factor Nothing p)  = rules p+  rules (Factor (Just i) p) =+    [R.Concat . concat $ replicate (fromIntegral i) (rules p)]++instance InputGrammar Primary where+  parser = primary+  stringify (OptionalSequence dl)      = "[" ++ stringify dl ++ "]"+  stringify (RepeatedSequence dl)      = "{" ++ stringify dl ++ "}"+  stringify (GroupedSequence dl)       = "(" ++ stringify dl ++ ")"+  stringify (PrimaryMetaIdentifier mi) = stringify mi+  stringify (TerminalString s)         = show s+  stringify Empty                      = ""+  rules a@(OptionalSequence dl)    = let x = stringify a in+    R.NonTerm x : R.Rule x [R.Empty] : [R.Rule x [r, R.Empty] | r <- rules dl]+  rules a@(RepeatedSequence dl)    = let x = stringify a in+    R.NonTerm x : R.Rule x [R.Empty] :+      [R.Rule x [r, R.NonTerm x, R.Empty] | r <- rules dl]+  rules a@(GroupedSequence dl)     = let x = stringify a in+    R.NonTerm x : [R.Rule x [r, R.Empty] | r <- rules dl]+  rules (PrimaryMetaIdentifier mi) = rules mi+  rules (TerminalString s)         = [R.Concat $ L.map R.Term s]+  rules Empty                      = [R.Empty]++instance InputGrammar MetaIdentifier where+  parser = metaIdentifier+  stringify (MetaIdentifier s) = "<" ++ s ++ ">"+  rules (MetaIdentifier s) = [R.NonTerm s]
+ src/PP/Grammars/Lexical.hs view
@@ -0,0 +1,82 @@+{-|+Module      : PP.Grammars.Lexical+Description : Defines an AST and parser for a lexical grammar+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Grammars.Lexical+    ( -- *AST+      RegExpr(..)+    ) where++import           Control.Applicative                    ((<$>), (<*>))+import           Data.Text                              (pack, strip, unpack)+import           PP.Grammar+import qualified PP.Rule                                as R+import           Text.ParserCombinators.Parsec+import           Text.ParserCombinators.Parsec.Language (emptyDef)+import qualified Text.ParserCombinators.Parsec.Token    as Token++-- |Lexical rule AST+data RegExpr+  = RegExpr [RegExpr]       -- ^Composed of many choices+  | Choice [RegExpr]        -- ^Composed of many expressions+  | Many0 RegExpr           -- ^`a` many times+  | Many1 RegExpr           -- ^`a` many times, without 0+  | Option RegExpr          -- ^`a` 0 or 1 time+  | Group RegExpr           -- ^`a` grouped (parenthesis)+  | Class [RegExpr]         -- ^One character in the sub-classes+  | Interval Char Char      -- ^One character in the interval+  | Value Char              -- ^One specific character+  | Any                     -- ^One character+    deriving (Show, Eq)++-- |Lexical expression parser (input is reversed)+regExprP :: Parser RegExpr+regExprP = RegExpr . reverse <$> sepBy1 choiceP (char '|')+  where+    choiceP = Choice . reverse <$> many exprP+    exprP = try groupP+        <|> try classP+        <|> try classSpecialP+        <|> try many0P+        <|> try many1P+        <|> try optionP+        <|> try anyP+        <|>     valueP+    many0P = Many0 <$> (char '*' *> exprP)+    many1P = Many1 <$> (char '+' *> exprP)+    optionP = Option <$> (char '?' *> exprP)+    groupP = Group <$> between (char ')') (char '(') regExprP+    classP = Class . reverse <$> between (char ']') (char '[')+                                         (many1 (try intervalP+                                             <|> classValueP))+    classSpecialP =+      Class . (Value '[' :) . reverse <$> between (char ']') (string "[[")+                                                  (many (try intervalP+                                                     <|> classValueP))+    intervalP = flip Interval <$> (anyChar <* char '-') <*> anyChar+    valueP = Value <$> noneOf "|*+?()[]"+    classValueP = Value <$> noneOf "["+    anyP = Any <$ char '.'++-- |RegExpr InputGrammar instance+instance InputGrammar RegExpr where+  parser = regExprP+  parseAst = parse regExprP "" . reverse+  stringify (RegExpr [])     = ""+  stringify (RegExpr [x])    = stringify x+  stringify (RegExpr (x:xs)) = stringify x ++ "|" ++ stringify (RegExpr xs)+  stringify (Choice xs)      = concatMap stringify xs+  stringify (Many0 a)        = stringify a ++ "*"+  stringify (Many1 a)        = stringify a ++ "+"+  stringify (Option a)       = stringify a ++ "?"+  stringify (Group a)        = "(" ++ stringify a ++ ")"+  stringify (Class xs)       = "[" ++ concatMap stringify xs ++ "]"+  stringify (Interval i j)   = [i,'-',j]+  stringify (Value i)        = [i]+  stringify Any              = "."+  rules r = [R.RegEx $ stringify r]
+ src/PP/Grammars/LexicalHelper.hs view
@@ -0,0 +1,112 @@+{-|+Module      : PP.Grammars.LexicalHelper+Description : Add lexical support to other grammars+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Grammars.LexicalHelper+    ( -- *AST helper for other grammars+      LexicalRule(..)+    , LexicalDefinitionList(..)+    , LexicalDefinition(..)+      -- *Helpers+    , lexicalString+    ) where++import           Control.Applicative                    ((<$>), (<*>))+import           Data.Text                              (pack, strip, unpack)+import           PP.Grammar+import qualified PP.Rule                                as R+import           Text.ParserCombinators.Parsec+import           Text.ParserCombinators.Parsec.Language (emptyDef)+import qualified Text.ParserCombinators.Parsec.Token    as Token++-- |Defines a lexical rule represented by a identifier+data LexicalRule = LexicalRule String LexicalDefinitionList+  deriving (Show, Eq)++-- |Defines the definition list for a lexical rule+newtype LexicalDefinitionList = LexicalDefinitionList [LexicalDefinition]+  deriving (Show, Eq)++-- |Lexical rule definition component+data LexicalDefinition+  -- |Regular expression as a terminal string+  = LexicalRegEx String+  | LexicalString String+  -- |Other lexical rule identifier+  | LexicalIdentifier String+    deriving (Show, Eq)++-- |Construct a simple lexical rule+lexicalString :: String -> String -> LexicalRule+lexicalString n s = LexicalRule n $ LexicalDefinitionList [LexicalString s]++-- |Parsing helpers+lexer = Token.makeTokenParser def+  where+    def = emptyDef {+        Token.commentStart = "(*"+      , Token.commentEnd = "*)"+      , Token.commentLine = ""+      , Token.nestedComments = False+      , Token.identStart = letter+      , Token.identLetter = alphaNum <|> oneOf "_- "+      , Token.reservedNames = []+      , Token.reservedOpNames = ["%=", ";", ","]+      , Token.caseSensitive = True+    }++identifier = Token.identifier lexer+reservedOp = Token.reservedOp lexer+stringLiteral = Token.stringLiteral lexer+whiteSpace = Token.whiteSpace lexer++-- |Parser for LexicalRule+lexicalRule :: Parser LexicalRule+lexicalRule = whiteSpace *>+              (LexicalRule <$> (lexicalIdentifier <* reservedOp "%=")+                           <*> (lexicalDefinitionList <* reservedOp ";"))+  <?> "lexical rule"++-- |Parser for LexicalDefinitionList$+lexicalDefinitionList :: Parser LexicalDefinitionList+lexicalDefinitionList = LexicalDefinitionList <$> sepBy1 lexicalDefinition (reservedOp ",")+  <?> "lexical definition list"++-- |Parser for LexicalDefinition+lexicalDefinition :: Parser LexicalDefinition+lexicalDefinition = LexicalRegEx <$> stringLiteral+                <|> LexicalIdentifier <$> lexicalIdentifier+  <?> "lexical definition"++-- |Parser for LexicalIdentifier, helper+lexicalIdentifier :: Parser String+lexicalIdentifier = (unpack . strip . pack) <$> identifier+  <?> "lexical identifier"++-- *Associated InputGrammar instances+instance InputGrammar LexicalRule where+  parser = lexicalRule+  stringify (LexicalRule li xs) = li ++ "%=" ++ stringify xs ++ ";"+  rules (LexicalRule li xs) = R.uniformize [R.Rule li (rules xs ++ [R.Empty])]++instance InputGrammar LexicalDefinitionList where+  parser = lexicalDefinitionList+  stringify (LexicalDefinitionList []) = ""+  stringify (LexicalDefinitionList [x]) = stringify x+  stringify (LexicalDefinitionList (x:xs)) =+    stringify x ++ "," ++ stringify (LexicalDefinitionList xs)+  rules (LexicalDefinitionList xs) = [head (rules x) | x <- xs]++instance InputGrammar LexicalDefinition where+  parser = lexicalDefinition+  stringify (LexicalString x)     = show x+  stringify (LexicalRegEx x)      = show x+  stringify (LexicalIdentifier x) = x+  rules (LexicalRegEx x)      = [R.RegEx x]+  rules (LexicalString x)     = [R.RegExString x]+  rules (LexicalIdentifier x) = [R.NonTerm x]
+ src/PP/Lexer.hs view
@@ -0,0 +1,40 @@+{-|+Module      : PP.Lexer+Description : Common behavior for defined lexers+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Lexer+    ( IToken+    , OToken(..)+    , charLexer+    , Lexer(..)+    ) where++-- |Input token+type IToken = Char++-- |Output token+data OToken+  = OToken1 String           -- ^Token value+  | OToken2 [IToken] String  -- ^Token value and name+    deriving (Show, Eq, Ord)++-- |String to OToken (char by char lexer)+charLexer :: String -> [OToken]+charLexer = map (\c -> OToken1 [c])++-- |Lexer class+class Lexer config where+  -- |Simulate the automaton on the input, for one iteration+  simulate :: config -> config+  -- |Check if the input is consumed+  consumed :: config -> Bool+  -- |Get the output tokens+  output :: config -> [OToken]+  -- |Consume the complete input+  consume :: config -> config+  consume c = if consumed c then c else consume $ simulate c
+ src/PP/Lexers/Dfa.hs view
@@ -0,0 +1,104 @@+{-|+Module      : PP.Lexers.Dfa+Description : Lexer simulation with DFA+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Lexers.Dfa+    ( DfaConfig+    , dfaConfig+    , createDfa+    , createDfa'+    ) where++import           Control.Exception+import           Data.Either+import qualified Data.Graph.Inductive.Graph as Gr+import           Data.Maybe+import           PP.Builder+import           PP.Builders.Dfa+import           PP.Builders.Nfa+import           PP.Grammar+import           PP.Grammars.Lexical+import           PP.Lexer+import           PP.Rule++-- |DFA configuration+data DfaConfig = DfaConfig+  { dfaInput  :: [IToken]             -- ^Input tokens+  , dfaBuffer :: [IToken]             -- ^Buffer+  , dfaOutput :: [OToken]             -- ^Output tokens+  , dfaGraph  :: DfaGraph             -- ^Automaton+  , dfaPath   :: [Gr.LNode DfaNode]   -- ^Path for the current buffer+  }++instance Show DfaConfig where+  show (DfaConfig is bs os _ ps) =+    "DfaConfig {dfaInput = " ++ show is +++    ", dfaBuffer = " ++ show bs +++    ", dfaOutput = " ++ show os +++    ", dfaGraph = ..., dfaPath = " ++ show ps ++ "}"++-- |Lexer instance for DFA configuration+-- Dragon Book (2nd edition, fr), page 156, example 3.28+instance Lexer DfaConfig where+  simulate = simulateDfa+  consumed c = null $ dfaInput c+  output = reverse . dfaOutput+  consume c = if consumed c then simulate c else consume $ simulate c++-- |Create DFA configuration+dfaConfig :: String -> DfaGraph -> DfaConfig+dfaConfig s g = DfaConfig s [] [] g [findInitial g]++-- |Create a complete DFA from a list of lexical rules+createDfa :: [Rule] -> DfaGraph+createDfa = buildDfa . combineNfa . map createNfa . regexfy+  where+    createNfa (Rule n (RegEx re:_)) =+      case parseAst re :: To RegExpr of+        Left e    -> error $ show e+        Right ast -> buildNfa' n ast++-- |Exception-safe version of `createDfa`+createDfa' :: [Rule] -> IO (Either String DfaGraph)+createDfa' rs = do+    a <- try (evaluate $ createDfa rs) :: IO (Either SomeException DfaGraph)+    case a of+        Left e  -> return $ Left $ head $ lines $ displayException e+        Right r -> return $ Right r++-- |Simulate one iteration+simulateDfa :: DfaConfig -> DfaConfig+simulateDfa c@(DfaConfig [] _ _ _ _) = reducePath c+simulateDfa c@(DfaConfig (i:is) bs os g ps@(p:_)) =+  case findNext g i p of+    Nothing -> reducePath c+    Just q  -> DfaConfig is (i:bs) os g (q:ps)++-- |Find next node+findNext :: DfaGraph -> IToken -> Gr.LNode DfaNode -> Maybe (Gr.LNode DfaNode)+findNext g i (n, _) =+  case map fst $ filter (\(_, DfaValue v) -> i == v) $ Gr.lsuc g n of+    []  -> Nothing+    [m] -> Just (m, fromMaybe DfaNode $ Gr.lab g m)++-- |Reduce path to initial node and construct an output token, if any+reducePath :: DfaConfig -> DfaConfig+reducePath c@(DfaConfig [] _ _ _ ((_, DfaInitial):_)) = c+reducePath (DfaConfig (_:is) bs os g ps@((_, DfaInitial):_)) =+  DfaConfig is bs os g ps+reducePath (DfaConfig is (b:bs) os g ((_, DfaNode):ps)) =+  reducePath $ DfaConfig (b:is) bs os g ps+reducePath (DfaConfig is bs os g ((_, DfaFinal n):_)) =+  DfaConfig is [] (OToken2 (reverse bs) n:os) g [findInitial g]++-- |Find initial node+findInitial :: DfaGraph -> Gr.LNode DfaNode+findInitial g = let [n] = filter isInitial (Gr.labNodes g) in n+  where+    isInitial (_, DfaInitial) = True+    isInitial _               = False
+ src/PP/Parser.hs view
@@ -0,0 +1,34 @@+{-|+Module      : PP.Parser+Description : Common behavior for defined parsers+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Parser+    ( LrParser(..)+    ) where++import           PP.Builder (LrTable)+import           PP.Lexer   (OToken (..))++-- |Type class for LR parser+class LrParser config where+  -- |Put the input into the configuration+  config :: LrTable -> [OToken] -> config+  -- |Parse one iteration only+  next :: LrTable -> config -> config+  -- |Check if there is still an iteration+  hasNext :: LrTable -> config -> Bool+  -- |Parse all iterations+  parse :: LrTable -> config -> config+  parse t c | hasNext t c = parse t $ next t c+            | otherwise = c+  -- |Parse all iterations and keep all configurations (in reverse order)+  parse' :: LrTable -> config -> [config]+  parse' t c = parse'' t [c]+    where+      parse'' t acc@(c:_) | hasNext t c = parse'' t $ next t c : acc+                          | otherwise = acc
+ src/PP/Parsers/Lr.hs view
@@ -0,0 +1,71 @@+{-|+Module      : PP.Parsers.Lr+Description : LR parser+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Parsers.Lr+    ( LrConfig(..)+    , LrAst(..)+    , prettyAst+    ) where++import           PP.Builder (LrAction (..), LrTable (..), action, action')+import           PP.Lexer   (OToken (..))+import           PP.Parser  (LrParser (..))+import           PP.Rule    (Rule (..))++-- |Dynamic AST generated by the parser+data LrAst+  = LrAstRoot [LrAst]+  | LrAstTerm [OToken]+  | LrAstNonTerm String [LrAst]+    deriving (Eq, Show)++-- |Configuration for LR parser+data LrConfig = LrConfig+  { lrCount  :: Int        -- ^Counter+  , lrStack  :: [Int]      -- ^State stack+  , lrAction :: LrAction   -- ^Action to do+  , lrInput  :: [OToken]   -- ^Input+  , lrAst    :: LrAst      -- ^Parsed AST+  } deriving (Eq, Show)++-- Dragon Book (2nd edition, fr), page 230, algorithm 4.44+instance LrParser LrConfig where+  config t i = LrConfig 0 [0] (action' t 0 i) i (LrAstRoot [])+  next t (LrConfig c ss (LrShift s) (i:is) a) =+    LrConfig (c + 1) (s : ss) (action' t s is) is (shift a i)+  next t (LrConfig c ss (LrReduce (Rule r xs)) i a) =+    LrConfig (c + 1) sr (action t m $ NonTerm r) i (reduce a r $ length xs - 1)+    where+      sr@(m:_) = drop (length xs - 1) ss+  next t (LrConfig c ss (LrGoto s) i a) =+    LrConfig (c + 1) (s : ss) (action' t s i) i a+  next _ c = c+  hasNext _ (LrConfig _ _ LrError _ _)  = False+  hasNext _ (LrConfig _ _ LrAccept _ _) = False+  hasNext _ _                           = True++-- |Modify the AST by a Shift action+shift :: LrAst -> OToken -> LrAst+shift (LrAstRoot xs) i = LrAstRoot $ xs ++ [LrAstTerm [i]]++-- |Modify the AST by a Reduce action+reduce :: LrAst -> String -> Int -> LrAst+reduce (LrAstRoot xs) r l = LrAstRoot $ a ++ [LrAstNonTerm r b]+  where+    (a, b) = splitAt pos xs+    pos = length xs - l++-- |Pretty print the LrAst+prettyAst :: LrAst -> String+prettyAst (LrAstRoot a) = concatMap (prettyAst' 0) a+  where+    prettyAst' d (LrAstTerm t) = tab d ++ show t ++ "\n"+    prettyAst' d (LrAstNonTerm r xs) =+      tab d ++ r ++ "\n" ++ concatMap (prettyAst' $ d + 2) xs+    tab d = replicate d ' ' ++ "|"
+ src/PP/Rule.hs view
@@ -0,0 +1,244 @@+{-|+Module      : PP.Rule+Description : Canonical rule representation+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Rule+    ( -- * Canonical low-level rule+      Rule(..)+    , uniformize+    , extend+    , separate+    , regexfy+      -- * Canonical rules as Map+    , RuleSet+    , ruleSet+    , rule+    , check+      -- * Rules first set (Map)+    , FirstSet+    , firstSet+    , first+    ) where++import           Control.Monad+import           Data.Binary+import           Data.Either+import           Data.List+import qualified Data.Map.Strict as Map+import           Data.Maybe+import           PP.Lexer        (IToken)++-- |Canonical rule type+data Rule+  -- |A rule is defined by a non terminal and a list of Term and NonTerm+  -- The list should end with Empty+  = Rule String [Rule]+  -- |Non terminal string+  | NonTerm String+  -- |Terminal character+  | Term IToken+  -- |Terminal token+  | TermToken String+  -- |Empty+  | Empty+  -- |Concatenated rules, useful for PP.InputGrammar.rules+  | Concat [Rule]+  -- |Regular expression, useful for lexical rules+  | RegEx String+  | RegExString String -- ^No parse-string+    deriving (Eq, Ord)++instance Show Rule where+  show (Rule a xs) = a ++ " -> " ++ right xs+    where+      right []     = ""+      right [x]    = show x+      right (x:xs) = show x ++ "," ++ right xs+  show (NonTerm a) = a+  show (Term c) = show c+  show (TermToken t) = '%' : t+  show Empty = "$"+  show (Concat xs) = "Concat " ++ show xs+  show (RegEx re) = '%' : show re+  show (RegExString s) = show s++instance Binary Rule where+  put (Rule a xs)     = putWord8 0 >> put a >> put xs+  put (NonTerm a)     = putWord8 1 >> put a+  put (Term c)        = putWord8 2 >> put c+  put (TermToken t)   = putWord8 3 >> put t+  put Empty           = putWord8 4+  put (Concat xs)     = putWord8 5 >> put xs+  put (RegEx re)      = putWord8 6 >> put re+  put (RegExString s) = putWord8 7 >> put s+  get = do+    tag <- getWord8+    case tag of+      0 -> liftM2 Rule get get+      1 -> fmap NonTerm get+      2 -> fmap Term get+      3 -> fmap TermToken get+      4 -> return Empty+      5 -> fmap Concat get+      6 -> fmap RegEx get+      7 -> fmap RegExString get++-- |Uniformize a list of rules+-- `uniformize = sort . nub . concatMap (flatten . clean)`+uniformize :: [Rule] -> [Rule]+uniformize = sort . nub . concatMap (flatten . clean)++-- |Clean a rule (remove Concat and useless Empty)+clean :: Rule -> Rule+clean (Rule s xs) = Rule s (cleaning xs)+  where+    cleaning []               = []+    cleaning a@[Empty]        = a+    cleaning (Empty : xs)     = cleaning xs -- useless Empty+    cleaning (Concat [] : xs) = cleaning xs+    cleaning (Concat xs : ys) = cleaning (xs ++ ys) -- remove Concat+    cleaning (Rule s xs : ys) = Rule s (cleaning xs) : cleaning ys -- inner Rule+    cleaning (x : xs)         = x : cleaning xs++-- |Replace and extract inner rules+flatten :: Rule -> [Rule]+flatten (Rule s xs) = Rule s (replace xs) : extract xs+  where+    replace []              = []+    replace (Rule s _ : xs) = NonTerm s : replace xs -- replacement+    replace (x : xs)        = x : replace xs+    extract []                  = []+    extract (r@(Rule _ _) : xs) = flatten r ++ extract xs -- extract inner Rule+    extract (x : xs)            = extract xs++-- |Generate an augmented grammar+extend :: [Rule] -> Either String [Rule]+extend xs = case start xs of+  Left s  -> Left $ "cannot extend, " ++ s+  Right s -> Right $ Rule "__start" [NonTerm s, Empty] : xs++-- |Find start rule+start :: [Rule] -> Either String String+start xs = let c = candidates xs in+  case length c of+    1 -> Right $ head c+    _ -> Left $ "no start rule found (candidates: " ++ show c ++ ")"++-- |Find start rule candidates+candidates :: [Rule] -> [String]+candidates = map (fst . head) . filter (all snd) . grp . sortOn fst . evaluate+  where+    grp = groupBy (\(a, _) (b, _) -> a == b)+    evaluate []               = []+    evaluate (Rule s xs : ys) = (s, True) : evaluate xs ++ evaluate ys+    evaluate (NonTerm s : xs) = (s, False) : evaluate xs+    evaluate (_ : xs)         = evaluate xs++-- |Rules as a map+type RuleSet = Map.Map String [[Rule]]++-- |Compute the rule set+ruleSet :: [Rule] -> RuleSet+ruleSet xs = Map.fromList [(n, collect n xs) | n <- names xs]+  where+    names = nub . map (\(Rule s _) -> s)+    collect n = map (\(Rule _ r) -> r) . filter (\(Rule s _) -> s == n)++-- |Get rule from a RuleSet+rule :: String -> RuleSet -> [Rule]+rule name rs = case Map.lookup name rs of+  Nothing -> []+  Just xs -> map (Rule name) xs++-- |Check a rule set, return: (errors, warnings)+check :: RuleSet -> ([String], [String])+check rs = (missing ++ leftRec, unused)+  where+    missing = ["missing non-terminal: " ++ n | n <- right, n `notElem` left]+    leftRec = ["direct left-recusion: " ++ n | n <- left, hasLeftRec n]+    unused = ["unused non-terminal: " ++ n+              | n <- left+              , n /= "__start"+              , n `notElem` right]+    hasLeftRec n = hasLeftRec' n /= []+    hasLeftRec' n = [0 | (Rule _ (x:_)) <- rule n rs, hasLeftRec'' n x]+    hasLeftRec'' n (NonTerm s) = n == s+    hasLeftRec'' _ _           = False+    left = Map.keys rs+    right = nub $ concat [nonTerm xs | n <- left, (Rule _ xs) <- rule n rs]+    nonTerm []               = []+    nonTerm (NonTerm s : xs) = s : nonTerm xs+    nonTerm (_:xs)           = nonTerm xs++-- |First set type+type FirstSet = Map.Map String [Rule]++-- |Compute the complete first set+firstSet :: RuleSet -> FirstSet+firstSet rs = Map.mapWithKey (\k _ -> find k rs) rs+  where+    find name rs = nub . sort $ concatMap compute $ noLeftRec $ rule name rs+    noLeftRec = filter (\(Rule a (x:_)) -> case x of+      NonTerm b -> a /= b+      _         -> True)+    compute (Rule _ [Empty]) = [Empty]+    compute (Rule name (x:xs)) = case compute x of+      [Empty] -> compute $ Rule name xs+      a       -> a+    compute a@(Term _) = [a]+    compute a@(TermToken _) = [a]+    compute (NonTerm s) = find s rs+    compute Empty = [Empty]++-- |Compute first set of a given rule+first :: Rule -> FirstSet -> [Rule]+first Empty _           = [Empty]+first a@(Term _) _      = [a]+first a@(TermToken _) _ = [a]+first (NonTerm s) fs    = fromMaybe [Empty] (Map.lookup s fs)+first (Rule _ (x:_)) fs = first x fs++-- |Separate rules into (parsing rules, lexing rules)+separate :: [Rule] -> ([Rule], [Rule])+separate rs = nonTermToToken (filter (not . hasRegex) rs, filter hasRegex rs)+  where+    hasRegex (Rule _ [])     = False+    hasRegex (Rule r (x:xs)) = hasRegex x || hasRegex (Rule r xs)+    hasRegex (NonTerm _)     = False+    hasRegex (Term _)        = False+    hasRegex (TermToken _)   = False+    hasRegex Empty           = False+    hasRegex (Concat [])     = False+    hasRegex (Concat (x:xs)) = hasRegex x || hasRegex (Concat xs)+    hasRegex (RegEx _)       = True+    hasRegex (RegExString _) = True++-- |Transform NonTerm into TermToken, when needed+nonTermToToken :: ([Rule], [Rule]) -> ([Rule], [Rule])+nonTermToToken (rs, lrs) = (mappers rs, mappers lrs)+    where+      mappers = map (\(Rule r xs) -> Rule r $ map (replaceNonTerm tok) xs)+      tok = map (\(Rule r _) -> r) lrs+      replaceNonTerm [] r = r+      replaceNonTerm (t:ts) r@(NonTerm nt) =+        if nt == t then TermToken t else replaceNonTerm ts r+      replaceNonTerm (_:ts) r = replaceNonTerm ts r++-- |Transform lexing rules to have only one RegEx on right+regexfy :: [Rule] -> [Rule]+regexfy lrs = concatMap replace lrs+  where+    replace (Rule r xs)    = [Rule r $ bind [RegEx ""] $ concatMap replace xs]+    replace (TermToken nt) = concatMap replace $ find nt+    replace x              = [x]+    bind acc [Empty]                      = acc ++ [Empty]+    bind (RegEx a:acc) (RegEx b:xs)       = bind [RegEx $ a ++ b] xs+    bind (RegEx a:acc) (RegExString b:xs) = bind [RegEx $ a ++ toRegex b] xs+    find r = let (Rule _ xs:_) = rule r rs in init xs+    toRegex s = '(' : concat [['[',c,']'] | c <- s] ++ ")"+    rs = ruleSet lrs
+ src/PP/Template.hs view
@@ -0,0 +1,34 @@+{-|+Module      : PP.Template+Description : Common behavior for defined templates+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+{-# LANGUAGE FlexibleInstances #-}+module PP.Template+    ( Template(..)+    , mergeContext+    ) where++import           Text.StringTemplate++-- |Type class for Templatable structure+class Template context where+  -- |Put the context into StringTemplate attributes+  attributes :: context -> StringTemplate String -> StringTemplate String+  -- |Compile a template with a given context+  compile :: context -> String -> String+  compile c t = render $ attributes c $ newSTMP t++-- |Merge two contexts together+mergeContext :: (Template c1, Template c2) => c1 -> c2+                -> (StringTemplate String -> StringTemplate String)+mergeContext a b = attributes a . attributes b++-- |Allow to use `compile` with `mergeContext`+-- For example: `compile (mergeContext c1 c2) t`+instance Template ((->) (StringTemplate String) (StringTemplate String)) where+  attributes = id
+ src/PP/Templates/Dfa.hs view
@@ -0,0 +1,55 @@+{-|+Module      : PP.Templates.Dfa+Description : DFA template+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+{-# LANGUAGE DeriveDataTypeable #-}+module PP.Templates.Dfa+    ( DfaContext+    , context+    ) where++import           Data.Data+import qualified Data.Graph.Inductive.Graph          as Gr+import           Data.Typeable+import           PP.Builder+import           PP.Template+import           Text.StringTemplate+import           Text.StringTemplate.GenericStandard++-- |DFA context+data DfaContext = DfaContext+  { states      :: [DfaContextState]      -- ^DFA states (nodes)+  , transitions :: [DfaContextTransition] -- ^DFA transitions (links)+  } deriving (Data, Typeable, Eq)+data DfaContextState = DfaContextState+  { id        :: Int                      -- ^State ID+  , isInitial :: Bool                     -- ^Is it initial node ?+  , isNode    :: Bool                     -- ^Is it middle node ?+  , isFinal   :: Bool                     -- ^Is it final node ?+  , final     :: String                   -- ^Final node value+  } deriving (Data, Typeable, Eq)+data DfaContextTransition = DfaContextTransition+  { from   :: Int                         -- ^State from+  , to     :: Int                         -- ^State to+  , symbol :: Char                        -- ^Transition symbol+  } deriving (Data, Typeable, Eq)++-- |Construct DFA context+context :: DfaGraph -> DfaContext+context dfa = DfaContext states' transitions'+  where+    states' = map fromNode $ Gr.labNodes dfa+    transitions' = map fromEdge $ Gr.labEdges dfa+    fromNode (i, DfaInitial) = DfaContextState i True False False ""+    fromNode (i, DfaNode)    = DfaContextState i False True False ""+    fromNode (i, DfaFinal f) = DfaContextState i False False True f+    fromEdge (i, j, DfaValue s) = DfaContextTransition i j s++-- |Template instance for DfaContext+instance Template DfaContext where+  attributes = setAttribute "dfa"
+ src/PP/Templates/Lr.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-|+Module      : PP.Templates.Lr+Description : LR template+Copyright   : (c) 2017 Patrick Champion+License     : see LICENSE file+Maintainer  : chlablak@gmail.com+Stability   : provisional+Portability : portable+-}+module PP.Templates.Lr+    ( LrContext+    , context+    ) where++import           Data.Char+import           Data.Data+import qualified Data.List                           as L+import qualified Data.Map.Strict                     as Map+import           Data.Maybe+import           Data.Typeable+import           PP.Builder+import           PP.Rule+import           PP.Template+import           Text.StringTemplate+import           Text.StringTemplate.GenericStandard++-- |LR table context+data LrContext = LrContext+  { states   :: [LrContextState]    -- ^States informations+  , terms    :: [LrContextTerm]     -- ^Terminals informations+  , nonTerms :: [LrContextNonTerm]  -- ^Non-terminals informations (without length)+  , table    :: LrContextTable      -- ^LR table informations+  } deriving (Data, Typeable, Eq)+data LrContextState = LrContextState+  { id  :: Int                      -- ^State ID+  , alt :: LrContextNonTerm         -- ^Associated non-terminal (not impl. yet)+  } deriving (Data, Typeable, Eq)+data LrContextTerm = LrContextTerm+  { symbol  :: Char                 -- ^Terminal symbol+  , isEmpty :: Bool                 -- ^It's the EMPTY symbol?+  } deriving (Data, Typeable, Eq)+data LrContextNonTerm = LrContextNonTerm+  { name   :: String                -- ^Non-terminal name+  , length :: Int                   -- ^Rule length (right side)+  } deriving (Data, Typeable, Eq)+data LrContextTable = LrContextTable+  { rows  :: [LrContextTableRow]    -- ^Table flatten in rows only+  , total :: Int                    -- ^Total rows (with errors)+  } deriving (Data, Typeable, Eq)+data LrContextTableRow = LrContextTableRow+  { state   :: LrContextState       -- ^Row state+  , isTerm  :: Bool                 -- ^Row state is associated with ?+  , term    :: LrContextTerm        -- ^Row is associated with terminal+  , nonTerm :: LrContextNonTerm     -- ^Row is associated with non-terminal+  , action  :: LrContextAction      -- ^Associated action+  } deriving (Data, Typeable, Eq)+data LrContextAction = LrContextAction+  { isReduce :: Bool                -- ^Is action reduce?+  , isShift  :: Bool                -- ^Is action shift?+  , isGoto   :: Bool                -- ^Is action goto?+  , isError  :: Bool                -- ^Is action error?+  , isAccept :: Bool                -- ^Is action accept?+  , shift    :: Int                 -- ^Shift value+  , goto     :: Int                 -- ^Goto value+  , reduce   :: LrContextNonTerm    -- ^Reduce associated non-terminal (with length)+  } deriving (Data, Typeable, Eq)++-- |Construct the LR context+context :: LrTable -> LrContext+context t = LrContext states' terms' nonTerms' table'+  where+    states' = L.nub [LrContextState i (nonTerm' Empty) | ((i, _), _) <- list']+    terms' = term' Empty : L.nub [term' r | ((_, r), _) <- list', isTerm' r]+    nonTerms' = L.nub [nonTerm' r | ((_, r), _) <- list', isNonTerm' r]+    table' = LrContextTable rows'+      (L.length states' * (L.length terms' + L.length nonTerms'))+    rows' = [LrContextTableRow (LrContextState i (nonTerm' Empty))+                               (isTermOrEmpty' r)+                               (term' r)+                               (nonTerm' r)+                               (action' a)+           | ((i, r), a) <- list']+    term' (Term x) = LrContextTerm x False+    term' Empty    = LrContextTerm (chr 0) True+    term' _        = LrContextTerm (chr 0) False+    nonTerm' (NonTerm n) = LrContextNonTerm n (-1)+    nonTerm' _           = LrContextNonTerm "" (-1)+    action' (LrReduce (Rule n xs)) =+      LrContextAction True False False False False (-1) (-1)+        (LrContextNonTerm n (L.length xs - 1))+    action' (LrShift s) =+      LrContextAction False True False False False s (-1) (nonTerm' Empty)+    action' (LrGoto s) =+      LrContextAction False False True False False (-1) s (nonTerm' Empty)+    action' LrError =+      LrContextAction False False False True False (-1) (-1) (nonTerm' Empty)+    action' LrAccept =+      LrContextAction False False False False True (-1) (-1) (nonTerm' Empty)+    list' = Map.toList t+    isTerm' (Term _) = True+    isTerm' _        = False+    isTermOrEmpty' (Term _) = True+    isTermOrEmpty' Empty    = True+    isTermOrEmpty' _        = False+    isNonTerm' (NonTerm _) = True+    isNonTerm' _           = False+    isReduce' (LrReduce _) = True+    isReduce' _            = False++-- |Template instance for LrContext+instance Template LrContext where+  attributes = setAttribute "lr"
+ test/PPTest/Builders/Dfa.hs view
@@ -0,0 +1,37 @@+module PPTest.Builders.Dfa (specs) where++import qualified Data.Graph.Inductive.Graph as Gr+import           PP+import           PP.Builders.Dfa+import           PP.Builders.Nfa+import           PP.Grammars.Lexical+import           Test.Hspec++specs = describe "PPTest.Builders.Dfa" $ do++  it "should build the correct automaton (from NFA: (a|b)*abb)" $ do+    -- Dragon Book (2nd edition, fr), page 142, figures 3.34 and 3.36+    let nfa = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaNode),(3,NfaNode),+                          (4,NfaNode),(5,NfaNode),(6,NfaNode),(7,NfaNode),+                          (8,NfaNode),(9,NfaNode),(10,NfaFinal "(a|b)*abb")]+                         [(0,1,NfaEmpty),(0,7,NfaEmpty),(1,2,NfaEmpty),+                          (1,4,NfaEmpty),(2,3,NfaValue 'a'),(3,6,NfaEmpty),+                          (4,5,NfaValue 'b'),(5,6,NfaEmpty),(6,1,NfaEmpty),+                          (6,7,NfaEmpty),(7,8,NfaValue 'a'),(8,9,NfaValue 'b'),+                          (9,10,NfaValue 'b')] :: NfaGraph+    let e = Gr.mkGraph [(0,DfaInitial),(1,DfaNode),(2,DfaNode),(3,DfaNode),+                        (4,DfaFinal "(a|b)*abb")]+                       [(0,1,DfaValue 'a'),(0,2,DfaValue 'b'),(1,1,DfaValue 'a'),+                        (1,3,DfaValue 'b'),(2,1,DfaValue 'a'),(2,2,DfaValue 'b'),+                        (3,1,DfaValue 'a'),(3,4,DfaValue 'b'),(4,1,DfaValue 'a'),+                        (4,2,DfaValue 'b')]+    buildDfa nfa `shouldBe` e++  it "should keep all final nodes from the NFA" $ do+    let nfa = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaFinal "a"),(3,NfaNode),+                          (4,NfaFinal "b")]+                         [(0,1,NfaEmpty),(0,3,NfaEmpty),(1,2,NfaValue 'a'),+                          (3,4,NfaValue 'b')] :: NfaGraph+    let e = Gr.mkGraph [(1,DfaInitial),(2,DfaFinal "a"),(3,DfaFinal "b")]+                       [(1,2,DfaValue 'a'),(1,3,DfaValue 'b')]+    buildDfa nfa `shouldBe` e
+ test/PPTest/Builders/Lalr.hs view
@@ -0,0 +1,101 @@+module PPTest.Builders.Lalr (specs) where++import qualified Data.Map.Strict  as Map+import qualified Data.Set         as Set+import qualified Data.Vector      as Vector+import           PP+import           PP.Builders.Lalr+import           Test.Hspec++specs = describe "PPTest.Builders.Lalr" $ do++  it "should build the LALR items set collection" $ do+    -- Dragon Book (2nd edition, fr), page 240, example 4.54+    let rs = ruleSet [Rule "__start" [NonTerm "S", Empty],+                      Rule "S" [NonTerm "C", NonTerm "C", Empty],+                      Rule "C" [Term 'c', NonTerm "C", Empty],+                      Rule "C" [Term 'd', Empty]]+    let fs = firstSet rs+    let c = collection rs fs :: LrCollection LalrItem+    let e0 = [LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'c'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'd'),+              LalrItem (Rule "C" [Term 'd',Empty]) 0 (Term 'c'),+              LalrItem (Rule "C" [Term 'd',Empty]) 0 (Term 'd'),+              LalrItem (Rule "S" [NonTerm "C",NonTerm "C",Empty]) 0 Empty,+              LalrItem (Rule "__start" [NonTerm "S",Empty]) 0 Empty]+    let e1 = [LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'c'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'd'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 Empty,+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 1 (Term 'c'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 1 (Term 'd'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 1 Empty,+              LalrItem (Rule "C" [Term 'd',Empty]) 0 (Term 'c'),+              LalrItem (Rule "C" [Term 'd',Empty]) 0 (Term 'd'),+              LalrItem (Rule "C" [Term 'd',Empty]) 0 Empty]+    let e2 = [LalrItem (Rule "C" [Term 'd',Empty]) 1 (Term 'c'),+              LalrItem (Rule "C" [Term 'd',Empty]) 1 (Term 'd'),+              LalrItem (Rule "C" [Term 'd',Empty]) 1 Empty]+    let e3 = [LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 Empty,+              LalrItem (Rule "C" [Term 'd',Empty]) 0 Empty,+              LalrItem (Rule "S" [NonTerm "C",NonTerm "C",Empty]) 1 Empty]+    let e4 = [LalrItem (Rule "__start" [NonTerm "S",Empty]) 1 Empty]+    let e5 = [LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 2 (Term 'c'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 2 (Term 'd'),+              LalrItem (Rule "C" [Term 'c',NonTerm "C",Empty]) 2 Empty]+    let e6 = [LalrItem (Rule "S" [NonTerm "C",NonTerm "C",Empty]) 2 Empty]+    Vector.length c `shouldBe` 7+    Set.toList (c Vector.! 0) `shouldBe` e0+    Set.toList (c Vector.! 1) `shouldBe` e1+    Set.toList (c Vector.! 2) `shouldBe` e2+    Set.toList (c Vector.! 3) `shouldBe` e3+    Set.toList (c Vector.! 4) `shouldBe` e4+    Set.toList (c Vector.! 5) `shouldBe` e5+    Set.toList (c Vector.! 6) `shouldBe` e6++  it "should build the LALR parsing table" $ do+    -- Dragon Book (2nd edition, fr), page 247, figure 4.43+    let r0 = Rule "S" [NonTerm "C", NonTerm "C", Empty]+    let r1 = Rule "C" [Term 'c', NonTerm "C", Empty]+    let r2 = Rule "C" [Term 'd', Empty]+    let rs = ruleSet [Rule "__start" [NonTerm "S", Empty], r0, r1, r2]+    let fs = firstSet rs+    let c = collection rs fs :: LrCollection LalrItem+    case table c of+      Left err -> show err `shouldBe` "not an error"+      Right t -> do+        Map.size t `shouldBe` 18+        action t 0 (Term 'c') `shouldBe` LrShift 1+        action t 0 (Term 'd') `shouldBe` LrShift 2+        action t 0 (NonTerm "S") `shouldBe` LrGoto 4+        action t 0 (NonTerm "C") `shouldBe` LrGoto 3+        action t 1 (Term 'c') `shouldBe` LrShift 1+        action t 1 (Term 'd') `shouldBe` LrShift 2+        action t 1 (NonTerm "C") `shouldBe` LrGoto 5+        action t 2 (Term 'c') `shouldBe` LrReduce r2+        action t 2 (Term 'd') `shouldBe` LrReduce r2+        action t 2 Empty `shouldBe` LrReduce r2+        action t 3 (Term 'c') `shouldBe` LrShift 1+        action t 3 (Term 'd') `shouldBe` LrShift 2+        action t 3 (NonTerm "C") `shouldBe` LrGoto 6+        action t 4 Empty `shouldBe` LrAccept+        action t 5 (Term 'c') `shouldBe` LrReduce r1+        action t 5 (Term 'd') `shouldBe` LrReduce r1+        action t 5 Empty `shouldBe` LrReduce r1+        action t 6 Empty `shouldBe` LrReduce r0++  it "should detect conflicts during the table generation" $ do+    let r0 = Rule "__start" [NonTerm "S", Empty]+    let r1 = Rule "S" [Term 'a', NonTerm "A", Term 'd', Empty]+    let r2 = Rule "S" [Term 'b', NonTerm "B", Term 'd', Empty]+    let r3 = Rule "S" [Term 'a', NonTerm "B", Term 'e', Empty]+    let r4 = Rule "S" [Term 'b', NonTerm "A", Term 'e', Empty]+    let r5 = Rule "A" [Term 'c', Empty]+    let r6 = Rule "B" [Term 'c', Empty]+    let rs = ruleSet [r0, r1, r2, r3, r4, r5, r6]+    let fs = firstSet rs+    let c = collection rs fs :: LrCollection LalrItem+    let e = ["(4,'e') conflict: reduce B -> 'c',$ with reduce A -> 'c',$",+             "(4,'d') conflict: reduce B -> 'c',$ with reduce A -> 'c',$"]+    case table c of+      Left err -> err `shouldBe` e+      Right t  -> show t `shouldBe` "an error"
+ test/PPTest/Builders/Lr1.hs view
@@ -0,0 +1,55 @@+module PPTest.Builders.Lr1 (specs) where++import qualified Data.Set        as Set+import qualified Data.Vector     as Vector+import           PP+import           PP.Builders.Lr1+import           Test.Hspec++specs = describe "PPTest.Builders.Lr1" $++  it "should build the LR(1) items set collection" $ do+      -- Dragon Book (2nd edition, fr), page 240, example 4.54+    let rs = ruleSet [Rule "__start" [NonTerm "S", Empty],+                      Rule "S" [NonTerm "C", NonTerm "C", Empty],+                      Rule "C" [Term 'c', NonTerm "C", Empty],+                      Rule "C" [Term 'd', Empty]]+    let fs = firstSet rs+    let c = collection rs fs :: LrCollection Lr1Item+    let e0 = [Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'c'),+              Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'd'),+              Lr1Item (Rule "C" [Term 'd',Empty]) 0 (Term 'c'),+              Lr1Item (Rule "C" [Term 'd',Empty]) 0 (Term 'd'),+              Lr1Item (Rule "S" [NonTerm "C",NonTerm "C",Empty]) 0 Empty,+              Lr1Item (Rule "__start" [NonTerm "S",Empty]) 0 Empty]+    let e1 = [Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'c'),+              Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 (Term 'd'),+              Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 1 (Term 'c'),+              Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 1 (Term 'd'),+              Lr1Item (Rule "C" [Term 'd',Empty]) 0 (Term 'c'),+              Lr1Item (Rule "C" [Term 'd',Empty]) 0 (Term 'd')]+    let e2 = [Lr1Item (Rule "C" [Term 'd',Empty]) 1 (Term 'c'),+              Lr1Item (Rule "C" [Term 'd',Empty]) 1 (Term 'd')]+    let e3 = [Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 Empty,+              Lr1Item (Rule "C" [Term 'd',Empty]) 0 Empty,+              Lr1Item (Rule "S" [NonTerm "C",NonTerm "C",Empty]) 1 Empty]+    let e4 = [Lr1Item (Rule "__start" [NonTerm "S",Empty]) 1 Empty]+    let e5 = [Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 2 (Term 'c'),+              Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 2 (Term 'd')]+    let e6 = [Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 0 Empty,+              Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 1 Empty,+              Lr1Item (Rule "C" [Term 'd',Empty]) 0 Empty]+    let e7 = [Lr1Item (Rule "C" [Term 'd',Empty]) 1 Empty]+    let e8 = [Lr1Item (Rule "S" [NonTerm "C",NonTerm "C",Empty]) 2 Empty]+    let e9 = [Lr1Item (Rule "C" [Term 'c',NonTerm "C",Empty]) 2 Empty]+    Vector.length c `shouldBe` 10+    Set.toList (c Vector.! 0) `shouldBe` e0+    Set.toList (c Vector.! 1) `shouldBe` e1+    Set.toList (c Vector.! 2) `shouldBe` e2+    Set.toList (c Vector.! 3) `shouldBe` e3+    Set.toList (c Vector.! 4) `shouldBe` e4+    Set.toList (c Vector.! 5) `shouldBe` e5+    Set.toList (c Vector.! 6) `shouldBe` e6+    Set.toList (c Vector.! 7) `shouldBe` e7+    Set.toList (c Vector.! 8) `shouldBe` e8+    Set.toList (c Vector.! 9) `shouldBe` e9
+ test/PPTest/Builders/Nfa.hs view
@@ -0,0 +1,85 @@+module PPTest.Builders.Nfa (specs) where++import qualified Data.Char                  as C+import qualified Data.Graph.Inductive.Graph as Gr+import           PP+import           PP.Builders.Nfa+import           PP.Grammars.Lexical+import           Test.Hspec++-- Utilities+getNfa expr = let Right ast = (parseAst expr :: To RegExpr) in buildNfa ast+isValue (_, _, NfaValue _) = True+isValue _                  = False++specs = describe "PPTest.Builders.Nfa" $ do++  it "should build the correct automaton ((a|b)*abb)" $ do+    -- Dragon Book (2nd edition, fr), page 142, figure 3.34+    let expr = "(a|b)*abb"+    let e = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaNode),(3,NfaNode),+                        (4,NfaNode),(5,NfaNode),(6,NfaNode),(7,NfaNode),+                        (8,NfaNode),(9,NfaNode),(10,NfaFinal expr)]+                       [(0,1,NfaEmpty),(0,7,NfaEmpty),(1,2,NfaEmpty),+                        (1,4,NfaEmpty),(2,3,NfaValue 'a'),(3,6,NfaEmpty),+                        (4,5,NfaValue 'b'),(5,6,NfaEmpty),(6,1,NfaEmpty),+                        (6,7,NfaEmpty),(7,8,NfaValue 'a'),(8,9,NfaValue 'b'),+                        (9,10,NfaValue 'b')]+    getNfa expr `shouldBe` e++  it "should build the correct automaton (a+)" $ do+    let expr = "a+"+    let e = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaNode),(3,NfaFinal expr)]+                       [(0,1,NfaEmpty),(1,2,NfaValue 'a'),+                        (2,1,NfaEmpty),(2,3,NfaEmpty)]+    getNfa expr `shouldBe` e++  it "should build the correct automaton (a?)" $ do+    let expr = "a?"+    let e = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaNode),(3,NfaFinal expr)]+                       [(0,1,NfaEmpty),(0,3,NfaEmpty),+                        (1,2,NfaValue 'a'),(2,3,NfaEmpty)]+    getNfa expr `shouldBe` e++  it "should build the correct automaton ([a-c])" $ do+    let expr = "[a-c]"+    let e = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaNode),(3,NfaNode),+                        (4,NfaNode),(5,NfaNode),(6,NfaNode),(7,NfaFinal expr)]+                       [(0,1,NfaEmpty),(0,3,NfaEmpty),(0,5,NfaEmpty),+                        (1,2,NfaValue 'a'),(2,7,NfaEmpty),(3,4,NfaValue 'b'),+                        (4,7,NfaEmpty),(5,6,NfaValue 'c'),(6,7,NfaEmpty)]+    getNfa expr `shouldBe` e++  it "should build the correct automaton ([a-c0-2.-])" $ do+    let expr = "[a-c0-2.-]"+    let e = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaNode),(3,NfaNode),+                        (4,NfaNode),(5,NfaNode),(6,NfaNode),(7,NfaNode),+                        (8,NfaNode),(9,NfaNode),(10,NfaNode),(11,NfaNode),+                        (12,NfaNode),(13,NfaNode),(14,NfaNode),(15,NfaNode),+                        (16,NfaNode),(17,NfaFinal expr)]+                       [(0,1,NfaEmpty),(0,3,NfaEmpty),(0,5,NfaEmpty),+                        (0,7,NfaEmpty),(0,9,NfaEmpty),(0,11,NfaEmpty),+                        (0,13,NfaEmpty),(0,15,NfaEmpty),(1,2,NfaValue 'a'),+                        (2,17,NfaEmpty),(3,4,NfaValue 'b'),(4,17,NfaEmpty),+                        (5,6,NfaValue 'c'),(6,17,NfaEmpty),(7,8,NfaValue '0'),+                        (8,17,NfaEmpty),(9,10,NfaValue '1'),(10,17,NfaEmpty),+                        (11,12,NfaValue '2'),(12,17,NfaEmpty),(13,14,NfaValue '.'),+                        (14,17,NfaEmpty),(15,16,NfaValue '-'),(16,17,NfaEmpty)]+    getNfa expr `shouldBe` e++  it "should build the correct automaton (.)" $ do+    let expr = "."+    let e = [c | c <- [minBound..maxBound], C.isAscii c]+    let values = map (\(_, _, NfaValue c) -> c) $ filter isValue $ Gr.labEdges $ getNfa expr+    values `shouldBe` e++  it "should combine multiple NFA in one correctly" $ do+    let a = Gr.mkGraph [(0,NfaInitial),(1,NfaFinal "a")]+                       [(0,1,NfaValue 'a')]+    let b = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaFinal "bc")]+                       [(0,1,NfaValue 'b'),(1,2,NfaValue 'c')]+    let e = Gr.mkGraph [(0,NfaInitial),(1,NfaNode),(2,NfaFinal "a"),(3,NfaNode),+                        (4,NfaNode),(5,NfaFinal "bc")]+                       [(0,1,NfaEmpty),(0,3,NfaEmpty),(1,2,NfaValue 'a'),+                        (3,4,NfaValue 'b'),(4,5,NfaValue 'c')]+    combineNfa [a,b] `shouldBe` e
+ test/PPTest/Grammars/Ebnf.hs view
@@ -0,0 +1,139 @@+module PPTest.Grammars.Ebnf (specs) where++import           Data.Either+import           PP+import           PP.Grammars.Ebnf+import           System.IO+import           Test.Hspec++specs = describe "PPTest.Grammars.Ebnf" $ do++  it "should detect a simple syntax error" $+    case parseAst "a = b" :: To Syntax of+      Left e  -> show e `shouldNotBe` ""+      Right o -> stringify o `shouldBe` "an error"++  it "should detect bad enclosing" $+    case parseAst "a = (b | [c - {d})" :: To Syntax of+      Left e  -> show e `shouldNotBe` ""+      Right o -> stringify o `shouldBe` "an error"++  it "should parseAst a simple correct input" $+    case parseAst "a = b;" :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "<a>=<b>;"++  it "should parseAst a more complex correct input" $+    case parseAst "a = b, (c | d);\ne = 4 * [f];\nh = i | j;" :: To Syntax of+      Left e -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "<a>=<b>,(<c>|<d>);\n<e>=4*[<f>];\n<h>=<i>|<j>;"++  it "should parseAst terminal string" $+    case parseAst "a = \"h 'w\"; b = \"h \\\"w\";" :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "<a>=\"h 'w\";\n<b>=\"h \\\"w\";"++  it "should parseAst complex meta identifiers" $+    case parseAst "a a = b; a = b b; <a>=b; a=<b>;" :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "<a a>=<b>;\n<a>=<b b>;\n<a>=<b>;\n<a>=<b>;"++  it "should ignore comments" $+    case parseAst "(* 1 *) a = b; (* 2 *) c = d; (* 3 *)" :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "<a>=<b>;\n<c>=<d>;"++  it "should deal with any white spaces" $+    case parseAst " \t\n a \n  = \tb  \n\t|  c  ; \t " :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "<a>=<b>|<c>;"++  it "should parseAst the complete EBNF grammar" $ do+    g <- readFile "test/res/ebnf.ebnf"+    m <- readFile "test/res/ebnf.min.ebnf"+    case parseAst g :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o ++ "\n" `shouldBe` m++  it "should parseAst the complete minified EBNF grammar" $ do+    g <- readFile "test/res/ebnf.min.ebnf"+    m <- readFile "test/res/ebnf.min.ebnf"+    case parseAst g :: To Syntax of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o ++ "\n" `shouldBe` m++  it "should handle multiple parseAst and stringify" $+    case parseAst "a = b;" :: To Syntax of+      Left e1  -> show e1 `shouldBe` "not an error (e1)"+      Right o1 -> let s1 = stringify o1 in+        case parseAst s1 :: To Syntax of+          Left e2  -> show e2 `shouldBe` "not an error (e2)"+          Right o2 -> stringify o2 `shouldBe` "<a>=<b>;"++  it "should handle translation to canonical rules (meta identifiers)" $+    let Right ast = parseAst "a = b;" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [NonTerm "b", PP.Empty]]++  it "should handle translation to canonical rules (alternatives)" $+    let Right ast = parseAst "a = b | c;" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [NonTerm "b", PP.Empty],+                            Rule "a" [NonTerm "c", PP.Empty]]++  it "should handle translation to canonical rules (terminal string)" $+    let Right ast = parseAst "a = \"hi\";" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [PP.Term 'h', PP.Term 'i', PP.Empty]]++  it "should handle translation to canonical rules (optional sequences)" $+    let Right ast = parseAst "a = [b];" :: To Syntax in+      rules ast `shouldBe` [Rule "[<b>]" [NonTerm "b", PP.Empty],+                            Rule "[<b>]" [PP.Empty],+                            Rule "a" [NonTerm "[<b>]", PP.Empty]]++  it "should handle translation to canonical rules (repeated sequences, left)" $+    let Right ast = parseAst "a = {b}, c;" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [NonTerm "{<b>}", NonTerm "c", PP.Empty],+                            Rule "{<b>}" [NonTerm "b", NonTerm "{<b>}", PP.Empty],+                            Rule "{<b>}" [PP.Empty]]++  it "should handle translation to canonical rules (repeated sequences, right)"$+    let Right ast = parseAst "a = c, {b};" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [NonTerm "c", NonTerm "{<b>}", PP.Empty],+                            Rule "{<b>}" [NonTerm "b", NonTerm "{<b>}", PP.Empty],+                            Rule "{<b>}" [PP.Empty]]++  it "should handle translation to canonical rules (grouped sequences)" $+    let Right ast = parseAst "a = (b | c), d;" :: To Syntax in+      rules ast `shouldBe` [Rule "(<b>|<c>)" [NonTerm "b", PP.Empty],+                            Rule "(<b>|<c>)" [NonTerm "c", PP.Empty],+                            Rule "a" [NonTerm "(<b>|<c>)", NonTerm "d", PP.Empty]]++  it "should handle translation to canonical rules (factor)" $+    let Right ast = parseAst "a = 2 * b;" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [NonTerm "b", NonTerm "b", PP.Empty]]++  it "should handle translation to canonical rules (exception)" $+    let Right ast = parseAst "a = <b> - c;" :: To Syntax in+      pendingWith "exception not supported yet"++  it "should handle translation to canonical rules (complex rules)" $+    let Right ast = parseAst "a = [(b, c) | {d}], e | (f | g);" :: To Syntax in+      rules ast `shouldBe` [Rule "(<b>,<c>)" [NonTerm "b",NonTerm "c",PP.Empty],+                            Rule "(<f>|<g>)" [NonTerm "f",PP.Empty],+                            Rule "(<f>|<g>)" [NonTerm "g",PP.Empty],+                            Rule "[(<b>,<c>)|{<d>}]" [NonTerm "(<b>,<c>)",PP.Empty],+                            Rule "[(<b>,<c>)|{<d>}]" [NonTerm "{<d>}",PP.Empty],+                            Rule "[(<b>,<c>)|{<d>}]" [PP.Empty],+                            Rule "a" [NonTerm "(<f>|<g>)",PP.Empty],+                            Rule "a" [NonTerm "[(<b>,<c>)|{<d>}]",NonTerm "e",PP.Empty],+                            Rule "{<d>}" [NonTerm "d",NonTerm "{<d>}",PP.Empty],+                            Rule "{<d>}" [PP.Empty]]++  it "should handle lexical rules (PP.Grammars.LexicalHelper)" $+    let Right ast = parseAst "a = b; b %= c; c = d;" :: To Syntax in+      rules ast `shouldBe` [Rule "a" [NonTerm "b", PP.Empty],+                            Rule "b" [NonTerm "c", PP.Empty],+                            Rule "c" [NonTerm "d", PP.Empty]]++  it "should lexify correctly" $+    let Right ast = parseAst "d%=\"[0-9]\";\nn%=d,\"+\";\ns=\"ab\",n;" :: To Syntax in+      stringify (lexify ast) `shouldBe` "__token_ab%=\"ab\";\nd%=\"[0-9]\";\nn%=d,\"+\";\n<s>=<__token_ab>,<n>;"
+ test/PPTest/Grammars/Lexical.hs view
@@ -0,0 +1,67 @@+module PPTest.Grammars.Lexical (specs) where++import           PP+import           PP.Grammars.Lexical+import           Test.Hspec++specs = describe "PPTest.Grammars.Lexical" $ do++  it "should parse a regular expression (any)" $+    case parseAst "." :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "."++  it "should parse a regular expression (value)" $+    case parseAst "a" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a"++  it "should parse a regular expression (class interval)" $+    case parseAst "[a-z]" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "[a-z]"++  it "should parse a regular expression (class)" $+    case parseAst "[a-z0-9.-]" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "[a-z0-9.-]"++  it "should parse a regular expression (group)" $+    case parseAst "(a)" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "(a)"++  it "should parse a regular expression (option)" $+    case parseAst "a?" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a?"++  it "should parse a regular expression (many1)" $+    case parseAst "a+" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a+"++  it "should parse a regular expression (many0)" $+    case parseAst "a*" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a*"++  it "should parse a regular expression (choice)" $+    case parseAst "abc" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "abc"++  it "should parse a regular expression (regexpr)" $+    case parseAst "ab|cd" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "ab|cd"++  it "should parse a complex regular expression" $+    case parseAst "(a*b)?|[a-z]+(a|[b-d])?|(a|(b|c))de|.|" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "(a*b)?|[a-z]+(a|[b-d])?|(a|(b|c))de|.|"++  it "should parse all meta symbols into class" $+    case parseAst "[[][|][*][+][?][(][(][]][.]" :: To RegExpr of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "[[][|][*][+][?][(][(][]][.]"
+ test/PPTest/Grammars/LexicalHelper.hs view
@@ -0,0 +1,57 @@+module PPTest.Grammars.LexicalHelper (specs) where++import           PP+import           PP.Grammars.LexicalHelper+import           Test.Hspec++specs = describe "PPTest.Grammars.LexicalHelper" $ do++  it "should detect a simple syntax error" $+    case parseAst "a %= b" :: To LexicalRule of+      Left e  -> show e `shouldNotBe` ""+      Right o -> stringify o `shouldBe` "an error"++  it "should parseAst a simple correct input" $+    case parseAst "a %= b;" :: To LexicalRule of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a%=b;"++  it "should parseAst a more complex correct input" $+    case parseAst "a %= b, \"c\", d;" :: To LexicalRule of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a%=b,\"c\",d;"++  it "should parseAst terminal string" $+    case parseAst "a %= \"h 'w\", \"h \\\"w\";" :: To LexicalRule of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a%=\"h 'w\",\"h \\\"w\";"++  it "should parseAst complex meta identifiers" $+    case parseAst "a a %= b b;" :: To LexicalRule of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a a%=b b;"++  it "should deal with any white spaces" $+    case parseAst " \t\n a \n  %= \tb  \n\t,  c  ; \t " :: To LexicalRule of+      Left e  -> show e `shouldBe` "not an error"+      Right o -> stringify o `shouldBe` "a%=b,c;"++  it "should handle multiple parseAst and stringify" $+    case parseAst "a %= b, \"c\";" :: To LexicalRule of+      Left e1  -> show e1 `shouldBe` "not an error (e1)"+      Right o1 -> let s1 = stringify o1 in+        case parseAst s1 :: To LexicalRule of+          Left e2  -> show e2 `shouldBe` "not an error (e2)"+          Right o2 -> stringify o2 `shouldBe` "a%=b,\"c\";"++  it "should handle translation to canonical rules (lexical identifiers)" $+    let Right ast = parseAst "a %= b;" :: To LexicalRule in+      rules ast `shouldBe` [Rule "a" [NonTerm "b", Empty]]++  it "should handle translation to canonical rules (lexical string)" $+    let Right ast = parseAst "a %= \"hi\";" :: To LexicalRule in+      rules ast `shouldBe` [Rule "a" [RegEx "hi", Empty]]++  it "should handle translation to canonical rules (complex rules)" $+    let Right ast = parseAst "a %= b, \"c\", d;" :: To LexicalRule in+      rules ast `shouldBe` [Rule "a" [NonTerm "b", RegEx "c", NonTerm "d", Empty]]
+ test/PPTest/Lexers/Dfa.hs view
@@ -0,0 +1,52 @@+module PPTest.Lexers.Dfa (specs) where++import qualified Data.Graph.Inductive.Graph as Gr+import           PP+import           PP.Lexers.Dfa+import           Test.Hspec++specs = describe "PPTest.Lexers.Dfa" $ do++  it "should create a DFA from a list of lexical rules" $ do+    let rs = [Rule "digit" [RegEx "[0-2]", Empty],+              Rule "number" [TermToken "digit", RegEx "+", Empty]]+    let e = Gr.mkGraph [(0,DfaInitial),(1,DfaFinal "digit"),+                        (2,DfaFinal "digit"),(3,DfaFinal "digit"),+                        (4,DfaFinal "number"),(5,DfaFinal "number"),+                        (6,DfaFinal "number")]+                       [(0,1,DfaValue '0'),(0,2,DfaValue '1'),(0,3,DfaValue '2'),+                        (1,4,DfaValue '0'),(1,5,DfaValue '1'),(1,6,DfaValue '2'),+                        (2,4,DfaValue '0'),(2,5,DfaValue '1'),(2,6,DfaValue '2'),+                        (3,4,DfaValue '0'),(3,5,DfaValue '1'),(3,6,DfaValue '2'),+                        (4,4,DfaValue '0'),(4,5,DfaValue '1'),(4,6,DfaValue '2'),+                        (5,4,DfaValue '0'),(5,5,DfaValue '1'),(5,6,DfaValue '2'),+                        (6,4,DfaValue '0'),(6,5,DfaValue '1'),(6,6,DfaValue '2')]+    createDfa rs `shouldBe` e++  it "should consume a simple token correctly" $ do+    let rs = [Rule "p1" [RegEx "abb", Empty]]+    let dfa = createDfa rs+    let e = [OToken2 "abb" "p1"]+    let input = "abb"+    let config = dfaConfig input dfa+    output (consume config) `shouldBe` e++  it "should consume two tokens correctly" $ do+    -- Dragon Book (2nd edition, fr), page 156, example 3.29+    let rs = [Rule "p1" [RegEx "a", Empty],+              Rule "p2" [RegEx "abb", Empty],+              Rule "p3" [RegEx "a*b+", Empty]]+    let dfa = createDfa rs+    let e = [OToken2 "abb" "p2",+             OToken2 "a" "p1"]+    let input = "abba"+    let config = dfaConfig input dfa+    output (consume config) `shouldBe` e++  it "should ignore bad input" $ do+    let rs = [Rule "p1" [RegEx "a", Empty]]+    let dfa = createDfa rs+    let e = []+    let input = "bbb"+    let config = dfaConfig input dfa+    output (consume config) `shouldBe` e
+ test/PPTest/Other/LexerDfaParserLr.hs view
@@ -0,0 +1,82 @@+module PPTest.Other.LexerDfaParserLr (specs) where++import qualified Data.Map.Strict  as Map+import           PP+import qualified PP.Builders.Lalr as Lalr+import qualified PP.Grammars.Ebnf as Ebnf+import qualified PP.Lexers.Dfa    as Dfa+import qualified PP.Parsers.Lr    as Lr+import           Test.Hspec++import qualified PP.Builders.Nfa  as Nfa++-- Grammar+g = "expr=number,{binop,number};\n\+    \binop%=\"-|[+]\";\n\+    \number%=digit,\"+\";\n\+    \digit%=\"[0-9]\";"+Right ast = parseAst g :: To Ebnf.Syntax++-- Tests for chaining the lexer followed by the parser+specs = describe "PPTest.Other.LexerDfaParserLr" $ do++  it "should be able to extract rules from the AST" $ do+    let e = [Rule "binop" [RegEx "-|[+]",Empty],+             Rule "digit" [RegEx "[0-9]",Empty],+             Rule "expr" [NonTerm "number",NonTerm "{<binop>,<number>}",Empty],+             Rule "number" [NonTerm "digit",RegEx "+",Empty],+             Rule "{<binop>,<number>}" [NonTerm "binop",NonTerm "number",NonTerm "{<binop>,<number>}",Empty],+             Rule "{<binop>,<number>}" [Empty]]+    rules (lexify ast) `shouldBe` e++  it "should be able to separate parsing and lexing rules" $ do+    let e = ([Rule "expr" [TermToken "number",NonTerm "{<binop>,<number>}",Empty],+              Rule "{<binop>,<number>}" [TermToken "binop",TermToken "number",NonTerm "{<binop>,<number>}",Empty],+              Rule "{<binop>,<number>}" [Empty]],+             [Rule "binop" [RegEx "-|[+]",Empty],+              Rule "digit" [RegEx "[0-9]",Empty],+              Rule "number" [TermToken "digit",RegEx "+",Empty]])+    separate (rules $ lexify ast) `shouldBe` e++  it "should be able to create a LALR table" $ do+    let Right prs = extend $ fst $ separate $ rules $ lexify ast+    let rs = ruleSet prs+    let c = collection rs (firstSet rs) :: LrCollection Lalr.LalrItem+    let e = [((0,NonTerm "expr"),LrGoto 1),+             ((0,TermToken "number"),LrShift 2),+             ((1,Empty),LrAccept),+             ((2,NonTerm "{<binop>,<number>}"),LrGoto 3),+             ((2,TermToken "binop"),LrShift 4),+             ((2,Empty),LrReduce $ Rule "{<binop>,<number>}" [Empty]),+             ((3,Empty),LrReduce $ Rule "expr" [TermToken "number",NonTerm "{<binop>,<number>}",Empty]),+             ((4,TermToken "number"),LrShift 5),+             ((5,NonTerm "{<binop>,<number>}"),LrGoto 6),+             ((5,TermToken "binop"),LrShift 4),+             ((5,Empty),LrReduce $ Rule "{<binop>,<number>}" [Empty]),+             ((6,Empty),LrReduce $ Rule "{<binop>,<number>}" [TermToken "binop",TermToken "number",NonTerm "{<binop>,<number>}",Empty])]+    case table c of+      Left err -> show err `shouldNotBe` "an error"+      Right t  -> Map.toList t `shouldBe` e++  it "should be able to create the correct tokens" $ do+    let i = "123-456+789"+    let (_, lrs) = separate $ rules $ lexify ast+    let lconfig = Dfa.dfaConfig i $ Dfa.createDfa lrs+    let e = [OToken2 "123" "number",+             OToken2 "-" "binop",+             OToken2 "456" "number",+             OToken2 "+" "binop",+             OToken2 "789" "number"]+    output (consume lconfig) `shouldBe` e++  it "should be able to use a lexer and a parser in sequence" $ do+    let i = "123-456+789"+    let (prs, lrs) = separate $ rules $ lexify ast+    let rs = ruleSet $ let Right x = extend prs in x+    let c = collection rs (firstSet rs) :: LrCollection Lalr.LalrItem+    let Right t = table c+    let dfa = Dfa.createDfa lrs+    let lconfig = Dfa.dfaConfig i dfa+    let tokens = output $ consume lconfig+    let pconfig = config t tokens+    Lr.lrAction (parse t pconfig) `shouldBe` LrAccept
+ test/PPTest/Parsers/Lr.hs view
@@ -0,0 +1,82 @@+module PPTest.Parsers.Lr (specs) where++import qualified Data.List        as L+import           PP+import           PP.Builders.Lalr+import           PP.Parsers.Lr+import           Test.Hspec++-- Dragon Book (2nd edition, fr), page 230, example 4.45+r0 = Rule "__start" [NonTerm "E", Empty]+r1 = Rule "E" [NonTerm "T", Term '+', NonTerm "E", Empty]+r2 = Rule "E" [NonTerm "T", Empty]+r3 = Rule "T" [NonTerm "F", Term '*', NonTerm "T", Empty]+r4 = Rule "T" [NonTerm "F", Empty]+r5 = Rule "F" [Term '(', NonTerm "E", Term ')', Empty]+r6 = Rule "F" [Term 'x', Empty]+rs = ruleSet [r0, r1, r2, r3, r4, r5, r6]+fs = firstSet rs+c = collection rs fs :: LrCollection LalrItem+Right t = table c++specs = describe "PPTest.Parsers.Lr" $ do++  it "should build the first configuration" $ do+    let cfg = config t (charLexer "x*x+x") :: LrConfig+    cfg `shouldBe` LrConfig 0 [0] (LrShift 3) (charLexer "x*x+x") (LrAstRoot [])++  it "should parse a simple grammar correctly" $ do+    -- Dragon Book (2nd edition, fr), page 232, figure 4.38+    let e = [ LrConfig 0 [0] (LrShift 3) (charLexer "x*x+x")+              (LrAstRoot [])+            , LrConfig 1 [3,0] (LrReduce r6) (charLexer "*x+x")+              (LrAstRoot [LrAstTerm [OToken1 "x"]])+            , LrConfig 2 [0] (LrGoto 4) (charLexer "*x+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]])+            , LrConfig 3 [4,0] (LrShift 8) (charLexer "*x+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]])+            , LrConfig 4 [8,4,0] (LrShift 3) (charLexer "x+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"]])+            , LrConfig 5 [3,8,4,0] (LrReduce r6) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstTerm [OToken1 "x"]])+            , LrConfig 6 [8,4,0] (LrGoto 4) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]])+            , LrConfig 7 [4,8,4,0] (LrReduce r4) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]])+            , LrConfig 8 [8,4,0] (LrGoto 11) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]])+            , LrConfig 9 [11,8,4,0] (LrReduce r3) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]])+            , LrConfig 10 [0] (LrGoto 1) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]]])+            , LrConfig 11 [1,0] (LrShift 6) (charLexer "+x")+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]]])+            , LrConfig 12 [6,1,0] (LrShift 3) (charLexer "x")+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"]])+            , LrConfig 13 [3,6,1,0] (LrReduce r6) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstTerm [OToken1 "x"]])+            , LrConfig 14 [6,1,0] (LrGoto 4) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]])+            , LrConfig 15 [4,6,1,0] (LrReduce r4) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]])+            , LrConfig 16 [6,1,0] (LrGoto 1) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]])+            , LrConfig 17 [1,6,1,0] (LrReduce r2) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]])+            , LrConfig 18 [6,1,0] (LrGoto 9) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "E" [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]]])+            , LrConfig 19 [9,6,1,0] (LrReduce r1) []+              (LrAstRoot [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "E" [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]]])+            , LrConfig 20 [0] (LrGoto 5) []+              (LrAstRoot [LrAstNonTerm "E" [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "E" [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]]]])+            , LrConfig 21 [5,0] LrAccept []+              (LrAstRoot [LrAstNonTerm "E" [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]],LrAstTerm [OToken1 "*"],LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]],LrAstTerm [OToken1 "+"],LrAstNonTerm "E" [LrAstNonTerm "T" [LrAstNonTerm "F" [LrAstTerm [OToken1 "x"]]]]]])]+    let cfg = L.reverse $ parse' t $ config t (charLexer "x*x+x") :: [LrConfig]+    L.length cfg `shouldBe` 22+    cfg `shouldBe` e++  it "should detect an error in input" $ do+    let cfg = parse t $ config t (charLexer "x+x*()+x") :: LrConfig+    let (LrConfig _ _ s i _) = cfg+    s `shouldBe` LrError+    i `shouldBe` charLexer ")+x"
+ test/PPTest/Rule.hs view
@@ -0,0 +1,125 @@+module PPTest.Rule (specs) where++import           Data.Map.Strict (toList)+import           PP+import           Test.Hspec++specs = describe "PPTest.Rule" $ do++  it "should uniformize correctly" $ do+    let r = [Rule "c" [Concat [Empty, Empty], Empty],+             Rule "a" [Rule "b" [Empty, Term 'c', Empty], Term 'c', Empty]]+    let e = [Rule "a" [NonTerm "b", Term 'c', Empty],+             Rule "b" [Term 'c', Empty],+             Rule "c" [Empty]]+    uniformize r `shouldBe` e++  it "should find the start rule and extend it" $ do+    let r = [Rule "a" [NonTerm "b", Empty],+             Rule "a" [Term 'c', Empty],+             Rule "b" [Term 'd', Empty]]+    let e = [Rule "__start" [NonTerm "a", Empty],+             Rule "a" [NonTerm "b", Empty],+             Rule "a" [Term 'c', Empty],+             Rule "b" [Term 'd', Empty]]+    extend r `shouldBe` Right e++  it "should detect when there is no start rule" $ do+    let r = [Rule "a" [NonTerm "b", Empty],+             Rule "a" [Term 'c', Empty],+             Rule "b" [Term 'd', NonTerm "c", Empty],+             Rule "c" [NonTerm "a", Empty]]+    extend r `shouldBe` Left "cannot extend, no start rule found (candidates: [])"++  it "should detect when there are many start rules" $ do+    let r = [Rule "a" [NonTerm "b", Empty],+             Rule "a" [Term 'c', Empty],+             Rule "b" [Term 'd', Empty],+             Rule "c" [NonTerm "b", Empty]]+    extend r `shouldBe` Left "cannot extend, no start rule found (candidates: [\"a\",\"c\"])"++  it "should generate the correct RuleSet" $ do+    let r = [Rule "__start" [NonTerm "a", Empty],+             Rule "a" [Term 'b', Empty],+             Rule "a" [NonTerm "c", Empty],+             Rule "c" [Term 'd', Empty],+             Rule "c" [Empty],+             Rule "e" [Empty]]+    let e = [("__start", [[NonTerm "a", Empty]]),+             ("a", [[Term 'b', Empty], [NonTerm "c", Empty]]),+             ("c", [[Term 'd', Empty], [Empty]]),+             ("e", [[Empty]])]+    toList (ruleSet r) `shouldBe` e++  it "should generate the correct FirstSet" $ do+    let r = [Rule "__start" [NonTerm "A", Empty],+             Rule "A" [NonTerm "B", Empty],+             Rule "A" [Term 'a', Empty],+             Rule "B" [Term 'b', Empty],+             Rule "B" [NonTerm "C", NonTerm "D", Empty],+             Rule "C" [Term 'c', Empty],+             Rule "C" [Empty],+             Rule "D" [Term 'd', Empty]]+    let e = [("A", [Term 'a', Term 'b', Term 'c', Empty]),+             ("B", [Term 'b', Term 'c', Empty]),+             ("C", [Term 'c', Empty]),+             ("D", [Term 'd']),+             ("__start", [Term 'a', Term 'b', Term 'c', Empty])]+    toList (firstSet (ruleSet r)) `shouldBe` e++  it "should handle left recursion (firstSet)" $ do+      let r = [Rule "__start" [NonTerm "E", Empty],+               Rule "E" [NonTerm "E", Term '+', NonTerm "T", Empty],+               Rule "E" [NonTerm "T", Empty],+               Rule "T" [NonTerm "T", Term '*', NonTerm "F", Empty],+               Rule "T" [NonTerm "F", Empty],+               Rule "F" [Term '(', NonTerm "E", Term ')', Empty],+               Rule "F" [Term 'x', Empty]]+      let e = [("E", [Term '(', Term 'x']),+               ("F", [Term '(', Term 'x']),+               ("T", [Term '(', Term 'x']),+               ("__start", [Term '(', Term 'x'])]+      toList (firstSet (ruleSet r)) `shouldBe` e++  it "should check a rules set for missing non-terminals" $ do+    let r = [Rule "__start" [NonTerm "A", Empty],+             Rule "A" [NonTerm "B", NonTerm "C", Empty],+             Rule "C" [Empty]]+    let e = (["missing non-terminal: B"], [])+    check (ruleSet r) `shouldBe` e++  it "should check a rules set for unused non-terminals" $ do+    let r = [Rule "__start" [NonTerm "A", Empty],+             Rule "A" [NonTerm "B", Empty],+             Rule "B" [Empty],+             Rule "C" [Empty]]+    let e = ([], ["unused non-terminal: C"])+    check (ruleSet r) `shouldBe` e++  it "should check a rules set for direct left recursion" $ do+    let r = [Rule "__start" [NonTerm "A", Empty],+             Rule "A" [NonTerm "B", Empty],+             Rule "B" [NonTerm "B", Term 'b', Empty]]+    let e = (["direct left-recusion: B"], [])+    check (ruleSet r) `shouldBe` e++  it "should check a rules set for indirect left recursion" $+    pendingWith "not impl. yet"++  it "should separate parsing and lexing rules" $ do+    let r = [Rule "a" [NonTerm "b", Empty],+             Rule "c" [RegEx "d", Empty]]+    let e = ([Rule "a" [NonTerm "b", Empty]],+             [Rule "c" [RegEx "d", Empty]])+    separate r `shouldBe` e++  it "should transform lexical rules to have only one regex on right" $ do+    let r = [Rule "a" [TermToken "b", Empty],+             Rule "b" [TermToken "c", RegEx "bb", Empty],+             Rule "c" [RegEx "cc", TermToken "d", Empty],+             Rule "d" [RegEx "dd", RegEx "dd", Empty]]+    let e = [Rule "a" [RegEx "ccddddbb", Empty],+             Rule "b" [RegEx "ccddddbb", Empty],+             Rule "c" [RegEx "ccdddd", Empty],+             Rule "d" [RegEx "dddd", Empty]]+    regexfy r `shouldBe` e
+ test/PPTest/Template.hs view
@@ -0,0 +1,19 @@+module PPTest.Template (specs) where++import qualified Data.Graph.Inductive.Graph as Gr+import qualified Data.Map.Strict            as Map+import           PP+import qualified PP.Templates.Dfa           as Dfa+import qualified PP.Templates.Lr            as Lr+import           Test.Hspec++specs = describe "PPTest.Template" $++  it "should be able to compile two contexts together" $ do+    let t = Map.singleton (0, Term 'a') LrAccept+    let dfa = Gr.mkGraph [(0,DfaInitial),(1,DfaFinal "f")]+                         [(0,1,DfaValue 'b')] :: DfaGraph+    let c1 = Lr.context t+    let c2 = Dfa.context dfa+    let st = "$length(lr.states)$ $length(dfa.states)$"+    compile (mergeContext c1 c2) st `shouldBe` "1 2"
+ test/PPTest/Templates/Dfa.hs view
@@ -0,0 +1,25 @@+module PPTest.Templates.Dfa (specs) where++import qualified Data.Graph.Inductive.Graph as Gr+import           PP+import qualified PP.Templates.Dfa           as Dfa+import           Test.Hspec++specs = describe "PPTest.Templates.Dfa" $++  it "should compile correctly a template" $ do+    let dfa = Gr.mkGraph [(0,DfaInitial),(1,DfaNode),(2,DfaFinal "ab")]+                         [(0,1,DfaValue 'a'),(1,2,DfaValue 'b')]+    let t = "STATE $length(dfa.states)$\n\+            \$dfa.states:{state|$state.id$ $if(state.isInitial)$INITIAL$elseif(state.isNode)$NODE$else$FINAL $state.final$$endif$\n\+            \}$TRANSITION $length(dfa.transitions)$\n\+            \$dfa.transitions:{trans|$trans.from$ $trans.to$ $trans.symbol$\n\+            \}$"+    let e = "STATE 3\n\+            \0 INITIAL\n\+            \1 NODE\n\+            \2 FINAL ab\n\+            \TRANSITION 2\n\+            \0 1 a\n\+            \1 2 b\n"+    compile (Dfa.context dfa) t `shouldBe` e
+ test/PPTest/Templates/Lr.hs view
@@ -0,0 +1,27 @@+module PPTest.Templates.Lr (specs) where++import qualified Data.List        as L+import           PP+import           PP.Builders.Lalr+import           PP.Templates.Lr  as Lr+import           System.IO+import           Test.Hspec++r0 = Rule "__start" [NonTerm "E", Empty]+r1 = Rule "E" [NonTerm "T", Term '+', NonTerm "E", Empty]+r2 = Rule "E" [NonTerm "T", Empty]+r3 = Rule "T" [NonTerm "F", Term '*', NonTerm "T", Empty]+r4 = Rule "T" [NonTerm "F", Empty]+r5 = Rule "F" [Term '(', NonTerm "E", Term ')', Empty]+r6 = Rule "F" [Term 'x', Empty]+rs = ruleSet [r0, r1, r2, r3, r4, r5, r6]+fs = firstSet rs+c = collection rs fs :: LrCollection LalrItem+Right t = table c++specs = describe "PPTest.Templates.Lr" $++  it "should compile correctly a template" $ do+    te <- readFile "test/res/lr-table"+    e <- readFile "test/res/lr-table.test"+    compile (Lr.context t) te `shouldBe` e
+ test/Spec.hs view
@@ -0,0 +1,35 @@+module Main where++import qualified PPTest.Builders.Dfa+import qualified PPTest.Builders.Lalr+import qualified PPTest.Builders.Lr1+import qualified PPTest.Builders.Nfa+import qualified PPTest.Grammars.Ebnf+import qualified PPTest.Grammars.Lexical+import qualified PPTest.Grammars.LexicalHelper+import qualified PPTest.Lexers.Dfa+import qualified PPTest.Other.LexerDfaParserLr+import qualified PPTest.Parsers.Lr+import qualified PPTest.Rule+import qualified PPTest.Template+import qualified PPTest.Templates.Dfa+import qualified PPTest.Templates.Lr+import           Test.Hspec++main :: IO ()+main = hspec $+  describe "PPTest" $ do+    PPTest.Grammars.Ebnf.specs+    PPTest.Rule.specs+    PPTest.Builders.Lr1.specs+    PPTest.Builders.Lalr.specs+    PPTest.Parsers.Lr.specs+    PPTest.Templates.Lr.specs+    PPTest.Grammars.LexicalHelper.specs+    PPTest.Grammars.Lexical.specs+    PPTest.Builders.Nfa.specs+    PPTest.Builders.Dfa.specs+    PPTest.Lexers.Dfa.specs+    PPTest.Other.LexerDfaParserLr.specs+    PPTest.Templates.Dfa.specs+    PPTest.Template.specs