packages feed

LR-demo (empty) → 0.0.20251105

raw patch · 17 files changed

+1531/−0 lines, 17 filesdep +LR-demodep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: LR-demo, array, base, containers, microlens, microlens-th, mtl, string-qq, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+0.0.20251105+============++- Initial release.+- Tested with GHC 8.4.4 - 9.12.2.
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright (C) 2019-25 Andreas Abel++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ LR-demo.cabal view
@@ -0,0 +1,104 @@+cabal-version: 2.2++name:           LR-demo+version:        0.0.20251105+synopsis:       LALR(1) parsetable generator and interpreter+description:    An LALR(1) parsetable generator and interpreter.+category:       Parsing+author:         Andreas Abel <andreas.abel@gu.se>+maintainer:     Andreas Abel <andreas.abel@gu.se>+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Custom++tested-with:+    GHC == 9.12.2+    GHC == 9.10.3+    GHC == 9.8.4+    GHC == 9.6.7+    GHC == 9.4.8+    GHC == 9.2.8+    GHC == 9.0.2+    GHC == 8.10.7+    GHC == 8.8.4+    GHC == 8.6.5+    GHC == 8.4.4++extra-doc-files:+  CHANGELOG.md+  README.md++extra-source-files: src/LBNF.cf++source-repository head+  type: git+  location: https://github.com/teach-plt/LR-demo.git++custom-setup+  setup-depends:+      Cabal   >= 2.2   && < 3.17+        -- Distribution.Simple.BuildPaths.autogenPackageModulesDir is new in Cabal-2.0+        -- We use cabal-version: 2.2, so also Cabal >= 2.2 for the sake of Stack.+    , base    >= 4.11  && < 5+        -- Restrict to GHC >= 8.4 which ships Cabal-2.2 (otherwise Cabal has to be reinstalled)+    , process+    -- Adding BNFC here does not help because that only provides the BNFC _library_,+    -- not the _executable that_ we call from 'Setup.hs'.++library+  exposed-modules:+      CFG+      CharacterTokenGrammar+      DebugPrint+      License+      LBNF.Abs+      LBNF.Lex+      LBNF.Par+      LBNF.Print+      LR+      ParseTable+      ParseTable.Pretty+      Saturation+      SetMaybe+      Util+      Paths_LR_demo+  autogen-modules:+      LBNF.Abs+      LBNF.Lex+      LBNF.Par+      LBNF.Print+      Paths_LR_demo+  hs-source-dirs:+      src+  build-depends:+      array+    , base >= 4.11 && <5+    , containers+    , microlens+    , microlens-th+    , mtl+    , string-qq+    , transformers+  build-tool-depends:+      BNFC:bnfc+    , alex:alex+    , happy:happy+  default-language: Haskell2010++executable lr-demo+  hs-source-dirs:   lr-demo+  main-is:          Main.hs+  build-depends:    LR-demo+  default-language: Haskell2010++-- executable cyk+--   main-is:          CYK.hs+--   hs-source-dirs:   main-cyk+--   ghc-options:      -main-is CYK+--   build-depends:+--       LR-demo+--     , base+--     , containers+--     , mtl+--     , transformers+--   default-language: Haskell2010
+ README.md view
@@ -0,0 +1,89 @@+# A parser for LALR(1) grammars in Haskell++Usage:+```+lr-demo MyGrammar.cf < MyInput.txt+```+Prints the generated LALR(1) parse table for context-free grammar `MyGrammar.cf`+and a trace of shift and reduce actions of the parser when accepting `MyInput.txt`.++The input `.cf` file consists of labelled BNF rules (LBNF) of the form:+```+LABEL "." NONTERMINAL "::=" (NONTERMINAL | TERMINAL)* ";"+```+For example:+```+Par.  S ::= "(" S ")" S ;+Done. S ::= ;+```+This format is compatible with BNFC (but BNFC pragmas are not recognized).++Limitation: terminals can only be single characters.++## Getting started++1. Have Haskell Stack installed.+2. Clone and enter this repository.+3. Execute: `stack run lr-demo -- test/BalancedParentheses.cf < test/BalPar.txt`+```+Using the following grammar:++Done . S ::=;+Par . S ::= "(" S ")" S;++Generated parse table:++State 0++	eof	reduce with rule Done+	'('	shift to state 1++	S 	goto state 2++State 1++	'('	shift to state 1+	')'	reduce with rule Done++	S 	goto state 3++State 2++	eof	reduce with rule %start++State 3++	')'	shift to state 4++State 4++	eof	reduce with rule Done+	'('	shift to state 1+	')'	reduce with rule Done++	S 	goto state 5++State 5++	eof	reduce with rule Par+	')'	reduce with rule Par+++Parsing stdin...+            . '(' ')'  -- shift+'('         . ')'      -- reduce with rule Done+'(' S       . ')'      -- shift+'(' S ')'   .          -- reduce with rule Done+'(' S ')' S .          -- reduce with rule Par+S           .          -- halt+```++## Reference++```+stack run -- --help+```++## License++BSD 3-clause.
+ Setup.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}++-- | Hook BNFC into the cabal build process to generate AST, lexer, parser, and printer definitions.++import Distribution.Simple            (defaultMainWithHooks, simpleUserHooks, buildHook, replHook)+import Distribution.Simple.BuildPaths (autogenPackageModulesDir)+#if MIN_VERSION_Cabal(3,14,0)+import Distribution.Utils.Path        (interpretSymbolicPath)+#endif+import System.Process                 (callProcess)++main :: IO ()+main = do+  defaultMainWithHooks simpleUserHooks+    { buildHook = \ packageDescription localBuildInfo userHooks buildFlags -> do+        -- Call BNFC.+        callBNFC localBuildInfo+        -- Run the build process.+        buildHook simpleUserHooks packageDescription localBuildInfo userHooks buildFlags+    , replHook = \ packageDescription localBuildInfo userHooks buildFlags replArgs -> do+        -- Call BNFC.+        callBNFC localBuildInfo+        -- Run the repl.+        replHook simpleUserHooks packageDescription localBuildInfo userHooks buildFlags replArgs+    }+  where+    callBNFC localBuildInfo = do+      -- For simplicity, generate files in build/global-autogen;+      -- there they are available to all components of the package.+      callProcess "bnfc"+        [ "-o",+#if MIN_VERSION_Cabal(3,14,0)+          interpretSymbolicPath Nothing $+#endif+            autogenPackageModulesDir localBuildInfo+        , "-d"+        , "src/LBNF.cf"+        ]
+ lr-demo/Main.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-}++import qualified LR++main = LR.main
+ src/CFG.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Context-free grammars: syntax and grammar folds.++module CFG where++import Control.Monad.Except+import Control.Monad.State++import qualified Data.Foldable as Fold+import qualified Data.List as List+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++import Data.Maybe (mapMaybe)+import Data.Function (on)+import Data.Tuple (swap)+import Data.Semigroup (Semigroup(..))++-- uses microlens-platform+import Lens.Micro+import Lens.Micro.Extras (view)+import Lens.Micro.TH (makeLenses)++import Saturation+import SetMaybe (SetMaybe)+import qualified SetMaybe++-- | A grammar over non-terminal names x, rulenames r and an alphabet t+--   consists of definitions of the nonterminals, represented as Ints.++data Grammar' x r t = Grammar+  { _grmNumNT  :: Int                   -- ^ Number of non-terminals.+  , _grmNTDict :: Map x NTId            -- ^ Names-to-number map for non-terminals.+  , _grmNTDefs :: IntMap (NTDef' x r t) -- ^ Definitions of non-terminals.+  }++emptyGrammar :: Grammar' x r t+emptyGrammar = Grammar 0 Map.empty IntMap.empty++-- | A nonterminal is defined by a list of alternatives.++data NTDef' x r t = NTDef { _ntName :: x, _ntDef :: [Alt' x r t] }++-- | Each alternative is a rule name plus a sentential form.++data Alt' x r t = Alt r (Form' x t)+  deriving (Eq, Ord, Show)++-- | A sentential form is a string of symbols.++newtype Form' x t = Form { theForm :: [Symbol' x t] }+  deriving (Eq, Ord, Show)++-- | A symbol is a terminal or a non-terminal.++data Symbol' x t+  = Term t+  | NonTerm (NT' x)+  deriving (Eq, Ord, Show)++-- | Non-terminals are natural numbers.+--   We store the original name for printing purposes.+--+data NT' x = NT { ntNum :: NTId, ntNam :: x }+  deriving (Show)++instance Eq  (NT' x) where (==)    = (==)    `on` ntNum+instance Ord (NT' x) where compare = compare `on` ntNum++type NTId = Int++-- Lenses+makeLenses ''Grammar'+makeLenses ''NTDef'++-- | Disregarding 'NTName', we can join non-terminal definitions.++instance (Show x, Eq x) => Semigroup (NTDef' x r t) where+  NTDef x alts <> NTDef x' alts'+    | x == x'   = NTDef x $ alts ++ alts'+    | otherwise = error $ unwords $+       [ "non-terminal names do not match:" ] ++ map show [x, x']++-- ** Converting 'NTId' back to name.++-- | Decoration of something with a NT printing dictionary.++data WithNTNames x a = WithNTNames+  { _wntNames :: IntMap x               -- ^ Number-to-names map for non-terminals.+  , _wntThing :: a                      -- ^ The decorated thing.+  }++makeLenses ''WithNTNames++class GetNTNames x a where+  getNTNames :: a -> IntMap x++instance GetNTNames x (WithNTNames x a) where+  getNTNames = (^. wntNames)++instance GetNTNames x (Grammar' x r t) where+  getNTNames g = (^. ntName) <$> g ^. grmNTDefs+++-- * Generic grammar folds.++-- The class-based approach did not go well with Haskell's+-- instance inference.+--+-- class GrmAlg t a where+--   gaTerminal :: t -> a        -- ^ Single terminal.+--   gaZero     :: a             -- ^ Empty language.+--   gaPlus     :: a -> a -> a   -- ^ Language union.+--   gaEps      :: a             -- ^ Language of the empty word.+--   gaConcat   :: a -> a -> a   -- ^ Language concatenation.++-- class GrmFold t a b where+--   grmFold :: GrmAlg t a => (NT -> a) -> b -> a++-- | A grammar algebra provides an implementation for+--   the operations constituting CFGs.++data GrmAlg r t a = GrmAlg+  { gaTerminal :: t -> a        -- ^ Single terminal.+  , gaZero     :: a             -- ^ Empty language.+  , gaPlus     :: a -> a -> a   -- ^ Language union.+  , gaEps      :: a             -- ^ Language of the empty word.+  , gaConcat   :: a -> a -> a   -- ^ Language concatenation.+  , gaLabel    :: r -> a -> a   -- ^ Labelled language.+  }++-- | @n@-ary concatenation, with a special case for empty concatenation.+gaProduct :: GrmAlg r t a -> [a] -> a+gaProduct ga [] = gaEps ga+gaProduct ga as = foldl1 (gaConcat ga) as++-- | @n@-ary alternative, with a special case for empty language.+gaSum :: GrmAlg r t a -> [a] -> a+gaSum ga [] = gaZero ga+gaSum ga as = foldl1 (gaPlus ga) as++-- | Generic fold over a grammar.++class GrmFold r t a b where+  grmFold :: GrmAlg r t a -> (NTId -> a) -> b -> a++instance GrmFold r t a (NT' x) where+  grmFold ga env x = env $ ntNum x++instance GrmFold r t a (Symbol' r' t) where+  grmFold ga env = \case+    Term t    -> gaTerminal ga t+    NonTerm x -> env $ ntNum x++instance GrmFold r t a (Form' r' t) where+  grmFold ga env (Form alpha) = gaProduct ga $ map (grmFold ga env) alpha++instance GrmFold r t a (Alt' x r t) where+  grmFold ga env (Alt r alpha) = gaLabel ga r (grmFold ga env alpha)++instance GrmFold r t a (NTDef' x r t) where+  grmFold ga env (NTDef _x alts) = gaSum ga $ map (grmFold ga env) alts+++-- | Computing properties of non-terminals by saturation.+--   The iteration is needed to handle the recursion inherent in CFGs.+--   Requires a bounded lattice @a@.++grmIterate :: forall r t a x . (Eq a, Ord a)+  => GrmAlg r t a   -- ^ Grammar algebra.+  -> Grammar' x r t -- ^ Grammar.+  -> a              -- ^ Default/start value.+  -> Maybe a        -- ^ Best value (if it exists).+  -> IntMap a       -- ^ Final value for each non-terminal.+grmIterate ga grm@(Grammar n dict defs) bot mtop+  = IntMap.map fst+  $ saturate (\ gs -> IntMap.traverseWithKey (step gs) gs)+  $ IntMap.map (bot,) defs+  where+  step :: IntMap (a, NTDef' x r t)+       -> NTId+       -> (a, NTDef' x r t)+       -> Change (a, NTDef' x r t)+  step gs i d@(a, def)+    | Just a /= mtop, let a' = grmFold ga env def, a' > a = do+      dirty  -- change!+      return (a', def)+    | otherwise = return d  -- no change+    where+    env j = fst $ IntMap.findWithDefault (error "grmIterate") j gs++-- * Guardedness.++newtype Guarded = Guarded { getGuarded :: Bool }+  deriving (Eq, Ord, Show, Bounded) -- False < True++guardedAlg :: GrmAlg r t Guarded+guardedAlg = GrmAlg+  { gaTerminal = const maxBound  -- Yes. A terminal is guarded.+  , gaZero     = maxBound  -- Yes.  (A bit arbitrary, but consistent with gaPlus.)+  , gaPlus     = min       -- All alternatives need to be guarded.+  , gaEps      = maxBound  -- Empty language is guarded!  (Outlier!)+  , gaConcat   = max       -- One factor needs to be guarded.+  , gaLabel    = const id  -- Labels do not change the game.+  }++computeGuardedness :: Grammar' x r t -> IntMap Guarded+computeGuardedness grm = grmIterate guardedAlg grm minBound (Just maxBound)++-- * Nullability.++newtype Nullable = Nullable { getNullable :: Bool }+  deriving (Eq, Ord, Show, Bounded) -- False < True++nullableAlg :: GrmAlg r t Nullable+nullableAlg = GrmAlg+  { gaTerminal = const minBound  -- No. A terminal is not nullable.+  , gaZero     = minBound  -- No.+  , gaPlus     = max       -- One alternative suffices.+  , gaEps      = maxBound  -- Yes. Empty language is exactly nullable.+  , gaConcat   = min       -- All factor must be nullable.+  , gaLabel    = const id  -- Labels do not change the game.+  }++computeNullable :: Grammar' x r t -> IntMap Nullable+computeNullable grm = grmIterate nullableAlg grm minBound (Just maxBound)+++-- * First sets++newtype First t = First { getFirst :: SetMaybe t }+  deriving (Eq, Ord, Show)++-- | Rules to compute first sets.+--+--   FIRST(a)   = {a}+--   FIRST(ε)   = {ε}+--   FIRST(αβ)  = FIRST(α) ∪ (NULLABLE(α) ⇒ FIRST(β))+--   FIRST(α+β) = FIRST(α) ∪ FIRST(β)++firstAlg :: Ord t => GrmAlg r t (First t)+firstAlg = GrmAlg+  { gaTerminal = First . SetMaybe.singleton . Just+  , gaEps      = First $ SetMaybe.singleton Nothing+  , gaZero     = First $ SetMaybe.empty+  , gaPlus     = \ (First s) (First s') -> First $ SetMaybe.union s s'+  , gaConcat   = concatFirst+  , gaLabel    = const id+  }++-- | Empty FIRST set.++emptyFirst :: First t+emptyFirst = First $ SetMaybe.empty++-- |  FIRST(αβ)  = FIRST(α) ∪ (NULLABLE(α) ⇒ FIRST(β)).++concatFirst :: Ord t => First t -> First t -> First t+concatFirst (First s) (First s')+  | SetMaybe.member Nothing s = First $ SetMaybe.union s s'+  | otherwise                 = First s++-- | FIRST sets for all non-terminals.++type FirstSets t = IntMap (First t)++-- | Compute FIRST sets for all non-terminals.++computeFirst :: Ord t => Grammar' x r t -> FirstSets t+computeFirst grm = grmIterate firstAlg grm emptyFirst Nothing++-- Ambiguous: r+-- firstSet :: (GrmFold r t (First t) b, Ord t) => FirstSets t -> b -> First t+firstSet :: (Ord t) => FirstSets t -> Form' r t -> First t+firstSet fs = grmFold firstAlg (\ x -> IntMap.findWithDefault err x fs)+  where+  err = error $ "CFG.firstSet: undefined nonterminal"+++-- | Enriched grammar.++data EGrammar' x r t = EGrammar+  { _eGrm   :: Grammar' x r t   -- ^ CFG.+  , _eStart :: NT' x            -- ^ Start symbol.+  , _eFirst :: FirstSets t      -- ^ Precomputed FIRST sets.+  }+makeLenses ''EGrammar'++makeEGrammar :: Ord t => Grammar' x r t -> NT' x -> EGrammar' x r t+makeEGrammar grm start = EGrammar grm start $ computeFirst grm++instance GetNTNames x (EGrammar' x r t) where+  getNTNames = getNTNames . _eGrm
+ src/CharacterTokenGrammar.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- {-# LANGUAGE TemplateHaskell #-}++-- {-# OPTIONS_GHC -Wunused-imports #-}++-- | Abstract syntax instance for grammars with single-character tokens.++module CharacterTokenGrammar where++import Control.Monad+import Control.Monad.Except+import Control.Monad.State++import qualified Data.List as List+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map++import Data.Maybe+import Data.Semigroup ((<>))++-- uses microlens-platform+import Lens.Micro+import Lens.Micro.Extras (view)++import qualified LBNF.Abs as A+import LBNF.Print (printTree)++import CFG+import DebugPrint++-- | Grammar over single-character terminals with identifiers as rule names.++type Term     = Char+type NTName   = A.Ident+type RuleName = A.Ident+type Grammar  = Grammar' NTName RuleName Term+type NT       = NT' NTName+type NTDef    = NTDef' NTName RuleName Term+type Form     = Form' Term++-- | Intermediate rule format.+type IRule = (NT, RuleName, [A.Entry])++type Error = Either String++-- | Convert grammar to internal format; check for single-character terminals.+--   Also return start non-terminal if the grammar has any rules+checkGrammar :: A.Grammar -> Error (Maybe NT, Grammar)+checkGrammar (A.Rules rs) = (`runStateT` emptyGrammar) $ do+  irs <- mapM addNT rs+  mapM_ addRule irs+  -- The start symbol is the lhs of the first rule+  return $ listToMaybe $ map (\ (x, _, _) -> x) irs+  where+  -- Pass 1: collect non-terminals from lhss of rules.+  addNT :: A.Rule -> StateT Grammar Error IRule+  addNT (A.Prod r x es) = StateT $ \ grm@(Grammar n dict defs) -> do+    -- Check if we have seen NT x before.+    case Map.lookup x dict of+      -- Yes, use its number.+      Just i  -> return ((NT i x, r, es), grm)+      -- No, insert a new entry into the dictionary.+      Nothing -> return ((NT n x, r, es), Grammar (n+1) (Map.insert x n dict) defs)++  -- Pass 2: scope-check and convert rhss of rules.+  addRule :: IRule -> StateT Grammar Error ()+  addRule (NT i x, r, es) = StateT $ \ grm -> do+    alt <- Alt r . Form <$> do+     forM es $ \case+      -- Current limitation: Since we have no lexer, terminals are characters.+      A.Term [a] -> return $ Term a+      A.Term _   -> throwError "terminals must be single-character strings"+      -- Convert non-terminal names into de Bruijn indices (numbers).+      A.NT y -> case Map.lookup y $ view grmNTDict grm of+        Nothing -> throwError $ "undefined non-terminal " ++ printTree y+        Just j  -> return $ NonTerm $ NT j y+    return ((), over grmNTDefs (IntMap.insertWith (<>) i (NTDef x [alt])) grm)++-- | Turn grammar back to original format.++reifyGrammar :: Grammar -> A.Grammar+reifyGrammar grm@(Grammar _ dict defs) =+  A.Rules . (`concatMap` IntMap.toList defs) $ \ (i, NTDef x alts) ->+    (`map` alts) $ \ (Alt r (Form alpha)) ->+      A.Prod r x . (`map` alpha) $ \case+        Term a    -> A.Term [a]+        NonTerm j -> A.NT $ ntToIdent grm j++ntToIdent :: Grammar -> NT -> NTName+ntToIdent grm (NT i x) = x+-- -- Lookup in Grammar no longer needed as NT's carry their name.+-- ntToIdent grm (NT i x) =+--   view ntName $+--     IntMap.findWithDefault (error "printGrammar: impossible") i $+--       view grmNTDefs grm++-- * Printing++instance DebugPrint (A.Ident) where+  debugPrint (A.Ident s) = s++instance DebugPrint Term where+  debugPrint = show+  -- debugPrint = (:[])
+ src/DebugPrint.hs view
@@ -0,0 +1,4 @@+module DebugPrint where++class DebugPrint a where+  debugPrint :: a -> String
+ src/LBNF.cf view
@@ -0,0 +1,24 @@+-- A grammar for LBNF (labelled Backus-Naur-Form)++-- A grammar is a list of rules terminated by semicolon.++Rules.  Grammar ::= [Rule] ;++terminator Rule ";" ;++-- A rule consists of a rule name, a non terminal, and a rhs+-- which is a sentential form composed of entries.++Prod.   Rule ::= Ident "." Ident "::=" [Entry] ;++separator Entry "";++-- An entry is either a terminal or a non terminal.++Term.   Entry ::= String ;  -- A terminal is a string literal+NT.     Entry ::= Ident  ;  -- A non-terminal is an identifier++-- Haskell-style comments.++comment "--" ;+comment "{-" "-}" ;
+ src/LR.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | LR-parser.++module LR where++import Data.Version                 ( showVersion )++import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)++import qualified LBNF.Abs as A+import LBNF.Par (pGrammar, myLexer)+import LBNF.Print (printTree)++import DebugPrint+import Util++import CFG+import CharacterTokenGrammar+import ParseTable+import ParseTable.Pretty++import License+import qualified Paths_LR_demo as Self ( version )++-- | Main: read file passed by only command line argument and call 'run'.++main :: IO ()+main = do+  getArgs >>= \case+    ["-h"]                -> usage+    ["--help"]            -> usage+    ["-V"]                -> version+    ["--version"]         -> version+    ["--numeric-version"] -> numericVersion+    ["--license"]         -> printLicense+    ["--licence"]         -> printLicense+    ['-':_]               -> usage+    [file]                -> run =<< readFile file+    _                     -> usage+  where+    ver = showVersion Self.version+    versionLine = unwords [ "lr-demo version", ver, "(C) 2019-25 Andreas Abel" ]+    usage = do+      putStr $ unlines+        [ versionLine+        , "Call patterns:"+        , "  -h | --help        Print this help text."+        , "  -V | --version     Print version info."+        , "  --numeric-version  Print just the version number."+        , "  --license          Print the license text."+        , "  FILE               Parses stdin with the LBNF grammar given in FILE."+        ]+      exitFailure+    version = do+      putStr $ unlines+        [ versionLine+        , "Developed for the course Programming Language Technology;"+        , "Chalmers DAT151 / University of Gothenburg DIT231."+        , "License: BSD 3-clause."+        ]+    numericVersion = do+      putStrLn ver+      exitSuccess+    printLicense = do+      putStr license+      exitSuccess++-- | Parse grammar and then use it to parse stdin.++run :: String -> IO ()+run s = do++  -- Parse CFG grammar from file in LBNF syntax+  tree <- runErr (putStrLn "Syntax error in grammar file") $+    pGrammar (myLexer s)++  -- Scope-check grammar and convert into internal format.+  (mstart, grm)  <- runM $ checkGrammar tree++  start <- runM $ case mstart of+    Just start -> Right start+    Nothing    -> Left "grammar is empty!"++  putStrLn $ unlines+    [ "Using the following grammar:"+    , ""+    , printTree $ reifyGrammar grm+    ]++  let newstart = A.Ident "%start"+  let egrm = addNewStart newstart newstart $ makeEGrammar grm start+  let ipt  = ptGen egrm++  putStrLn $ unlines+    [ "Generated parse table:"+    , ""+    , debugPrint $ WithNTNames @A.Ident (getNTNames egrm) ipt+    ]++  let pt   = constructParseTable' ipt++  -- Run the parser.+  putStrLn "Parsing stdin..."+  stdin <- trim <$> getContents+  -- runM $ parseWith pt stdin+  -- putStrLn "Parse successful!"+  putStrLn $ debugPrint $ runLR1Parser pt stdin++type Err = Either String++runM :: Err a -> IO a+runM = runErr $ return ()++runErr :: IO () -> Err a -> IO a+runErr preErr = \case+  Right a -> return a+  Left err -> do+    preErr+    putStrLn $ "Error: " ++ err+    exitFailure
+ src/License.hs view
@@ -0,0 +1,25 @@+-- This file duplicates LICENSE++{-# LANGUAGE QuasiQuotes #-}++module License where++import Data.String.QQ++copyright :: String+copyright = head (lines license)++license :: String+license = [s|+Copyright (C) 2019-24 Andreas Abel++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.+|]
+ src/ParseTable.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TemplateHaskell #-}++-- | LR-parser.++module ParseTable where++import Control.Monad+import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Trans.Maybe++import qualified Data.Foldable as Fold+import qualified Data.List as List+import qualified Data.List.NonEmpty as List1+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++import Data.Bifunctor (first, second)+import Data.Function (on)+import Data.Maybe (catMaybes, maybeToList, listToMaybe, fromMaybe)+import Data.Either (partitionEithers)+import Data.Semigroup (Semigroup(..))++-- uses microlens-platform+import Lens.Micro+import Lens.Micro.Extras (view)+import Lens.Micro.TH (makeLenses)++import qualified LBNF.Abs as A+import LBNF.Print (Print, printTree)++import SetMaybe (SetMaybe(SetMaybe))+import qualified SetMaybe++import Util+import Saturation+import CFG++-- Shift-reduce parser.++-- | A stack is a sentential form (reversed).++newtype Stack' x t = Stack [Symbol' x t]+  deriving (Eq, Ord, Show)++type Input' t = [t]++-- | The state of a shift-reduce parser consists of a stack and some input.++data SRState' x t = SRState+  { _srStack :: Stack' x t+  , _srInput :: Input' t+  } deriving (Show)+makeLenses ''SRState'++-- | An action of a shift-reduce parser.++data SRAction' x r t+  = Shift                 -- ^ Shift next token onto stack.+  | Reduce (Rule' x r t)  -- ^ Reduce with given rule.+  deriving (Show)++type Action' x r t = Maybe (SRAction' x r t)  -- ^ Nothing means halt.++data Rule' x r t = Rule (NT' x) (Alt' x r t)+  deriving (Eq, Ord, Show)++-- | A trace is a list of pairs of states and actions.++data TraceItem' x r t = TraceItem+  { _trState  :: SRState' x t+  , _trAction :: Action' x r t+  } deriving (Show)++type Trace' x r t = [TraceItem' x r t]++-- | The next action is decided by a control function.++type Control' x r t m = SRState' x t -> MaybeT m (SRAction' x r t)++-- | Run a shift-reduce parser given by control function on some input,+--   Returning a trace of states and actions.++runShiftReduceParser :: (Eq t, Monad m)+  => Control' x r t m+  -> Input' t+  -> m (Trace' x r t)+runShiftReduceParser nextAction input = loop $ SRState (Stack []) input+  where+  loop st@(SRState (Stack stk) ts0) = do+    act <- runMaybeT $ nextAction st+    (TraceItem st act :) <$> do+      case (act, ts0) of+        (Nothing   , _   ) -> halt+        (Just Shift, t:ts) -> loop $ SRState (Stack $ Term t : stk) ts+        (Just (Reduce (Rule x (Alt r alpha))), _)+          | Just stk' <- matchStack stk alpha+                           -> loop $ SRState (Stack $ NonTerm x : stk') ts0+        _ -> error "runShiftReduceParser: reduce failed"++  matchStack stk (Form alpha) = List.stripPrefix (reverse alpha) stk+  halt = return []+++-- | A parse table maps pairs of states and symbols to actions.+--+--   Non-terminal 'Nothing' is the end of file.+--   For non-terminals, either a shift or a reduce action is returned.+--   For terminals, a goto action (next state) is returned.+--   If 'Nothing' is returned, the parser halts.++data ParseTable' x r t s = ParseTable+  { _tabSR   :: s -> Maybe t -> Maybe (Either s (Rule' x r t))  -- ^ S/R-action on terminals.+  , _tabGoto :: s -> NT' x   -> Maybe s                         -- ^ Goto-action on reduction result.+  , _tabInit :: s+  }+makeLenses ''ParseTable'++-- | A LR control stack is a non-empty list of states.+--   The bottom element is the initial state.++type LRStack' s = List1.NonEmpty s++-- | The LR control function modifies a control stack.+--   It interprets the parse table.++lr1Control :: ParseTable' x r t s -> Control' x r t (State (LRStack' s))+lr1Control (ParseTable tabSR tabGoto _) (SRState stk input) = do+  -- Get control stack+  ss <- get+  -- Query table on maybe top state and maybe first input token.+  (MaybeT $ return $ tabSR (List1.head ss) (listToMaybe input)) >>= \case+    -- Shift action:+    Left s -> do+      -- Put new state on top of stack+      modify $ List1.cons s+      return Shift+    -- Reduce action:+    Right rule@(Rule x (Alt _ (Form alpha))) -> do+      -- Pop |alpha| many states+      let n = length alpha+      let (ss1, rest) = List1.splitAt n ss+      -- Rest should be non-empty, otherwise internal error.+      let err = error $ "lr1Control: control stack too short to reduce"+      let ss2 = fromMaybe err $ List1.nonEmpty rest+      -- Execute the goto action (if present)+      s <- MaybeT $ return $ tabGoto (List1.head ss2) x+      put (List1.cons s ss2)+      return $ Reduce rule++-- | Run the LR(1) parser with the given parsetable.++runLR1Parser :: (Eq t) => ParseTable' x r t s -> Input' t -> Trace' x r t+runLR1Parser pt@(ParseTable _ _ s0) input =+  runShiftReduceParser control input `evalState` st+  where+  control = lr1Control pt+  st = s0 List1.:| []  -- List1.singleton only available from base-4.15 (GHC 9.0)++-- * LR(1) parsetable generation.++-- | A parse item is a dotted rule X → α.β.++data ParseItem' x r t = ParseItem+  { _piRule   :: Rule' x r t    -- ^ The rule this item comes from.+  , _piRest   :: [Symbol' x t]  -- ^ The rest after the ".".+  }+  deriving (Eq, Ord, Show)+makeLenses ''ParseItem'++type Lookahead t = SetMaybe t  -- ^ The set of lookahead symbols.++-- | A parse state is a map of parse items to lookahead lists.++newtype ParseState' x r t = ParseState { theParseState :: Map (ParseItem' x r t) (Lookahead t) }+  deriving (Eq, Ord, Show)++instance (Ord r, Ord t) => Semigroup (ParseState' x r t) where+  ParseState is <> ParseState is' = ParseState $ Map.unionWith SetMaybe.union is is'++instance (Ord r, Ord t) => Monoid (ParseState' x r t) where+  mempty = ParseState $ Map.empty+  mappend = (<>)++-- | Completing a parse state.+--+--   For each (X → α.Yβ, ts), add (Y → .γ, FIRST(β)∘ts)).+--   This might add a whole new item or just extend the token list.++complete :: (Ord r, Ord t)+  => EGrammar' x r t+  -> ParseState' x r t+  -> ParseState' x r t+complete = saturate . completeStep++completeStep :: forall x r t. (Ord r, Ord t)+  => EGrammar' x r t+  -> ParseState' x r t+  -> Change (ParseState' x r t)+completeStep (EGrammar (Grammar _ _ ntDefs) _ fs) (ParseState is) =+    mapM_ add+      [ (ParseItem (Rule y alt) gamma, la')+      | (ParseItem _ (NonTerm y : beta), la) <- Map.toList is+      , NTDef _ alts                         <- maybeToList $ IntMap.lookup (ntNum y) ntDefs+      , alt@(Alt _ (Form gamma))             <- alts+      , let la' = getFirst $ concatFirst (firstSet fs $ Form beta) $ First la+      ]+      `execStateT` ParseState is+  where+    -- Add a parse item candidate.+    add :: (ParseItem' x r t, Lookahead t) -> StateT (ParseState' x r t) Change ()+    add (k, new) = do+      ParseState st <- get+      let (mv, st') = Map.insertLookupWithKey (\ _ -> SetMaybe.union) k new st+      put $ ParseState st'+      -- Detect change:+      case mv of+        -- Item is new?+        Nothing -> lift dirty+        -- Item is old, maybe lookahead is new?+        Just old -> unless (SetMaybe.isSubsetOf new old) $ lift dirty+++-- | Goto action for a parse state.++successors :: (Ord r, Ord t) => EGrammar' x r t -> ParseState' x r t -> Map (Symbol' x t) (ParseState' x r t)+successors grm (ParseState is) = complete grm <$> Map.fromListWith (<>)+  [ (sy, ParseState $ Map.singleton (ParseItem r alpha) la)+  | (ParseItem r (sy : alpha), la) <- Map.toList is+  ]++-- * ParseState dictionary++type PState = Int++initPState = 0++-- | LALR: LR0 automaton decorated with lookahead.+--   The @LR0State@ is the @keysSet@ of a @ParseState@.++type LR0State' x r t = Set (ParseItem' x r t)++lr0state :: ParseState' x r t -> LR0State' x r t+lr0state (ParseState is) = Map.keysSet is++-- | The dictionary maps LR0 states to state numbers and their best decoration.+type PSDict' x r t = Map (LR0State' x r t) (PState, ParseState' x r t)++-- | Internal parse table.++data IPT' x r t = IPT+  { _iptSR   :: IntMap (ISRActions' x r t)  -- ^ Map from states to shift-reduce actions.+  , _iptGoto :: IntMap IGotoActions         -- ^ Map from states to goto actions.+  }+  deriving (Show)++-- | Goto actions of a state.+--   Mapping non-terminals to successor states.++type IGotoActions = IntMap PState++-- | Shift-reduce actions of a state.++data ISRActions' x r t = ISRActions+  { _iactEof  :: ISRAction' x r t+  , _iactTerm :: Map t (ISRAction' x r t)+  }+  deriving (Eq, Ord, Show)++instance (Ord r, Ord t) => Semigroup (ISRActions' x r t) where+  ISRActions aeof atok <> ISRActions aeof' atok' =+    ISRActions (aeof <> aeof') (Map.unionWith (<>) atok atok')++instance (Ord r, Ord t) => Monoid (ISRActions' x r t) where+  mempty = ISRActions mempty Map.empty+  mappend = (<>)++shiftActions :: (Ord r, Ord t) => Map t (ISRAction' x r t) -> ISRActions' x r t+shiftActions = ISRActions mempty++-- | Entry of a parse table cell: shift and/or reduce action(s).++data ISRAction' x r t = ISRAction+  { _iactShift  :: Maybe PState     -- ^ Possibly a shift action.+  , _iactReduce :: Set (Rule' x r t)  -- ^ Possibly several reduce actions.+  }+  deriving (Eq, Ord, Show)++instance (Ord r, Ord t) => Semigroup (ISRAction' x r t) where+  -- ISRAction Just{} _ <> ISRAction Just{} _ = error $ "impossible: union of shift actions"+  ISRAction ms1   r1 <> ISRAction ms2   r2 = ISRAction ms r+    where+    ms = listToMaybe $ maybeToList ms1 ++ maybeToList ms2+    r  = Set.union r1 r2++instance (Ord r, Ord t) => Monoid (ISRAction' x r t) where+  mempty = emptyAction+  mappend = (<>)++emptyAction :: ISRAction' x r t+emptyAction = ISRAction Nothing Set.empty++shiftAction :: PState -> ISRAction' x r t+shiftAction s = ISRAction (Just s) Set.empty++reduceAction :: Rule' x r t -> ISRAction' x r t+reduceAction rule = ISRAction Nothing $ Set.singleton rule++-- | Compute the reduce actions for a parse state.++reductions :: (Ord r, Ord t) => ParseState' x r t -> ISRActions' x r t+reductions (ParseState is) = mconcat+    [ ISRActions (if eof then ra else emptyAction) (Map.fromSet (const ra) ts)+    | (ParseItem r [], SetMaybe ts eof) <- Map.toList is+    , let ra = reduceAction r+    ]++-- | Parse table generator state++data PTGenState' x r t = PTGenState+  { _stNext   :: Int              -- ^ Next unused state number.+  , _stPSDict :: PSDict' x r t    -- ^ Translation from states to state numbers.+  , _stIPT    :: IPT' x r t       -- ^ Internal parse table.+  }+makeLenses ''ISRAction'+makeLenses ''ISRActions'+makeLenses ''IPT'+makeLenses ''PTGenState'++ptState0 :: (Ord r, Ord t) => EGrammar' x r t -> ParseState' x r t+ptState0 grm@(EGrammar (Grammar _ _ ntDefs) start _fs) =+  -- complete grm $+    ParseState $ Map.fromList items0+  where+    laEOF  = SetMaybe.singleton Nothing+    alts0  = maybe [] (view ntDef) $ IntMap.lookup (ntNum start) ntDefs+    items0 = flip map alts0 $ \ alt@(Alt r (Form alpha)) ->+      (ParseItem (Rule start alt) alpha, laEOF)++ptGen :: forall x r t. (Ord r, Ord t) => EGrammar' x r t -> IPT' x r t+ptGen grm@(EGrammar (Grammar _ _ ntDefs) start fs) =+  view stIPT $ loop [state0] `execState` stInit+  where+  stInit :: PTGenState' x r t+  stInit = PTGenState 1 (Map.singleton (lr0state state0) (0, state0)) $+             IPT IntMap.empty IntMap.empty+             -- IPT (IntMap.singleton 0 $ reductions state0)+             --     (IntMap.singleton 0 $ IntMap.empty)  -- initially no goto actions++  -- The first state contains the productions for the start non-terminal.+  state0 :: ParseState' x r t+  state0 = complete grm $ ParseState $ Map.fromList items0+    where+    laEOF  = SetMaybe.singleton Nothing+    alts0  = maybe [] (view ntDef) $ IntMap.lookup (ntNum start) ntDefs+    items0 = flip map alts0 $ \ alt@(Alt r (Form alpha)) ->+      (ParseItem (Rule start alt) alpha, laEOF)++  -- Work off worklist of registered by not processed parse states.+  loop :: [ParseState' x r t] -> State (PTGenState' x r t) ()+  loop [] = return ()+  loop (is : worklist) = do+    let k = lr0state is  -- the LR0State of is+    (Map.lookup k <$> use stPSDict) >>= \case+      Nothing -> error "impossible: parse state without number"+      Just (snew, is0)  -> do+        -- Lookaheads are already updated by convert.+        -- -- Update the lookaheads+        -- is <- do+        --   let is2 = is <> is0+        --   if is2 == is0 then return is0 else do+        --     modifying stPSDict $ Map.insert k (snew, is2)+        --     return is2+        -- Compute successors of snew.+        let sucs = Map.toList $ successors grm is+        -- Register the successors (if not known yet).+        (news, sucs') <- List.unzip <$> mapM convert sucs+        -- Compute goto actions for state snew.+        let fromSymbol (Term    t, a) = Left  (t, a)+            fromSymbol (NonTerm x, a) = Right (ntNum x, a)+        let (shifts0, gotos0) = partitionEithers $ map fromSymbol sucs'+        -- Equip the state snew with its goto actions.+        unless (null gotos0) $ do+          let gotos   = IntMap.fromList gotos0+          modifying (stIPT . iptGoto) $ IntMap.insertWith IntMap.union snew gotos+        -- Compute shift and reduce actions of snew.+        let shifts  = Map.fromList $ map (\ (t,s) -> (t, shiftAction s)) shifts0+        let reduces = reductions is+        let actions = (shiftActions shifts <> reduces)+        unless (actions == mempty) $ do+        -- Equip the state snew with its shift/reduce actions.+          modifying (stIPT . iptSR) $ IntMap.insertWith (<>) snew actions+        -- Add the new states to the worklist and continue+        loop $ catMaybes news ++ worklist++  -- Register a parse state and decide whether we have to process it.+  convert :: (a, ParseState' x r t) -> State (PTGenState' x r t) (Maybe (ParseState' x r t), (a, PState))+  convert (a, is) = do+    let k = lr0state is+    snew <- use stNext+    (Map.lookup k <$> use stPSDict) >>= \case+      -- Parse state has already been visited.  However, lookahead info might need update.+      Just (s, is0) -> do+        -- Combine old an new lookahead info.+        let is' = is <> is0+        if is' == is0 then return (Nothing, (a, s)) else do+          -- If something changed, update the lookahead info.+          -- Also, we will need to process this state again.+          modifying stPSDict $ Map.insert k (s, is')+          return (Just is', (a, s))+      -- New parse state.+      Nothing -> do+        -- Increase parse state counter.+        modifying stNext succ+        -- Save updated dictionary.+        modifying stPSDict $ Map.insert k (snew, is) -- (const dict')+        return (Just is, (a, snew))++-- | Shift over reduce.+--   First reduce action out of several ones.++chooseAction :: ISRAction' x r t -> Maybe (Either PState (Rule' x r t))+chooseAction (ISRAction (Just s) rs) = Just (Left s)+chooseAction (ISRAction Nothing  rs) = Right <$> Set.lookupMin rs++-- | Construct the extensional parse table.+constructParseTable' :: forall x r t. (Ord r, Ord t) => IPT' x r t -> ParseTable' x r t PState+constructParseTable' (IPT sr goto) = ParseTable tabSR tabGoto tabInit+  where+  tabSR s Nothing  = chooseAction =<< do view iactEof <$> IntMap.lookup s sr+  tabSR s (Just t) = chooseAction =<< Map.lookup t =<< do view iactTerm <$> IntMap.lookup s sr+  tabGoto s x = IntMap.lookup (ntNum x) =<< IntMap.lookup s goto+  tabInit = 0++-- | Construct the extensional parse table.+constructParseTable :: forall x r t. (Ord r, Ord t) => EGrammar' x r t -> ParseTable' x r t PState+constructParseTable = constructParseTable' . ptGen++-- | Add rule @%start -> S@ for new start symbol.+addNewStart :: forall x r t. x -> r -> EGrammar' x r t -> EGrammar' x r t+addNewStart x r (EGrammar grm start fs) = EGrammar (add grm) newstart fs+  where+  add = over grmNTDefs $ IntMap.insert (ntNum newstart) $+          NTDef x $ [Alt r $ Form [NonTerm start]]+  newstart :: NT' x+  newstart = NT (0-1) x
+ src/ParseTable/Pretty.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module ParseTable.Pretty where++import Data.Bifunctor (first, second)+import Data.List (intercalate)+import qualified Data.List as List+import qualified Data.List.NonEmpty as List1+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++-- TODO: tabular printout+-- import Text.PrettyPrint.Boxes++import CFG+import DebugPrint+import ParseTable++instance {-# OVERLAPPABLE #-} (DebugPrint t) => DebugPrint (Input' t) where+  debugPrint ts = unwords $ map debugPrint ts++instance DebugPrint x => DebugPrint (NT' x) where+  debugPrint = debugPrint . ntNam++instance (DebugPrint x, DebugPrint t) => DebugPrint (Symbol' x t) where+  debugPrint (Term t)    = debugPrint t+  debugPrint (NonTerm x) = debugPrint x++instance (DebugPrint x, DebugPrint t) => DebugPrint (Stack' x t) where+  debugPrint (Stack s) = unwords $ map debugPrint $ reverse s++instance (DebugPrint x, DebugPrint t) => DebugPrint (SRState' x t) where+  debugPrint (SRState s inp) = unwords [ debugPrint s, "\t.", debugPrint inp ]++instance (DebugPrint x, DebugPrint r) => DebugPrint (Rule' x r t) where+  debugPrint (Rule x (Alt r alpha)) = debugPrint r++instance (DebugPrint x, DebugPrint r) => DebugPrint (SRAction' x r t) where+  debugPrint Shift      = "shift"+  debugPrint (Reduce r) = unwords [ "reduce with rule", debugPrint r ]++instance (DebugPrint x, DebugPrint r) => DebugPrint (Action' x r t) where+  debugPrint Nothing  = "halt"+  debugPrint (Just a) = debugPrint a++instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (TraceItem' x r t) where+  debugPrint (TraceItem s a) = concat [ debugPrint s, "\t-- ", debugPrint a ]++instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (Trace' x r t) where+  debugPrint tr = unlines $ map debugPrint tr++instance DebugPrint IGotoActions where+  debugPrint gotos = unlines $ map ("\t" ++) $ map row $ IntMap.toList gotos+    where+    row (x, s) = unwords [ "NT", show x, "\tgoto state", show s ]++instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ISRAction' x r t) where+  debugPrint (ISRAction mshift rs) = intercalate ";" $ filter (not . null) $+    [ maybe "" (\ s -> unwords [ "shift to state", show s ]) mshift+    , if null rs then ""+      else unwords [ "reduce with rule", intercalate " or " $ map debugPrint $ Set.toList rs ]+    ]++instance (Ord r, Ord t, DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ISRActions' x r t) where+  debugPrint (ISRActions aeof tmap) = unlines $ map ("\t" ++) $+    (if aeof == mempty then id else (concat [ "eof", "\t", debugPrint aeof ] :)) $+      map (\(t,act) -> concat [ debugPrint t, "\t", debugPrint act ]) (Map.toList tmap)++instance (Ord r, Ord t, DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (IPT' x r t) where+  debugPrint (IPT sr goto) = unlines $ concat $ (`map` srgoto) $ \ (s, ls) ->+      [ unwords [ "State", show s ]+      , ""+      , ls+      ]+    where+    sr'    = map (second debugPrint) $ IntMap.toList sr+    goto'  = map (second debugPrint) $ IntMap.toList goto+    srgoto = IntMap.toList $ IntMap.fromListWith (\ s g -> unlines [s,g]) $ goto' ++ sr'++instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ParseItem' x r t) where+  debugPrint (ParseItem rule beta) = unwords+    [ debugPrint rule+    , "/"+    , debugPrint beta+    ]+instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ParseState' x r t) where+  debugPrint (ParseState m) = unlines $+    map (\ (item, ls) -> unwords [ debugPrint item, debugPrint ls ]) $ Map.toList m++---------------------------------------------------------------------------+-- Pretty printing of NTs using WithNTNames dictionary:++instance (DebugPrint x) => DebugPrint (WithNTNames x IGotoActions) where+  debugPrint (WithNTNames dict gotos) = unlines $ map ("\t" ++) $ map row $ IntMap.toList gotos+    where+    row (i, s) = unwords [ debugPrint (dict IntMap.! i), "\tgoto state", show s ]++instance (Ord r, Ord t, DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (WithNTNames x (IPT' x r t)) where+  debugPrint (WithNTNames dict (IPT sr goto)) = unlines $ concat $ (`map` srgoto) $ \ (s, ls) ->+      [ unwords [ "State", show s ]+      , ""+      , ls+      ]+    where+    sr'    = map (second debugPrint) $ IntMap.toList sr+    goto'  = map (second $ debugPrint . WithNTNames dict) $ IntMap.toList goto+    srgoto = IntMap.toList $ IntMap.fromListWith (\ s g -> unlines [s,g]) $ goto' ++ sr'
+ src/Saturation.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Saturation where++import Control.Monad.Writer (Writer, runWriter, tell)+import Data.Monoid (Any(..))++import DebugPrint++-- Tool box for iteration++type Change = Writer Any++dirty :: Change ()+dirty = tell $ Any True++-- | Iterate until no change.++saturate :: (a -> Change a) -> a -> a+saturate f = loop+  where+  loop x = case runWriter $ f x of+    (y, Any True)  -> loop y+    (y, Any False) -> y++-- | Iterate forever++iterateChange :: (a -> Change a) -> a -> [Change a]+iterateChange f a = iterate (f . fst . runWriter) (dirty >> return a)++-- * Printing++instance DebugPrint a => DebugPrint (Change a) where+  debugPrint w = case runWriter w of+    (a, Any b) -> unwords [ if b then "(dirty)" else "(clean)", debugPrint a ]
+ src/SetMaybe.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Sets of @Maybe a@ values.++module SetMaybe where++import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set++-- uses microlens-platform+import Lens.Micro.TH (makeLenses)++import DebugPrint++-- | A set of @Maybe t@ is stored as a set of @t@+--   plus a flag wether 'Nothing' is in the set.++data SetMaybe t = SetMaybe { _smSet :: Set t, _smNothing :: Bool }+  deriving (Eq, Ord, Show, Read)++makeLenses ''SetMaybe++empty :: SetMaybe t+empty  = SetMaybe Set.empty False++setOfNothing :: SetMaybe t+setOfNothing = SetMaybe Set.empty True++singleton :: Maybe t -> SetMaybe t+singleton Nothing = setOfNothing+singleton (Just k) = SetMaybe (Set.singleton k) False++-- | Union.++union :: Ord t => SetMaybe t -> SetMaybe t -> SetMaybe t+union (SetMaybe s b) (SetMaybe s' b') = SetMaybe (Set.union s s') (b || b')++-- | Query subset.++isSubsetOf :: Ord t => SetMaybe t -> SetMaybe t -> Bool+isSubsetOf (SetMaybe s b) (SetMaybe s' b') = (b' || not b) && Set.isSubsetOf s s'++-- | Query membership.++member :: Ord t => Maybe t -> SetMaybe t -> Bool+member Nothing  (SetMaybe _  b) = b+member (Just k) (SetMaybe ks _) = Set.member k ks++-- * Printing++instance (DebugPrint t) => DebugPrint (SetMaybe t) where+  debugPrint (SetMaybe s b) = concat $ [ "{" ] ++ set ++ [ "}" ]+    where+    set = List.intersperse ", " $ (if b then ("Nothing" :) else id) $ map debugPrint $ Set.toList s
+ src/Util.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE RankNTypes #-}++module Util where++import Control.Monad.State++import Data.Char+import Data.List++import Lens.Micro+import Lens.Micro.Extras++use :: MonadState s m => Lens s s a a -> m a+use l = gets $ view l+  -- eta-expanded for GHC-9.0++modifying :: MonadState s m => Lens s s a a -> (a -> a) -> m ()+modifying l = modify . over l++trim :: String -> String+trim = dropWhileEnd isSpace . dropWhile isSpace