diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,70 +1,2 @@ -0.3.0.7 -> 0.3.0.8 - + export maximumPivots and maximumPivotAtNt -0.3.0.8 -> 0.3.0.9 - + include bit of the input string when showing an error message (without whitespace) - + exporting SepBy2 - + exporting within, parens, braces, brackets, angles, quotes and dquotes - + added character literals to Token type - + exporting <:= - + <<<**> and <**>>> for shortest and longest match, respectively - defined some/many and variants using <**>>> and <<<**> - disambiguation remains very experimental -0.3.0.9 -> 0.3.0.10 - + exporting chooses -0.3.0.10 -> 0.3.0.11 - + parse option for disabling select test (lookahead) - -0.3.0.11 -> 0.4.0.1 - + replaced parser by reduced descriptor GLL (RGLL) - + renamed GLL.Types.Grammar to GLL.Types.Derivations - + renamed GLL.Types.Abstract to GLL.Types.Grammar - + exporting GLL.Types.Grammar, GLL.Types.Derivations, GLL.Combinators.Options, GLL.Combinators.Memoisation, GLL.Flags - -0.4.0.1 -> 0.4.0.2 - + generalised `within` - + different whitespace and comment handling in predefined lexer - + predefined lexer handles (nested) comment-blocks - -0.4.0.2 -> 0.4.0.3 - M added hex, octal and binary representation to integer literals - + added float literals - + exporting `preferably` and `reluctantly` - M renamed `rassoc` to shortest_match - M renamed `lassoc` to longest_match - - removed `assoc` - + version of `chooses` that is left-biased (w.r.t. alternatives) - + generalised arguments of longest_match and shortest_match to IsAltExpr - + exporting `optionalWithDef` - -0.4.0.3 -> 0.4.0.4 - + `chooses` cannot be given an empty list (runtime error) - + updated `base` dependency - -0.4.0.4 -> 0.4.0.5 - + relaxed cabal version constraint - -0.4.0.5 -> 0.4.0.6 - + generalised the definition of `within` combinator with respect to token type - -0.4.0.6 -> 0.4.0.7 - + simplified Ridge's "parsing context" in the semantic phase - -0.4.0.7 -> 0.4.0.8 - + unified usage of input in both parser and combinators, speeding up initialisation of large files - + fixed 'noSelectTest' 'ParseOption' - -0.4.0.8 -> 0.4.0.9 - + reinstated a "binarised version" of the interface - + count number of successes in ParseResult, not just True/False - -0.4.0.9 -> 0.4.0.10 - + build expression grammars from operator tables - -0.4.0.10 -> 0.4.0.11 - + integer literals are now by default considered as natural numbers only, the 'signed_int_lits' flag of 'LexerSettings' can be used to turn on signed integers, restoring the behaviour of previous versions - -0.4.0.11 -> 0.4.0.12 - + export 'grammarOf' - + let 'parse' throw errors by default - + changed priorities of operator tables to doubles - + removed need to specify associativity of prefix operators in operator table +0.4.1.1 +~ updated package and interface of GLL.ParserCombinators to 0.4.1.1 version of `gll` package diff --git a/fungll-combinators.cabal b/fungll-combinators.cabal --- a/fungll-combinators.cabal +++ b/fungll-combinators.cabal @@ -1,17 +1,17 @@ +cabal-version: 3.0 -- Initial haskell-gll.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ -- The name of the package. name: fungll-combinators -version: 0.1.0.1 +version: 0.4.1.1 synopsis: GLL parser with simple combinator interface -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: L. Thomas van Binsbergen maintainer: L. Thomas van Binsbergen category: Compilers build-type: Simple -cabal-version: >=1.22 tested-with: GHC == 8.2.1 copyright: Copyright (C) 2019 L. Thomas van Binsbergen stability: experimental @@ -30,20 +30,21 @@ build-depends : base >=4.3.1.0 && <= 5 , containers >= 0.4 , array - , TypeCompose , pretty , text , regex-applicative >= 0.3 , time >= 1.8 - , gll >= 0.4.0.12 + , gll >= 0.4.1.1 exposed-modules : GLL.ParserCombinators , GLL.Types.BSR , GLL.Types.DataSets + , GLL.Types.Input other-modules : GLL.Combinators.Visit.FUNGLL , GLL.Combinators.Visit.Sem , GLL.Combinators.Visit.Join , GLL.Combinators.Interface + , GLL.Types.TypeCompose ghc-options: -fwarn-incomplete-patterns -fwarn-monomorphism-restriction -fwarn-unused-imports default-language: Haskell2010 default-extensions: TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances diff --git a/src/GLL/Combinators/Interface.hs b/src/GLL/Combinators/Interface.hs --- a/src/GLL/Combinators/Interface.hs +++ b/src/GLL/Combinators/Interface.hs @@ -186,9 +186,11 @@ -- *** Choice (<||>), -- *** Semantic actions - (<$$>), + (<$$>), (<$$$>), -- *** Nonterminal introduction (<:=>),(<::=>),chooses,chooses_prec, + -- *** Difference + (<\\>), -- * Types -- ** Grammar (combinator expression) types BNF, SymbExpr, AltExpr, AltExprs, @@ -211,7 +213,7 @@ -- ** Builtin lexers. default_lexer, -- *** Lexer settings - lexer, LexerSettings(..), emptyLanguage, + lexer, lexerEither, LexerSettings(..), emptyLanguage, -- * Derived combinators mkNt, -- *** Ignoring semantic results @@ -233,6 +235,8 @@ HasAlts(..), IsSymbExpr(..), IsAltExpr(..), -- * Memoisation memo, newMemoTable, memClear, MemoTable, MemoRef, useMemoisation, + -- * Scannerless parsing, using `RawParser`s + RawParser, lexical, ) where import GLL.Combinators.Options @@ -241,21 +245,17 @@ import GLL.Combinators.Visit.Sem import GLL.Combinators.Memoisation import GLL.Combinators.Lexer +import GLL.Types.Input import GLL.Types.Grammar -import GLL.Types.DataSets -import GLL.Types.BSR +import GLL.Types.TypeCompose import GLL.Flags hiding (runOptions) -import GLL.Parseable.Char +import GLL.Parseable.Char () import Control.Monad (when) -import Control.Compose (OO(..)) import Control.Arrow import qualified Data.Array as A -import qualified Data.IntMap as IM import qualified Data.Map as M -import qualified Data.Set as S import Data.Text (pack) -import qualified Data.Text import Data.IORef import Data.Time.Clock import System.IO.Unsafe @@ -286,7 +286,7 @@ start = pack "__Start" parse_res = parser_for start vpa2 arr arr = mkInput input - (_,m) = A.bounds arr + m = inputLength arr in do startTime <- getCurrentTime putStrLn $ "#tokens: " ++ (show m) putStrLn $ "#successes: " ++ (show $ res_successes parse_res) @@ -309,7 +309,7 @@ start = pack "__Start" parse_res = parser_for start vpa2 arr arr = mkInput input - (_,m) = A.bounds arr + m = inputLength arr in unsafePerformIO $ do startTime <- getCurrentTime putStrLn $ "#tokens: " ++ (show m) @@ -415,8 +415,16 @@ -- Form an 'AltExpr' by mapping some semantic action overy the result -- of the second argument. (<$$>) :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b -f <$$> p' = join_apply f p' +f <$$> p' = join_apply ((:[]) . f) p' +infixl 4 <$$$> +-- | +-- Variant of `<$$>` that gives access to the underlying ambiguity representation +-- The semantic action can be used to disambiguate, for example using `guard`. +(<$$$>) :: (Show t, Ord t, IsSymbExpr s, Foldable f) => (a -> f b) -> s t a -> AltExpr t b +f <$$$> p' = join_apply f p' + + infixl 4 <**>,<<<**>,<**>>> -- | -- Add a 'SymbExpr' to the right-hand side represented by an 'AltExpr' @@ -438,6 +446,10 @@ pl' <<<**> pr' = join_seq [minimumPivot] pl' pr' +infixr 5 <\\> +(<\\>) :: (Show t) => SymbExpr t a -> SymbExpr t b -> SymbExpr t a +p <\\> q = p `join_andNot` q + infixr 3 <||> -- | -- Add an 'AltExpr' to a list of 'AltExpr' @@ -465,7 +477,11 @@ -- * The 'Parseable' token represented by the terminal. -- * A function from that 'Parseable' to a semantic result. term_parser :: Parseable t => t -> (t -> a) -> SymbExpr t a -term_parser t f = SymbExpr (Term t, parse_term t,\_ _ _ arr l _ -> return [f (arr A.! l)]) +term_parser t f = SymbExpr (Term t, parse_term t,\_ _ _ inp l _ -> return [f (fst inp A.! l)]) + +-- | Create a symbol given a `RawParser` (see `GLL.Types.Input`) +lexical :: String -> RawParser t -> SymbExpr t [t] +lexical nt regex = join_lexical (pack nt) regex -- | Parse a single character. -- diff --git a/src/GLL/Combinators/Visit/FUNGLL.hs b/src/GLL/Combinators/Visit/FUNGLL.hs --- a/src/GLL/Combinators/Visit/FUNGLL.hs +++ b/src/GLL/Combinators/Visit/FUNGLL.hs @@ -4,15 +4,16 @@ import GLL.Types.Grammar import GLL.Types.BSR import GLL.Types.DataSets +import GLL.Types.Input import qualified Data.IntMap as IM import qualified Data.Map as M import qualified Data.Set as S import qualified Data.IntSet as IS -import qualified Data.Array as A +import Data.Text (pack) type Command t = State t (ContF t) -> State t (ContF t) -data ContF t = ContF (Descr t -> Command t) +data ContF t = ContF (Input t -> Descr t -> Command t) type Parse_Symb t = (Symbol t, Input t -> Slot t -> Int -> Int -> ContF t -> Command t) type Parse_Choice t = Input t -> Nt -> Int -> ContF t -> Command t @@ -20,13 +21,17 @@ type Parse_Alt t = Parse_Seq t parser_for :: (Parseable t) => Nt -> Parse_Symb t -> Input t -> ParseResult t -parser_for x (Term t,p) inp = error "assert: terminal given to parser_for" -parser_for x (Nt s,p) inp = resultFromState inp ( - p inp (Slot x [Nt s] []) 0 0 cont0 emptyState) (s,0,0) - where cont0 = ContF cf - where cf (_,_,r) s | r == snd (A.bounds inp) = s { successes = successes s + 1 } - | otherwise = s +parser_for x p inp = resultFromState inp (run_parse x p inp 0 emptyState) +run_parse :: Nt -> Parse_Symb t -> Input t -> Int -> + State t (ContF t) -> State t (ContF t) +run_parse x p@(y,pf) inp l = pf inp (Slot x [y] []) l l counter_cont + +counter_cont :: ContF t +counter_cont = ContF cf + where cf _ (_,_,r) s = s { successes = IM.alter updater r (successes s) } + where updater = maybe (Just 1) (Just . (1+)) + parse_nterm :: (Ord t) => Nt -> [Parse_Seq t] -> Parse_Symb t parse_nterm n = nterm n . foldl altOp altStart @@ -43,52 +48,105 @@ nterm n p = (Nt n, parser) where parser inp g l k c s | null rs = p inp n k cont_for s' - | otherwise = compAll [ applyCF c (g,l,r) | r <- rs ] s' + | otherwise = compAll [ applyCF c (removePrefix len inp) (g,l,r) + | r <- rs, let len = r - k ] s' where s' = s { grel = addCont (n,k) (g,l,c) (grel s) } rs = extents (n,k) (prel s) cont_for = ContF cf - where cf (_,k,r) s = - compAll [ applyCF c (g,l',r) | (g,l',c) <- conts (n,k) (grel s) ] s' + where cf inp (_,k,r) s = + compAll [ applyCF c inp (g,l',r) + | (g,l',c) <- conts (n,k) (grel s) ] s' where s' = s { prel = addExtent (n,k) r (prel s) } term :: Parseable t => t -> Parse_Symb t -term t = (Term t, parser) - where parser inp g l k c s - | lb <= k, k <= ub, matches (inp A.! k) t = applyCF c (g, l, k+1) s - | otherwise = s - where (lb,ub) = A.bounds inp +term t = (Term t, snd (predicate (pack (show t)) (matches t))) seqStart :: Ord t => Parse_Seq t -seqStart inp x beta l c = continue (Slot x [] beta, l, l, l) c +seqStart inp x beta l c = continue inp (Slot x [] beta, l, l, l) c seqOp :: Ord t => Parse_Seq t -> Parse_Symb t -> Parse_Seq t seqOp p (s,q) inp x beta l c0 = p inp x (s:beta) l c1 where c1 = ContF c1f - where c1f ((Slot _ alpha _),l,k) = q inp (Slot x (alpha++[s]) beta) l k c2 + where c1f inp ((Slot _ alpha _),l,k) = q inp (Slot x (alpha++[s]) beta) l k c2 where c2 = ContF c2f - where c2f (g,l,r) = continue (g,l,k,r) c0 + where c2f inp (g,l,r) = continue inp (g,l,k,r) c0 -continue :: (Ord t) => BSR t -> ContF t -> Command t -continue bsr@(g@(Slot x alpha beta),l,k,r) c s +continue :: (Ord t) => Input t -> BSR t -> ContF t -> Command t +continue inp bsr@(g@(Slot x alpha beta),l,k,r) c s | hasDescr descr (uset s) = s' - | otherwise = applyCF c descr s'' + | otherwise = applyCF c inp descr s'' where descr = (g,l,r) s' | not (null alpha) || null beta = s { bsrs = addBSR bsr (bsrs s) } | otherwise = s - s'' = s' { uset = addDescr descr (uset s') } + s'' = s' { uset = addDescr descr (uset s') } altStart :: Parse_Choice t altStart inp n l c s = s altOp :: Parse_Choice t -> Parse_Seq t -> Parse_Choice t altOp p q inp n l c = p inp n l c . q inp n [] l c +{- MUCH SLOWER ? +altOp p q inp n l c s = + let s1 = p inp n l counter_cont s + s2 = q inp n [] l counter_cont s1 + in compAll [ applyCF c (error "cont_for assert", l, r) + | r <- IS.toList (IS.union (IM.keysSet (successes s1)) + (IM.keysSet (successes s2))) ] s2 +-} compAll :: [Command t] -> Command t compAll = foldr (.) id -applyCF (ContF cf) a = cf a +applyCF (ContF cf) inp a = cf inp a +{- EXTENSIONS -} + +parse_lexical :: Nt -> RawParser t -> Parse_Symb t +parse_lexical n scanner = (Nt n, parser) + where parser inp g l k c s = + compAll [ applyCF c (removePrefix len inp) (g, l, k + len) + | prefix <- apply_scanner scanner inp + , let len = length prefix ] s + +{- EXPERIMENTAL -} + +andNot :: (Show t) => Parse_Symb t -> Parse_Symb t -> Parse_Symb t +andNot (lnt,p) (rnt,q) = (Nt lhs_symb,parser) + where lhs_symb = pack ("__andNot(" ++ show lnt ++","++ show rnt ++ ")") + parser inp g l k c s = compAll [ applyCF c (removePrefix len inp) (g, l, r) + | r <- rs, let len = r - k ] + s2{successes = successes s} + where s1 = run_parse lhs_symb (lnt,p) inp k s{successes = IM.empty} + s2 = run_parse lhs_symb (rnt,q) inp k s1{successes = IM.empty} + rs = IS.toList $ IS.difference (IM.keysSet (successes s1)) + (IM.keysSet (successes s2)) + + +ands :: (Show t) => [Parse_Symb t] -> Parse_Symb t +ands = foldr andOp andStart + +andOp :: (Show t) => Parse_Symb t -> Parse_Symb t -> Parse_Symb t +andOp (lnt,p) (rnt,q) = (Nt lhs_symb,parser) + where lhs_symb = pack ("__and(" ++ show lnt ++","++ show rnt ++ ")") + parser inp g l k c s = compAll [ applyCF c (removePrefix len inp) (g, l, r) + | r <- rs, let len = r - k ] s2 + where s1 = run_parse lhs_symb (lnt,p) inp k s + s2 = run_parse lhs_symb (rnt,q) inp k s1 + rs = IS.toList $ IS.intersection (IM.keysSet (successes s1)) + (IM.keysSet (successes s2)) + +andStart :: Parse_Symb t +andStart = (Nt (pack "__and_unit"), parser) + where parser inp g l k c s = applyCF c inp (g, l, k) s + +predicate :: Parseable t => Nt -> (t -> Bool) -> Parse_Symb t +predicate nt p = (Nt nt, parser) + where parser inp g l k c s = + compAll [ applyCF c (removePrefix len inp) (g, l, k + len) + | prefix <- apply_scanner (scanner_from_predicate p) inp + , let len = length prefix ] s + -- | -- The "ParseResult" datatype contains some information about a parse: -- @@ -97,21 +155,25 @@ -- * The number of BSR elements data ParseResult t = ParseResult{ bsrs_result :: BSRs t , res_success :: Bool - , res_successes :: Int + , res_successes :: IM.IntMap Int , nr_descriptors :: Int , nr_bsrs :: Int , error_message :: String } -resultFromState :: Parseable t => Input t -> State t c -> (Nt, Int, Int) -> ParseResult t -resultFromState inp (State uset _ _ pMap cs) (s, l, m) = +matchedUpTo :: IM.IntMap Int -> Int -> Bool +matchedUpTo res r = maybe False (const True) (IM.lookup r res) + +resultFromState :: Parseable t => Input t -> State t c -> ParseResult t +resultFromState inp (State uset _ _ pMap cs) = let usize = sum [ S.size s | (l, r2s) <- IM.assocs uset , (r,s) <- IM.assocs r2s ] p_nodes = sum [ IS.size ks | (l, r2j) <- IM.assocs pMap , (r, j2s) <- IM.assocs r2j , (j, s2k) <- IM.assocs j2s , (s, ks) <- M.assocs s2k ] - in ParseResult pMap (cs > 0) cs usize p_nodes "no errors to report" + succs = maybe 0 id (IM.lookup (inputLength inp) cs) + in ParseResult pMap (succs > 0) cs usize p_nodes "no errors to report" instance Show (ParseResult t) where show res | res_success res = result_string diff --git a/src/GLL/Combinators/Visit/Join.hs b/src/GLL/Combinators/Visit/Join.hs --- a/src/GLL/Combinators/Visit/Join.hs +++ b/src/GLL/Combinators/Visit/Join.hs @@ -2,13 +2,13 @@ module GLL.Combinators.Visit.Join where -import GLL.Types.BSR import GLL.Types.Grammar +import GLL.Types.Input +import GLL.Types.TypeCompose import GLL.Combinators.Visit.Sem import GLL.Combinators.Visit.FUNGLL import GLL.Combinators.Options -import Control.Compose (OO(..),unOO) import Data.List (intercalate) import Data.Text (pack) @@ -40,7 +40,8 @@ x = pack x' in SymbExpr (Nt x, parse_nterm x vas2, sem_nterm use_ctx left_biased x alts vas3) -join_apply :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b +join_apply :: (Show t, Ord t, IsSymbExpr s, Foldable f) => + (a -> f b) -> s t a -> AltExpr t b join_apply f p' = let SymbExpr (vpa1,vpa2,vpa3) = mkRule p' in AltExpr ([vpa1],parse_apply vpa2, sem_apply f vpa3) @@ -52,6 +53,14 @@ SymbExpr (vpa1,vpa2,vpa3) = mkRule pr' in AltExpr (vimp1++[vpa1], parse_seq vimp2 vpa2, sem_seq local_opts vimp3 vpa3) +join_lexical :: Nt -> RawParser t -> SymbExpr t [t] +join_lexical nt regex = SymbExpr (Nt nt, parse_lexical nt regex, sem_slice regex) + +join_andNot :: (Show t) => SymbExpr t a -> SymbExpr t b -> SymbExpr t a +join_andNot (SymbExpr (_,p_parser,p_sem)) (SymbExpr (_, q_parser, q_sem)) = + SymbExpr (s, parser, p_sem) + where parser@(s, _) = andNot p_parser q_parser + -- | -- Class for lifting to 'SymbExpr'. class IsSymbExpr a where @@ -95,7 +104,7 @@ toAlt = id instance IsAltExpr SymbExpr where - toAlt p = join_apply id p + toAlt p = join_apply (:[]) p instance IsAltExpr AltExprs where toAlt = toAlt . mkRule diff --git a/src/GLL/Combinators/Visit/Sem.hs b/src/GLL/Combinators/Visit/Sem.hs --- a/src/GLL/Combinators/Visit/Sem.hs +++ b/src/GLL/Combinators/Visit/Sem.hs @@ -2,12 +2,12 @@ module GLL.Combinators.Visit.Sem where import GLL.Combinators.Options +import GLL.Types.Input import GLL.Types.Grammar import GLL.Types.BSR import Control.Monad (forM) -import qualified Data.Array as A -import qualified Data.IntMap as IM +import Data.Foldable (toList) import qualified Data.Set as S type Sem_Symb t a = PCOptions -> Ancestors t @@ -16,7 +16,8 @@ -> BSRs t -> Input t -> Int -> Int -> IO [(Int,a)] evaluator_for :: (Ord t) => Nt -> Sem_Symb t a -> PCOptions -> BSRs t -> Input t -> IO [a] -evaluator_for start sem opts bsrs inp = sem opts emptyAncestors bsrs inp 0 (snd (A.bounds inp)) +evaluator_for start sem opts bsrs inp = + sem opts emptyAncestors bsrs inp 0 (inputLength inp) sem_nterm :: Bool -> Bool -> Nt -> [Prod t] -> [Sem_Alt t a] -> Sem_Symb t a sem_nterm use_ctx left_biased x alts ps opts ctx sppf arr l r = @@ -41,11 +42,13 @@ firstRes ([]:ress) = firstRes ress firstRes (res:_) = res -sem_apply :: Ord t => (a -> b) -> Sem_Symb t a -> Sem_Alt t b +sem_apply :: (Foldable f, Ord t) => (a -> f b) -> Sem_Symb t a -> Sem_Alt t b sem_apply f p opts (alt,j) ctx sppf arr l r = let op f a = (r,f a) in do as <- p opts ctx sppf arr l r - return (maybe [] (const (map (op f) as)) $ sppf `pNodeLookup'` ((alt,1),l,r)) + case sppf `pNodeLookup'` ((alt,1),l,r) of + Nothing -> return [] + _ -> return [ (r, res) | a <- as, res <- toList (f a)] sem_seq :: Ord t => CombinatorOptions -> Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b sem_seq local_opts p q opts (alt@(Prod x rhs),j) ctx sppf arr l r = @@ -62,6 +65,9 @@ | otherwise = ctx in do ass <- forM choices seq return (concat ass) + +sem_slice :: RawParser t -> Sem_Symb t [t] +sem_slice regex opts ctx bsr inp l r = return [slice inp l r] --- contexts type Ancestors t = S.Set Nt diff --git a/src/GLL/Types/BSR.hs b/src/GLL/Types/BSR.hs --- a/src/GLL/Types/BSR.hs +++ b/src/GLL/Types/BSR.hs @@ -2,16 +2,12 @@ module GLL.Types.BSR where -import qualified Data.Array as A import qualified Data.Map as M import qualified Data.IntMap as IM -import qualified Data.Set as S import qualified Data.IntSet as IS -import Data.List (elemIndices, findIndices) import GLL.Types.Grammar -type Input t = A.Array Int t -- make sure that tokens are equal independent of their character level value type SlotL t = (Slot t, Int) -- slot with left extent type PrL t = (Prod t, Int) -- Production rule with left extent @@ -62,6 +58,4 @@ | (l,r2j) <- IM.assocs pMap, (r,j2a) <- IM.assocs r2j , (j,a2k) <- IM.assocs j2a, (a,kset) <- M.assocs a2k ] -mkInput :: (Parseable t) => [t] -> Input t -mkInput input = A.listArray (0,m) (input++[eos]) - where m = length input + diff --git a/src/GLL/Types/DataSets.hs b/src/GLL/Types/DataSets.hs --- a/src/GLL/Types/DataSets.hs +++ b/src/GLL/Types/DataSets.hs @@ -12,11 +12,11 @@ type Descr t = (Slot t, Int, Int) type Comm t = (Nt, Int) data Cont t c = Cont (Slot t, Int) c -data State t c = State { uset :: USet t - , grel :: GRel t c - , prel :: PRel t - , bsrs :: BSRs t - , successes :: Int +data State t c = State { uset :: USet t + , grel :: GRel t c + , prel :: PRel t + , bsrs :: BSRs t + , successes :: IM.IntMap Int {- maps index to counter -} } instance (Ord t) => Ord (Cont t c) where @@ -38,7 +38,7 @@ extents :: Comm t -> PRel t -> [Int] emptyState :: (Ord t) => State t c -emptyState = State emptyUSet emptyG emptyP emptyBSRs 0 +emptyState = State emptyUSet emptyG emptyP emptyBSRs IM.empty type RList t = [Descr t] type USet t = IM.IntMap (IM.IntMap (S.Set (Slot t))) @@ -95,5 +95,3 @@ extents (gs,l) = maybe [] inner . IM.lookup l where inner = maybe [] id . M.lookup gs - - diff --git a/src/GLL/Types/Input.hs b/src/GLL/Types/Input.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Types/Input.hs @@ -0,0 +1,32 @@ + +module GLL.Types.Input ( + module GLL.Types.Input) where + +import GLL.Types.Grammar +import qualified Data.Array as A + +type Input t = (A.Array Int t, [t]) +type RawParser t = [t] -> [[t]] -- input to list of prefixes + +mkInput :: (Parseable t) => [t] -> Input t +mkInput input = (A.listArray (0,m) (input++[eos]), input) + where m = length input + +inputLength :: Input t -> Int +inputLength = snd . A.bounds . fst + +scanner_from_predicate :: (t -> Bool) -> RawParser t +scanner_from_predicate p (t:ts) | p t = [[t]] +scanner_from_predicate p _ = [] + +apply_scanner :: RawParser t -> Input t -> [[t]] +apply_scanner scanner (_,str) = scanner str + +slice :: Input t -> Int -> Int -> [t] +slice (arr, str) l r + | lb <= l && r <= ub = map (arr A.!) [l..r-1] + | otherwise = [] + where (lb,ub) = A.bounds arr + +removePrefix :: Int -> Input t -> Input t +removePrefix l (arr, str) = (arr, drop l str) diff --git a/src/GLL/Types/TypeCompose.hs b/src/GLL/Types/TypeCompose.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Types/TypeCompose.hs @@ -0,0 +1,21 @@ + +-- | Definition copied from TypeCompose-0.9.14: https://hackage.haskell.org/package/TypeCompose-0.9.14 +module GLL.Types.TypeCompose where + +import Prelude hiding ((.),id) + +import Control.Arrow (Arrow(..)) +import Control.Category (Category(..)) +import Control.Applicative (liftA, liftA2) + +-- | Composition of type constructors: unary with binary. Called +-- "StaticArrow" in [1]. +newtype OO f j a b = OO { unOO :: f (a `j` b) } + +instance (Applicative f, Category cat) => Category (OO f cat) where + id = OO (pure id) + OO g . OO h = OO (liftA2 (.) g h) + +instance (Applicative f, Arrow arr) => Arrow (OO f arr) where + arr = OO . pure . arr + first (OO g) = OO (liftA first g)