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
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
----------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
-- 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 ("{ ... }")
) 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
, 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
]
<*> 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
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
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"))
, 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))
-- 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)
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
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
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 +<EOF> "
progline :: ByteString -> Spanned Line
progline = unsafeParse dline
]
sr = "goal += foo.bar. goal += 1."
+selftest :: TF.Test
+selftest = $(testGroupGenerator)
main :: IO ()
main = $(defaultMainGenerator)
{-# 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
-- import qualified Dyna.NormalizeParse as DNP
import Dyna.XXX.Trifecta
+
main :: IO ()
main = do
el <- elInit "dyna"
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
--- /dev/null
+-- 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
+ ]
+++ /dev/null
-{-# 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)
-
-
-
-- 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)
-- 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
+
--- /dev/null
+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
+
+
--- /dev/null
+{-# 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)
projects / dyna2 / commitdiff