-- import qualified Debug.Trace as XT
import Dyna.Main.Defns
import Dyna.Main.Exception
-import qualified Dyna.ParserHS.Parser as P
+import qualified Dyna.ParserHS.Types as P
import Dyna.Term.TTerm
import Dyna.Term.Normalized
import Dyna.Term.SurfaceSyntax
import Dyna.Analysis.RuleMode
import Dyna.Backend.BackendDefn
import Dyna.Main.Exception
+import qualified Dyna.ParserHS.Types as P
import qualified Dyna.ParserHS.Parser as P
import Dyna.Term.TTerm
import Dyna.XXX.PPrint
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BU
import qualified Data.Map as M
+import Data.Maybe
import qualified Data.Set as S
import Data.Monoid (mempty)
import Dyna.Main.Defns
import Dyna.Main.Exception
import Dyna.ParserHS.Parser
+import Dyna.ParserHS.Types
import Dyna.Term.SurfaceSyntax
import Dyna.Term.TTerm
import Dyna.XXX.Trifecta (prettySpanLoc)
nextRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m)
=> Maybe (S.Set String)
- -> m (Spanned Rule)
+ -> m (Maybe (Spanned Rule))
nextRule aggs = go
where
go = do
(l :~ s) <- gets (mkdlc aggs) >>= parse
case l of
- LPragma p -> pcsProcPragma (p :~ s) >> go
- LRule r -> return r
+ PLPragma p -> pcsProcPragma (p :~ s) >> return Nothing
+ PLRule r -> return (Just r)
oneshotDynaParser :: (DeltaParsing m, LookAheadParsing m)
=> Maybe (S.Set String)
-> m ParsedDynaProgram
oneshotDynaParser aggs = (postProcess =<<)
$ flip runStateT defPCS
- $ many (try $ do
- r <- nextRule aggs
- rix <- pcs_ruleix <<%= (+1)
- dt <- use pcs_dt_cache
- return $ (rix, dt, r))
- <* optional (dynaWhiteSpace (someSpace))
+ $ optional (dynaWhiteSpace (someSpace))
+ *> many (try $ do
+ mr <- nextRule aggs
+ case mr of
+ Nothing -> return Nothing
+ (Just r) -> do
+ rix <- pcs_ruleix <<%= (+1)
+ dt <- use pcs_dt_cache
+ return $ Just (rix, dt, r))
where
- postProcess (rs,pcs) = return $ PDP rs (pcs ^. pcs_iagg_map) (pragmasFromPCS pcs)
-
+ postProcess (rs,pcs) = return $
+ PDP (catMaybes rs)
+ (pcs ^. pcs_iagg_map)
+ (pragmasFromPCS pcs)
------------------------------------------------------------------------}}}
-- this depends on an upstream fix in Text.Parser.Expression.
-- But: I am not worried about it since we don't handle gensyms
-- anywhere else in the pipeline yet)
---
--- Header material {{{
-{-# LANGUAGE DeriveDataTypeable #-}
+
+-- Header material {{{
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Dyna.ParserHS.Parser (
-- * Parser configuration inputs
EOT, mkEOT, DLCfg(..),
- -- * Parser output types
- NameWithArgs(..),
- -- ** Surface langauge
- Term(..), Rule(..), dynaWhiteSpace, genericAggregators,
+ dynaWhiteSpace, genericAggregators,
-- ** Pragmas
- ParsedInst(..), ParsedModeInst, Pragma(..), renderPragma,
- -- ** Line
- Line(..),
+ renderPragma,
-- * Action
parse,
-- * Test harness hooks
import qualified Data.ByteString.UTF8 as BU
import qualified Data.ByteString as B
import qualified Data.CharSet as CS
-import qualified Data.Data as D
import qualified Data.HashSet as H
import qualified Data.Map as M
import Data.Semigroup ((<>))
import Dyna.Analysis.Mode.Inst
import qualified Dyna.Analysis.Mode.InstPretty as IP
import Dyna.Analysis.Mode.Uniq
-import Dyna.Main.Defns
+import Dyna.ParserHS.Types
import Dyna.Term.TTerm (Annotation(..), TBase(..),
DFunct)
import Dyna.Term.SurfaceSyntax
import qualified Text.PrettyPrint.Free as PP
import Text.Trifecta
-------------------------------------------------------------------------}}}
--- Parsed output definitions {{{
-
-data Term = TFunctor B.ByteString
- [Spanned Term]
- | TAnnot (Annotation (Spanned Term))
- (Spanned Term)
- | TVar B.ByteString
- | TBase TBase
- deriving (D.Data,D.Typeable,Eq,Ord,Show)
-
--- | 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
--- concern -- just use the parenthesized texpr case) so that there is no
--- risk of parsing ambiguity.
-data Rule = Rule (Spanned Term) B.ByteString (Spanned Term)
- deriving (Eq,Show)
-
-data NameWithArgs = PNWA B.ByteString [B.ByteString]
- deriving (Eq,Show)
-
--- | Pragmas that are recognized by the parser
-data Pragma = PDispos SelfDispos B.ByteString [ArgDispos]
- -- ^ Assert the evaluation disposition of a functor
-
- | PDisposDefl String
- -- ^ Specify the default disposition handlers
- -- for subsequent context.
- --
- -- Note that the override defintions are
- -- preserved across this operation!
- -- (XXX is that what we want?)
-
- | PIAggr B.ByteString Int B.ByteString
- -- ^ Assert the aggregator for a functor/arity.
-
- | PInst NameWithArgs
- ParsedInst
- -- ^ Declare an instantiation state: name and body
-
- | PMode NameWithArgs
- ParsedModeInst
- ParsedModeInst
- -- ^ Declare a mode: name, input, and output
-
- | POperAdd Fixity Integer B.ByteString
- -- ^ Add an operator
-
- | POperDel B.ByteString
- -- ^ Remove an operator
-
- -- | PQMode DFunctAr
- -- ^ A query mode declaration
-
- | PRuleIx RuleIx
- -- ^ Set the rule index.
- --
- -- XXX This is a bit of a hack to allow external drivers to
- -- feed rules incrementally; those drivers should treat the
- -- rule index as an opaque token rather than something to be
- -- interpreted. Eventually this will go away, when our
- -- REPLs have captive compilers.
-
- {- --- | PMisc Term
- -- ^ Fall-back parser for :- lines. -}
- deriving (Eq,Show)
-
--- | The type of a parsed inst declaration
-data ParsedInst = PIVar !B.ByteString
- | PIInst !(InstF DFunct ParsedInst)
- deriving (Eq,Show)
-
-type ParsedModeInst = Either NameWithArgs ParsedInst
-
-data Line = LRule (Spanned Rule)
- | LPragma Pragma
- deriving (Show)
-
------------------------------------------------------------------------}}}
-- Parser input definitions {{{
------------------------------------------------------------------------}}}
-- Atoms {{{
-parseAtom :: (Monad m, TokenParsing m) => m B.ByteString
+parseAtom :: (Monad m, TokenParsing m) => m DFunct
parseAtom = (liftA BU.fromString stringLiteralSQ <|> name) <?> "Atom"
-parseFunctor :: (Monad m, TokenParsing m) => m B.ByteString
+parseFunctor :: (Monad m, TokenParsing m) => m DFunct
parseFunctor = highlight Identifier parseAtom <?> "Functor"
------------------------------------------------------------------------}}}
[ parens tfexpr
, spanned $ TVar <$> var
- , spanned $ mkta <$> (colon *> term) <* whiteSpace <*> term
+ , spanned $ mkta <$> (colon *> term) <*> term
, try $ spanned $ TBase . TString <$> bsf stringLiteral
rule :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m)
=> m Rule
-rule = do
- _ <- whiteSpace
+rule = token $ do
h@(_ :~ hs) <- term
choice [ do
_ <- try (char '.' <* lookAhead whiteSpace)
return (Rule h "|=" (TFunctor "true" [] :~ hs))
, do
- aggr <- join $ asks dlc_aggrs
- _ <- whiteSpace
+ aggr <- token $ join $ asks dlc_aggrs
body <- tfexpr
_ <- char '.'
return (Rule h aggr body)
pragmaBody :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m)
=> m Pragma
-pragmaBody = choice
+pragmaBody = token $ choice
[
symbol "dispos_def" *> parseDisposDefl -- set default dispositions
, symbol "dispos" *> parseDisposition -- in-place dispositions
pragma :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m)
=> m Pragma
-pragma = symbol ":-"
- *> whiteSpace
- *> (pragmaBody
- -- <|> fmap PMisc (unSpan <$> tfexpr <?> "Other pragma")
- )
- <* whiteSpace
- <* {- optional -} (char '.')
+pragma = token $
+ symbol ":-"
+ *> (pragmaBody
+ -- <|> fmap PMisc (unSpan <$> tfexpr <?> "Other pragma")
+ )
+ <* {- optional -} (char '.')
------------------------------------------------------------------------}}}
-- Lines {{{
dline :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m)
- => m (Spanned Line)
-dline = whiteSpace
- *> spanned (choice [ LPragma <$> pragma
- , LRule <$> spanned rule
- ])
+ => m (Spanned PLine)
+dline = spanned (choice [ PLPragma <$> pragma
+ , PLRule <$> spanned rule
+ ])
configureParser :: (DeltaParsing m, LookAheadParsing m)
=> DynaLanguage m a
configureParser p c = runReaderT (unDL p) c
-- | The grand Dyna parser.
-parse :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m (Spanned Line)
+parse :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m (Spanned PLine)
parse = configureParser dline
------------------------------------------------------------------------}}}
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BU
-- import Data.Foldable (toList)
--- import Data.Monoid (mempty)
+import Data.Monoid (mempty)
-- import qualified Data.Sequence as S
import Data.String
import Dyna.Main.Defns
import Dyna.ParserHS.Parser
import Dyna.ParserHS.OneshotDriver
+import Dyna.ParserHS.Types
import Dyna.Term.SurfaceSyntax
import Dyna.Term.TTerm (Annotation(..), TBase(..))
import Dyna.XXX.TrifectaTest
case_failIncompleteExpr :: Assertion
case_failIncompleteExpr = checkParseFail (testTerm defDLC) "foo +"
- "(interactive):1:5: error: expected: \"(\",\nend of input\nfoo +<EOF> \n ^ "
+ (\s -> take 18 s @=? "(interactive):1:5:")
------------------------------------------------------------------------}}}
-- Annotations {{{
okAggrs
, TestLabel "generic invalid" $ TestList $
map (\x -> TestLabel (BU.toString x) $ TestCase
- $ checkParseFail_ testGenericAggr x)
+ $ checkParseFail
+ testGenericAggr
+ x
+ (\_ -> return ()))
[".", ". ", "+=3", "+3=", "+=a", "+a=" ]
, TestLabel "custom accept" $
let r = unsafeParse (testRule cdlc) r1
"+="
(TFunctor "b" [] :~ Span (Columns 5 5) (Columns 6 6) r1)
, TestLabel "custom reject" $ TestCase
- $ checkParseFail_ (testRule cdlc) "a *= b."
+ $ checkParseFail (testRule cdlc)
+ "a *= b."
+ (\_ -> return ())
]
where
r1 = "a += b."
-- Rules {{{
progrule :: ByteString -> Spanned Rule
-progrule = unsafeParse (spanned (testRule defDLC <* eof))
+progrule = unsafeParse (whiteSpace *> spanned (testRule defDLC <* eof))
progrules :: ByteString -> [Spanned Rule]
-progrules = unsafeParse (many (spanned (testRule defDLC)) <* eof)
+progrules = unsafeParse (whiteSpace *> many (spanned (testRule defDLC)) <* eof)
oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)]
oneshotRules = xlate . unsafeParse (oneshotDynaParser Nothing)
(_tNumeric (Left 2) :~ Span (Columns 22 22) (Columns 24 24) sr)
:~ s2
]
- s1 = Span (Columns 0 0) (Columns 11 11) sr
- s2 = Span (Columns 11 11) (Columns 25 25) sr
+ s1 = Span (Columns 0 0) (Columns 12 12) sr
+ s2 = Span (Columns 12 12) (Columns 25 25) sr
sr = "goal += 1 . laog min= 2 ."
-case_rules_ruleix_pragmas :: Assertion
-case_rules_ruleix_pragmas = e @=? (oneshotRules sr)
+case_rules_with_ruleix_pragmas :: Assertion
+case_rules_with_ruleix_pragmas = e @=? (oneshotRules sr)
where
e = [ ( 5
, Rule
)
]
- s1 = Span (Columns 13 13) (Columns 23 23) sr
+ s1 = Span (Columns 13 13) (Columns 24 24) sr
s2 = Span (Columns 24 24) (Columns 36 36) sr
sr = ":- ruleix 5. goal += 1. laog min= 2."
-
-
+
+case_just_ruleix_pragma :: Assertion
+case_just_ruleix_pragma = [] @=? (oneshotRules ":-ruleix 5.")
+
case_rulesWhitespace :: Assertion
case_rulesWhitespace = e @=? (progrules sr)
where
l1 = " += 1 .\n"
l2 = "%test \n"
l3 = " goal += 2 ."
- s1 = Span (Columns 0 0) (Lines 1 7 22 7) l0
- s2 = Span (Lines 1 7 22 7) (Lines 3 12 42 12) l1
+ s1 = Span (Columns 2 2) (Lines 3 1 31 1) l0
+ s2 = Span (Lines 3 1 31 1) (Lines 3 12 42 12) l3
sr = B.concat [l0,l1,l2,l3]
case_rulesDotExpr :: Assertion
(_tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr)
:~ s2
]
- s1 = Span (Columns 0 0) (Columns 16 16) sr
- s2 = Span (Columns 16 16) (Columns 28 28) sr
+ s1 = Span (Columns 0 0) (Columns 17 17) sr
+ s2 = Span (Columns 17 17) (Columns 28 28) sr
sr = "goal += foo.bar. goal += 1 ."
+case_rule_with_unknown_operator :: Assertion
+case_rule_with_unknown_operator =
+ checkParseFail (testRule dlc)
+ "goal += 1 ### 2."
+ (\s -> take 19 s @=? "(interactive):1:11:")
+ where
+ dlc = DLC (mkEOT mempty False) genericAggregators
+
------------------------------------------------------------------------}}}
-- Pragmas {{{
--- /dev/null
+---------------------------------------------------------------------------
+-- | The types which constitute the output of the parser
+
+-- Header material {{{
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Dyna.ParserHS.Types (
+ -- * Parser output types
+ NameWithArgs(..),
+ -- ** Surface langauge
+ Term(..), Rule(..),
+ -- ** Pragmas
+ ParsedInst(..), ParsedModeInst, Pragma(..),
+ -- ** Lines
+ PLine(..),
+) where
+
+
+import qualified Data.ByteString as B
+import qualified Data.Data as D
+import Dyna.Analysis.Mode.Inst
+import Dyna.Main.Defns
+import Dyna.Term.TTerm (Annotation(..), TBase(..),
+ DFunct)
+import Dyna.Term.SurfaceSyntax
+import Text.Trifecta
+
+------------------------------------------------------------------------}}}
+-- Parsed output definitions {{{
+
+data Term = TFunctor B.ByteString
+ [Spanned Term]
+ | TAnnot (Annotation (Spanned Term))
+ (Spanned Term)
+ | TVar B.ByteString
+ | TBase TBase
+ deriving (D.Data,D.Typeable,Eq,Ord,Show)
+
+-- | 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
+-- concern -- just use the parenthesized texpr case) so that there is no
+-- risk of parsing ambiguity.
+data Rule = Rule (Spanned Term) B.ByteString (Spanned Term)
+ deriving (Eq,Show)
+
+data NameWithArgs = PNWA B.ByteString [B.ByteString]
+ deriving (Eq,Show)
+
+-- | Pragmas that are recognized by the parser
+data Pragma = PDispos SelfDispos B.ByteString [ArgDispos]
+ -- ^ Assert the evaluation disposition of a functor
+
+ | PDisposDefl String
+ -- ^ Specify the default disposition handlers
+ -- for subsequent context.
+ --
+ -- Note that the override defintions are
+ -- preserved across this operation!
+ -- (XXX is that what we want?)
+
+ | PIAggr B.ByteString Int B.ByteString
+ -- ^ Assert the aggregator for a functor/arity.
+
+ | PInst NameWithArgs
+ ParsedInst
+ -- ^ Declare an instantiation state: name and body
+
+ | PMode NameWithArgs
+ ParsedModeInst
+ ParsedModeInst
+ -- ^ Declare a mode: name, input, and output
+
+ | POperAdd Fixity Integer B.ByteString
+ -- ^ Add an operator
+
+ | POperDel B.ByteString
+ -- ^ Remove an operator
+
+ | PRuleIx RuleIx
+ -- ^ Set the rule index.
+ --
+ -- XXX This is a bit of a hack to allow external drivers to
+ -- feed rules incrementally; those drivers should treat the
+ -- rule index as an opaque token rather than something to be
+ -- interpreted. Eventually this will go away, when our
+ -- REPLs have captive compilers.
+
+ {- --- | PMisc Term
+ -- ^ Fall-back parser for :- lines. -}
+ deriving (Eq,Show)
+
+-- | The type of a parsed inst declaration
+data ParsedInst = PIVar !B.ByteString
+ | PIInst !(InstF DFunct ParsedInst)
+ deriving (Eq,Show)
+
+type ParsedModeInst = Either NameWithArgs ParsedInst
+
+data PLine = PLRule (Spanned Rule)
+ | PLPragma Pragma
+ deriving (Show)
+
+------------------------------------------------------------------------}}}
module Dyna.XXX.TrifectaTest(
- unsafeFS, unsafeFF, unsafeFF_, unsafeParse, checkParseFail, checkParseFail_
+ unsafeFS, unsafeFF, unsafeParse, checkParseFail,
) where
import Control.Applicative
unsafeFS (Success a) = a
unsafeFS (Failure td) = error $ "Errors: " ++ show td
-unsafeFF :: String -> Result t -> Assertion
+unsafeFF :: (String -> Assertion) -> Result t -> Assertion
unsafeFF _ (Success _) = assertFailure "Unexpected success"
-unsafeFF e (Failure td) = e @=? flip PPA.displayS ""
- (filterSD $ PPA.renderCompact td)
+unsafeFF a (Failure td) = a $ flip PPA.displayS ""
+ (filterSD $ PPA.renderCompact td)
where
-- strip out any ANSI BS
filterSD PPA.SEmpty = PPA.SEmpty
filterSD (PPA.SLine i x) = PPA.SLine i (filterSD x)
filterSD (PPA.SSGR _ x) = filterSD x
-unsafeFF_ :: Result t -> Assertion
-unsafeFF_ (Success _) = assertFailure "Unexpected success"
-unsafeFF_ (Failure _) = return ()
-
unsafeParse :: (Parser a) -> ByteString -> a
unsafeParse p = unsafeFS . parseByteString (p <* eof) mempty
checkParseFail :: (Show a)
=> Parser a
-> ByteString
- -> String
+ -> (String -> Assertion)
-> Assertion
checkParseFail p i e = unsafeFF e $ parseByteString (p <* eof) mempty i
-checkParseFail_ :: Parser a
- -> ByteString
- -> Assertion
-checkParseFail_ p i = unsafeFF_ $ parseByteString (p <* eof) mempty i
-
projects / dyna2 / commitdiff