From a2696774f0192d205df43ece4a4ff894ed38a356 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Fri, 21 Sep 2012 23:10:21 -0400 Subject: [PATCH] REPL and parser improvements --- dyna.cabal | 24 ++++-- src/Dyna/ParserHS/Parser.hs | 111 ++++++++++++++++------------ src/Dyna/ParserHS/ParserSelftest.hs | 35 +++++++-- src/Dyna/REPL.hs | 14 ++-- src/Dyna/Test/Main.hs | 13 ++++ src/Dyna/Test/Trifecta.hs | 36 --------- src/Dyna/XXX/Trifecta.hs | 69 ++++++----------- src/Dyna/XXX/TrifectaTest.hs | 31 ++++++++ src/Dyna/XXX/TrifectaTests.hs | 67 +++++++++++++++++ 9 files changed, 253 insertions(+), 147 deletions(-) create mode 100644 src/Dyna/Test/Main.hs delete mode 100644 src/Dyna/Test/Trifecta.hs create mode 100644 src/Dyna/XXX/TrifectaTest.hs create mode 100644 src/Dyna/XXX/TrifectaTests.hs diff --git a/dyna.cabal b/dyna.cabal index 5f824ed..80825ea 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -33,9 +33,10 @@ Library bytestring >=0.9, containers >=0.4, mtl >=2.1, + parsers >=0.3, reducers >=3.0, semigroups >=0.8, - trifecta >=0.53, + trifecta >=0.90, unification-fd, unordered-containers>=0.2, utf8-string >=0.3 @@ -44,39 +45,50 @@ Executable drepl Default-Language: Haskell2010 ghc-options: -Wall + -main-is Dyna.REPL Hs-Source-Dirs: src Build-Depends: base >=4, bytestring >=0.9, containers >=0.4, editline >=0.2, + mtl >=2.1, + parsers >=0.3, reducers >=3.0, semigroups >=0.8, - trifecta >=0.53, + trifecta >=0.90, unordered-containers>=0.2, utf8-string >=0.3 Main-Is: Dyna/REPL.hs -Test-suite dyna-selftest-parser +Test-suite dyna-selftests type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: src + ghc-options: -Wall + -main-is Dyna.Test.Main + Build-Depends: base >=4, bytestring >=0.9, containers >=0.4, HUnit >=1.2, + mtl >=2.1, + parsers >=0.3, reducers >=3.0, semigroups >=0.8, test-framework >=0.6, test-framework-hunit >=0.2, test-framework-th >=0.2, - trifecta >=0.53, + trifecta >=0.90, unordered-containers>=0.2, - utf8-string >=0.3 + utf8-string >=0.3, + wl-pprint-extras >=3.0 + + Other-Modules: Dyna.ParserHS.ParserSelftest - Main-Is: Dyna/ParserHS/ParserSelftest.hs + Main-Is: Dyna/Test/Main.hs ---------------------------------------------------------------- diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 13fe26e..9566a49 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} @@ -6,6 +7,8 @@ -- https://github.com/ekmett/trifecta/blob/master/examples/RFC2616.hs -- as well as the trifecta code itself -- +-- XXX no longer handles comments due to trifecta code upgrade +-- -- TODO: -- We might want to use T.T.Literate, too, in the end. -- Doesn't understand dynabase literals ("{ ... }") @@ -19,59 +22,61 @@ module Dyna.ParserHS.Parser ( ) where import Control.Applicative +import Control.Monad +import Control.Monad.Trans (MonadTrans,lift) import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B import Data.Char (isSpace) import qualified Data.HashSet as H import Data.Semigroup ((<>)) import Data.Monoid (mempty) +import Text.Parser.Expression +import Text.Parser.Token.Highlight +import Text.Parser.Token.Style import Text.Trifecta -import Text.Trifecta.Highlight.Prim -import Text.Trifecta.Parser.Expr -import Text.Trifecta.Parser.Token.Style -import Dyna.XXX.Trifecta (identNL, pureSpanned) +import Dyna.XXX.Trifecta (identNL) data Term = TFunctor {-# UNPACK #-} !B.ByteString ![Spanned Term] | TVar {-# UNPACK #-} !B.ByteString -- | TDBLit XXX deriving (Eq,Ord,Show) -dynaDotOperStyle :: MonadParser m => IdentifierStyle m +dynaDotOperStyle :: TokenParsing m => IdentifierStyle m dynaDotOperStyle = IdentifierStyle { styleName = "Dot Operator" - , styleStart = () <$ char '.' - , styleLetter = () <$ oneOf "!#$%&*+/<=>?@\\^|-~:." + , styleStart = char '.' + , styleLetter = oneOf "!#$%&*+/<=>?@\\^|-~:." , styleReserved = mempty , styleHighlight = Operator , styleReservedHighlight = ReservedOperator } -dynaOperStyle :: MonadParser m => IdentifierStyle m +dynaOperStyle :: TokenParsing m => IdentifierStyle m dynaOperStyle = IdentifierStyle { styleName = "Operator" - , styleStart = () <$ oneOf "!#$%&*+/<=>?@\\^|-~:" - , styleLetter = () <$ oneOf "!#$%&*+/<=>?@\\^|-~:." + , styleStart = oneOf "!#$%&*+/<=>?@\\^|-~:" + , styleLetter = oneOf "!#$%&*+/<=>?@\\^|-~:." , styleReserved = mempty , styleHighlight = Operator , styleReservedHighlight = ReservedOperator } -dynaAtomStyle :: MonadParser m => IdentifierStyle m +dynaAtomStyle :: TokenParsing m => IdentifierStyle m dynaAtomStyle = IdentifierStyle { styleName = "Atom" - , styleStart = () <$ (lower <|> digit <|> char '_') - , styleLetter = () <$ (alphaNum <|> oneOf "_'") + , styleStart = (lower <|> digit <|> char '_') + , styleLetter = (alphaNum <|> oneOf "_'") , styleReserved = H.fromList [ "is", "new", "whenever" ] , styleHighlight = Constant , styleReservedHighlight = ReservedOperator } -dynaVarStyle :: MonadParser m => IdentifierStyle m +dynaVarStyle :: TokenParsing m => IdentifierStyle m dynaVarStyle = IdentifierStyle { styleName = "Variable" - , styleStart = () <$ (upper <|> char '_') - , styleLetter = () <$ (alphaNum <|> oneOf "_'") + , styleStart = (upper <|> char '_') + , styleLetter = (alphaNum <|> oneOf "_'") , styleReserved = mempty , styleHighlight = Identifier , styleReservedHighlight = ReservedIdentifier @@ -85,25 +90,38 @@ dynaCommentStyle = CommentStyle , commentNesting = True } -dynaLanguage :: (MonadParser m) - => LanguageDef m -dynaLanguage = LanguageDef - { languageCommentStyle = dynaCommentStyle - , languageIdentifierStyle = undefined -- dynaAtomStyle (XXX) - , languageOperatorStyle = undefined -- dynaOperStyle (XXX) - } +newtype DynaLanguage m a = DL { unDL :: m a } + deriving (Functor,Applicative,Alternative,Monad,MonadPlus,Parsing,CharParsing) + +instance MonadTrans DynaLanguage where + lift = DL + +instance (TokenParsing m, MonadPlus m) => TokenParsing (DynaLanguage m) where + someSpace = buildSomeSpaceParser (lift someSpace) dynaCommentStyle + semi = lift semi + highlight h (DL m) = DL (highlight h m) -atom :: MonadParser m => m B.ByteString +instance DeltaParsing m => DeltaParsing (DynaLanguage m) where + line = lift line + position = lift position + slicedWith f (DL m) = DL $ slicedWith f m + rend = lift rend + restOfLine = lift restOfLine + + +bsf = fmap BU.fromString + +atom :: (Monad m, TokenParsing m) => m B.ByteString atom = liftA BU.fromString stringLiteral - <|> ident dynaAtomStyle + <|> (bsf $ ident dynaAtomStyle) -- sparen :: MonadParser m => m a -> m a -- sparen = between (char '(' *> spaces) (spaces <* char ')') -term :: MonadParser m => m (Spanned Term) -term = lexeme $ choice +term :: DeltaParsing m => m (Spanned Term) +term = token $ choice [ parens texpr - , spanned $ TVar <$> (ident dynaVarStyle) + , spanned $ TVar <$> (bsf$ident dynaVarStyle) , try $ spanned $ flip TFunctor [] <$> atom <* (notFollowedBy $ char '(') , spanned $ parenfunc ] @@ -112,14 +130,14 @@ term = lexeme $ choice <*> parens (texpr `sepBy` symbolic ',') -- XXX right now all binops are at equal precedence and left-associative; that's wrong. -texpr :: MonadParser m => m (Spanned Term) +texpr :: DeltaParsing m => m (Spanned Term) texpr = buildExpressionParser etable term "Expression" where - etable = [ [ Prefix $ uf (spanned $ symbol "new") ] - , [ Prefix $ uf (spanned $ ident dynaOperStyle) ] - , [ Infix (bf (spanned $ ident dynaOperStyle)) AssocLeft ] - , [ Infix (bf (spanned $ dotOper)) AssocRight ] - , [ Infix (bf (spanned $ symbol "is")) AssocNone ] + etable = [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ] + , [ Prefix $ uf (spanned $ bsf $ ident dynaOperStyle) ] + , [ Infix (bf (spanned $ bsf $ ident dynaOperStyle)) AssocLeft ] + , [ Infix (bf (spanned $ bsf $ dotOper)) AssocRight ] + , [ Infix (bf (spanned $ bsf $ symbol "is")) AssocNone ] ] -- The dot operator is required to have not-a-space following (to avoid @@ -137,12 +155,9 @@ texpr = buildExpressionParser etable term "Expression" hriss = highlight ReservedOperator . spanned . symbol -dynafy :: MonadParser m => Language m a -> m a -dynafy = flip runLanguage dynaLanguage - -dterm, dtexpr :: MonadParser m => m (Spanned Term) -dterm = dynafy term -dtexpr = dynafy texpr +dterm, dtexpr :: DeltaParsing m => m (Spanned Term) +dterm = unDL term +dtexpr = unDL texpr -- | Rules are not just terms because we want to make it very syntactically -- explicit about the head being a term (though that's not an expressivity @@ -162,8 +177,9 @@ data Line = LRule (Spanned Rule) rulepfx = Rule <$> term <* spaces - <*> (ident dynaOperStyle "Aggregator") + <*> (bsf$ident dynaOperStyle "Aggregator") +rule :: DeltaParsing m => m Rule rule = choice [(try (liftA flip rulepfx <*> texpr <* hriss "whenever")) @@ -176,18 +192,19 @@ rule = choice [(try (liftA flip rulepfx , Fact <$> term ] +drule :: DeltaParsing m => m (Spanned Rule) drule = spanned rule -progline :: MonadParser m => m (Spanned Line) +progline :: DeltaParsing m => m (Spanned Line) progline = spanned $ choice [ LRule <$> drule , LPragma <$> (symbol ":-" *> spaces *> texpr) ] -dline :: MonadParser m => m (Spanned Line) --- dline = dynafy (progline <* optional (char '.' <* (spaces <|> eof))) -dline = dynafy (progline <* optional (char '.') <* optional newline) +dline :: DeltaParsing m => m (Spanned Line) +-- dline = unDL (progline <* optional (char '.' <* (spaces <|> eof))) +dline = unDL (progline <* optional (char '.') <* optional newline) -dlines :: MonadParser m => m [Spanned Line] -dlines = dynafy (progline `sepEndBy` (char '.' <* spaces)) +dlines :: DeltaParsing m => m [Spanned Line] +dlines = unDL (progline `sepEndBy` (char '.' <* spaces)) diff --git a/src/Dyna/ParserHS/ParserSelftest.hs b/src/Dyna/ParserHS/ParserSelftest.hs index fdcd79f..bf242ae 100644 --- a/src/Dyna/ParserHS/ParserSelftest.hs +++ b/src/Dyna/ParserHS/ParserSelftest.hs @@ -9,8 +9,7 @@ -- Test.Framework.TH appears not to understand comments at the -- moment, and parses right through them. --- XXX Cabal doesn't understand Main-Is in quite the right way --- module Dyna.ParserHS.ParserSelftest where +module Dyna.ParserHS.ParserSelftest where import Control.Applicative ((<*)) import Data.ByteString (ByteString) @@ -18,13 +17,15 @@ import Data.Foldable (toList) import Data.Monoid (mempty) import qualified Data.Sequence as S import Data.String +import qualified Test.Framework as TF import Test.Framework.Providers.HUnit import Test.Framework.TH import Test.HUnit import Text.Trifecta +import Text.Trifecta.Delta -import Dyna.Test.Trifecta import Dyna.ParserHS.Parser +import Dyna.XXX.TrifectaTest term :: ByteString -> Spanned Term @@ -63,15 +64,33 @@ case_nestedFunctorsWithArgs = e @=? (term st) st :: (IsString s) => s st = "foo(bar,X,bif(),baz(quux,Y))" +case_basicFunctorComment = e @=? (term sfb) + where + e = TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 8 8) sfb + + sfb :: (IsString s) => s + sfb = "foo %xxx" + +case_basicFunctorNLComment = e @=? (term sfb) + where + e = TFunctor "foo" + [TFunctor "1" [] :~ Span (Lines 1 0 9 0) (Lines 1 1 10 1) "1,2\n" + ,TFunctor "2" [] :~ Span (Lines 1 2 11 2) (Lines 2 0 13 0) "1,2\n" + ] + :~ Span (Columns 0 0) (Lines 2 1 14 1) "foo(%xxx\n" + + sfb :: (IsString s) => s + sfb = "foo(%xxx\n1,2\n)" + case_basicFunctorTWS = e @=? (term sfb) where e = TFunctor "foo" - [TFunctor "bar" [] :~ Span (Columns 5 5) (Columns 9 9) sfb - ] :~ Span (Columns 0 0) (Columns 10 10) sfb + [TFunctor "bar" [] :~ Span (Lines 1 1 5 1) (Lines 1 5 9 5) "(bar )" + ] :~ Span (Columns 0 0) (Columns 10 10) "foo\n" sfb :: (IsString s) => s - sfb = "foo (bar )" + sfb = "foo\n(bar )" case_basicFunctorNL = e @=? (term sfb) where @@ -95,7 +114,7 @@ case_colonFunctor = e @=? (term pvv) pvv = "possible(Var:Val)" case_failIncompleteExpr = checkParseFail dterm "foo +" - [(Right (Columns 4 4), "expected: \"(\", end of input")] + "(interactive):1:5: error: expected: \"(\",\n end of input\nfoo + " progline :: ByteString -> Spanned Line progline = unsafeParse dline @@ -224,6 +243,8 @@ case_rulesDotExpr = e @=? (proglines sr) ] sr = "goal += foo.bar. goal += 1." +selftest :: TF.Test +selftest = $(testGroupGenerator) main :: IO () main = $(defaultMainGenerator) diff --git a/src/Dyna/REPL.hs b/src/Dyna/REPL.hs index 8a3947f..3e6c278 100644 --- a/src/Dyna/REPL.hs +++ b/src/Dyna/REPL.hs @@ -1,8 +1,7 @@ {-# LANGUAGE Rank2Types #-} -module Main where +module Dyna.REPL where import Control.Applicative ((<*)) -import qualified Data.Foldable as F import System.Console.Editline import Text.Trifecta @@ -10,6 +9,7 @@ import qualified Dyna.ParserHS.Parser as DP -- import qualified Dyna.NormalizeParse as DNP import Dyna.XXX.Trifecta + main :: IO () main = do el <- elInit "dyna" @@ -26,16 +26,18 @@ main = do failure l - + -- Interaction interprets a ^D in nested context + -- as an excuse to print out parsing errors + -- (i.e. it why it rejected the line promptCont = do - setPrompt el (return " > ") + setPrompt el (return " ") elGets el success a = do putStrLn $ "\nParsed: " ++ show a loop - failure sd = do - displayLn $ F.toList sd + failure td = do + displayLn td loop loop diff --git a/src/Dyna/Test/Main.hs b/src/Dyna/Test/Main.hs new file mode 100644 index 0000000..b0f2271 --- /dev/null +++ b/src/Dyna/Test/Main.hs @@ -0,0 +1,13 @@ +-- Bring together all of our test suites + +module Dyna.Test.Main where + +import Test.Framework +import qualified Dyna.ParserHS.ParserSelftest as DPHS +import qualified Dyna.XXX.TrifectaTests as DXT + +main :: IO () +main = defaultMain + [DPHS.selftest + , DXT.selftest + ] diff --git a/src/Dyna/Test/Trifecta.hs b/src/Dyna/Test/Trifecta.hs deleted file mode 100644 index 431df44..0000000 --- a/src/Dyna/Test/Trifecta.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - -module Dyna.Test.Trifecta where - -import Control.Applicative ((<*),(*>)) -import Data.ByteString (ByteString) -import Data.Foldable (toList) -import Data.Monoid (mempty) -import qualified Data.Sequence as S -import Data.String -import Test.HUnit -import Text.Trifecta -import Text.Trifecta.Diagnostic.Rendering.Prim (Rendering(..)) - -unsafeParse :: (Show a) => (forall r . (Parser r String a)) -> ByteString -> a -unsafeParse p = unsafeFS . parseByteString (p <* eof) mempty - where unsafeFS (Success xs s) | S.null xs = s - unsafeFS (Success xs _) = error $ "Warnings: " ++ show (toList xs) - unsafeFS (Failure xs) = error $ "Errors: " ++ show (toList xs) - --- XXX this fails to properly check the last argument of the "Diagnostic"s --- we get (the [Diagnostic m] argument). We should fix that eventually. -checkParseFail :: (Show a) - => (forall r . (Parser r String a)) - -> ByteString - -> [(Either String Delta, String)] - -> Assertion -checkParseFail p i e = unsafeFF e $ parseByteString (p <* eof) mempty i - where - unsafeFF e (Success _ _) = error $ "Unexpected success" - unsafeFF e (Failure xs) = e @=? map extractDiag (toList xs) - extractDiag (Diagnostic (Left s) _ m _) = (Left s, show m) - extractDiag (Diagnostic (Right (Rendering d _ _ _ _)) _ m _) = (Right d, show m) - - - diff --git a/src/Dyna/XXX/Trifecta.hs b/src/Dyna/XXX/Trifecta.hs index 74696f8..e1deb82 100644 --- a/src/Dyna/XXX/Trifecta.hs +++ b/src/Dyna/XXX/Trifecta.hs @@ -2,56 +2,34 @@ -- XXX contribute back to trifecta module Dyna.XXX.Trifecta ( - identNL, pureSpanned, stepParserBS, triInteract + identNL, pureSpanned, triInteract ) where -import Data.ByteString as Strict hiding (map, zip, foldl, foldr) -import qualified Data.ByteString.UTF8 as BU import Control.Applicative import Control.Monad (when) +import qualified Data.ByteString.UTF8 as BU +import Data.Monoid (mempty) import Data.HashSet as HashSet (member) -import Data.Monoid import qualified Data.Semigroup.Reducer as R -import qualified Data.Sequence as Q import Text.Trifecta +import Text.Trifecta.Delta -import qualified Text.Trifecta.Parser.Step as TPS -import qualified Text.Trifecta.Parser.Mark as TPM - - -- XXX -import Debug.Trace +-- import Debug.Trace --- | Step a trifecta parser +-- | Just like ident but without the "token $" prefix -- --- based on Text.Trifecta.Parser.parseByteString -stepParserBS :: Show a - => (forall r. Parser r String a) - -> Delta - -> ByteString - -> TPS.Step TermDoc a -stepParserBS p d inp = TPS.feed inp $ stepParser - (fmap prettyTerm) - (why prettyTerm) - (TPM.release d *> p) - mempty - True - mempty - mempty - --- | Just like ident but without the "lexeme $" prefix --- --- belongs in Text.Trifecta.Parser.Identifier +-- belongs in Text.Parser.Token -- -identNL :: MonadParser m => IdentifierStyle m -> m ByteString +identNL :: (Monad m, TokenParsing m) => IdentifierStyle m -> m String identNL s = try $ do - name <- highlight (styleHighlight s) (sliced (styleStart s *> skipMany (styleLetter s))) styleName s - when (member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name + name <- highlight (styleHighlight s) ((:) <$> styleStart s <*> many (styleLetter s) styleName s) + when (HashSet.member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name return name -- | Just like "pure" but right here in the parsing state -- -- belongs in Text.Trifecta.Diagnostic.Rendering.Span -pureSpanned :: MonadParser f => a -> f (Spanned a) +pureSpanned :: DeltaParsing m => a -> m (Spanned a) pureSpanned r = (liftA (r :~) $ Span <$> position <*> position <*> line) @@ -60,20 +38,21 @@ pureSpanned r = (liftA (r :~) $ Span <$> position <*> position <*> line) -- Maybe this should not be contributed, but it uses so much of the -- internals that it surely belongs here beside the other such. triInteract :: (Monad m, Show a) - => (forall m' . MonadParser m' => m' a) -- ^ Parser - -> (m (Maybe String)) -- ^ Continuation callback - -> (a -> m ()) -- ^ Success callback - -> (Q.Seq (Diagnostic TermDoc) -> m ()) -- ^ Failure callback - -> String -- ^ Initial input - -> m () -triInteract p c s f i = loop (stepParserBS p dd $ BU.fromString i) + => (Parser a) -- ^ Parser + -> (m (Maybe String)) -- ^ Continuation callback + -> (a -> m b) -- ^ Success callback + -> (TermDoc -> m b) -- ^ Failure callback + -> String -- ^ Initial input + -> m b +triInteract p c s f i = loop (feed (BU.fromString i) $ stepParser (release dd *> p) dd mempty) where - loop x = traceShow ("triInteract", x) $ case x of - TPS.StepDone _ _ a -> s a - TPS.StepFail _ sd -> f sd - TPS.StepCont ro re k -> case re of - Success _ a -> s a + loop x = {- traceShow ("triInteract", x) $ -} case x of + StepDone _ a -> s a + StepFail _ sd -> f sd + StepCont ro re k -> case re of + Success a -> s a Failure sd -> c >>= maybe (f sd) (loop . k . R.snoc ro) dd = Directed (BU.fromString "interactive") 0 0 0 0 + diff --git a/src/Dyna/XXX/TrifectaTest.hs b/src/Dyna/XXX/TrifectaTest.hs new file mode 100644 index 0000000..f4e4105 --- /dev/null +++ b/src/Dyna/XXX/TrifectaTest.hs @@ -0,0 +1,31 @@ +module Dyna.XXX.TrifectaTest( + unsafeFS, unsafeFF, unsafeParse, checkParseFail +) where + +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Monoid (mempty) +import Test.HUnit +import Text.Trifecta + +unsafeFS :: Result t -> t +unsafeFS (Success a) = a +unsafeFS (Failure td) = error $ "Errors: " ++ show td + +unsafeFF :: String -> Result t -> Assertion +unsafeFF e (Success _) = error $ "Unexpected success" +unsafeFF e (Failure td) = e @=? show td + +unsafeParse :: (Show a) => (Parser a) -> ByteString -> a +unsafeParse p = unsafeFS . parseByteString (p <* eof) mempty + +-- XXX this fails to properly check the last argument of the "Diagnostic"s +-- we get (the [Diagnostic m] argument). We should fix that eventually. +checkParseFail :: (Show a) + => Parser a + -> ByteString + -> String + -> Assertion +checkParseFail p i e = unsafeFF e $ parseByteString (p <* eof) mempty i + + diff --git a/src/Dyna/XXX/TrifectaTests.hs b/src/Dyna/XXX/TrifectaTests.hs new file mode 100644 index 0000000..f0a4c1a --- /dev/null +++ b/src/Dyna/XXX/TrifectaTests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Dyna.XXX.TrifectaTests (selftest) where + +import Control.Applicative +import Control.Monad.State +import qualified Data.ByteString.Char8 as B8 +import Data.Monoid (mempty) +import qualified Test.Framework as TF +import Test.Framework.Providers.HUnit +import Test.Framework.TH +import Test.HUnit +import Text.Trifecta + +import Dyna.XXX.Trifecta +import Dyna.XXX.TrifectaTest + +pa = parens (many $ char 'a') + +case_incrementality0 = + unsafeFS (parseByteString pa mempty fullstr) + @=? unsafeFS (starve (feed fullstr (stepParser (release mempty *> pa) mempty B8.empty))) + where + fullstr = B8.pack "(aa)" + +case_incrementality1 = + unsafeFS (parseByteString pa mempty fullstr) + @=? unsafeFS (starve (feed tstr (feed istr (stepParser (release mempty *> pa) mempty B8.empty)))) + where + fullstr = B8.concat [istr, tstr] + istr = B8.pack "(a" + tstr = B8.pack "a)" + +{- + - XXX no workie +_case_incrementality2 = + unsafeFS (parseByteString pa mempty fullstr) + ~=? unsafeFS (starve (feed tstr (stepParser (release mempty *> pa) mempty istr))) + where + fullstr = B8.concat [istr, tstr] + istr = B8.pack "(a" + tstr = B8.pack "a)" + -} + +interactTest p (i:is) = runState (triInteract p next success failure i) is + where + next = do + l <- get + case l of + [] -> return Nothing + x:xs -> put xs >> return (Just x) + + success = return.Right + failure = return.Left + +successInteract p r i = either (const $ assertFailure "Parser failure") + (assertEqual "" r) $ + fst $ interactTest p i + +case_interactOnce = successInteract pa "aa" ["(aa)"] +case_interactMany = successInteract pa "aa" ["", "(a", "", "a)", ""] + +selftest :: TF.Test +selftest = $(testGroupGenerator) + +main :: IO () +main = $(defaultMainGenerator) -- 2.50.1