From c271da59c173ebbc6fd851d006c741685d9cc2b6 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Mon, 3 Jun 2013 03:10:32 -0400 Subject: [PATCH] Rework parser infrastructure Parser now really should just be the parser. OneshotDriver consumes an entire Dyna program at once, tracking all the requisite state from line to line, before emitting the whole mass to the down-stream pipeline. While here, push through some changes for custom operator symbols, though this is not quite wired up yet. --- dyna.cabal | 8 +- src/Dyna/Analysis/ANF.hs | 4 +- src/Dyna/Main/Driver.hs | 13 +- src/Dyna/ParserHS/OneshotDriver.hs | 153 ++++++++++++ src/Dyna/ParserHS/Parser.hs | 382 ++++++++++++----------------- src/Dyna/ParserHS/Selftest.hs | 219 +++++++++-------- src/Dyna/Term/SurfaceSyntax.hs | 43 ++++ src/Dyna/XXX/MonadUtils.hs | 7 +- src/Dyna/XXX/TrifectaTest.hs | 3 +- 9 files changed, 494 insertions(+), 338 deletions(-) create mode 100644 src/Dyna/ParserHS/OneshotDriver.hs diff --git a/dyna.cabal b/dyna.cabal index 270c91d..91469fa 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -47,7 +47,7 @@ source-repository head -- mtl >=2.1, -- lens >=3.8, -- -- logict >=0.6, --- parsers >=0.5, +-- parsers >=0.6, -- recursion-schemes >=3.0, -- reducers >=3.0, -- semigroups >=0.8, @@ -76,7 +76,7 @@ source-repository head -- haskeline >=0.6, -- mtl >=2.1, -- lens >=3.8, --- parsers >=0.5, +-- parsers >=0.6, -- process >=1.1, -- recursion-schemes >=3.0, -- reducers >=3.0, @@ -110,7 +110,7 @@ Executable dyna mtl >=2.1, lens >=3.8, -- logict >=0.6, - parsers >=0.5, + parsers >=0.6, process >=1.1, recursion-schemes >=3.0, reducers >=3.0, @@ -145,7 +145,7 @@ Test-suite dyna-selftests mtl >=2.1, lens >=3.8, -- logict >=0.6, - parsers >=0.5, + parsers >=0.6, process >=1.1, QuickCheck >= 2.5, recursion-schemes >=3.0, diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index d8d2186..3095ca0 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -402,9 +402,9 @@ data Rule = Rule { r_index :: RuleIx deriving (Show) -normRule :: T.Spanned P.Rule -- ^ Term to digest +normRule :: (RuleIx, DisposTab, T.Spanned P.Rule) -- ^ Rule to digest -> (Rule, ANFWarns) -normRule (P.Rule i h a r dt T.:~ sp) = +normRule (i, dt, P.Rule h a r T.:~ sp) = let (ru,s) = runNormalize dt $ do nh <- normTerm False h >>= newAssign "_h" . Left nr <- normTerm True r >>= newAssign "_r" . Left diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index d1dad60..8daf8cc 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -19,7 +19,7 @@ import Control.Exception import qualified Data.ByteString.UTF8 as BU import qualified Data.Map as M import qualified Data.Maybe as MA -import qualified Data.Set as S +-- import qualified Data.Set as S import Data.String import Dyna.Analysis.Aggregation import Dyna.Analysis.ANF @@ -29,7 +29,7 @@ import Dyna.Analysis.RuleMode import Dyna.Backend.BackendDefn import Dyna.Backend.Backends import Dyna.Main.Exception -import qualified Dyna.ParserHS.Parser as P +import qualified Dyna.ParserHS.OneshotDriver as P import Dyna.Term.TTerm import Dyna.XXX.Trifecta (prettySpanLoc) import System.Console.GetOpt @@ -249,12 +249,11 @@ processFile fileName = bracket openOut hClose go maybeWarnANF xs = Just $ vcat $ map (uncurry renderSpannedWarn) xs go out = do - rs <- parse + P.PDP rs <- parse - dump DumpParsed (vcat $ map (text.show) rs) + dump DumpParsed (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) - let urs = map (\(P.LRule x T.:~ _) -> x) rs - (frs, anfWarns) = unzip $ map normRule urs + let (frs, anfWarns) = unzip $ map normRule rs dump DumpANF (vcat $ map printANF frs) @@ -296,7 +295,7 @@ processFile fileName = bracket openOut hClose go be_d aggm uPlans' {- qPlans -} initializers' out parse = do - pr <- T.parseFromFileEx (P.rawDLines <* T.eof) fileName + pr <- T.parseFromFileEx (P.oneshotDynaParser <* T.eof) fileName case pr of TR.Failure td -> dynacUserANSIErr $ PPA.align ("Parser error" PPA.<$> td) TR.Success rs -> return rs diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs new file mode 100644 index 0000000..4f2ca32 --- /dev/null +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -0,0 +1,153 @@ +--------------------------------------------------------------------------- +-- | A driver which wraps the parser and accumulates state to hand off in a +-- single chunk to the rest of the pipeline. +-- +-- XXX We'd like to have a much more incremental version as well, but the +-- easiest thing to do was to extricate the old parser's state handling code +-- to its own module first. + +-- Header material {{{ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Dyna.ParserHS.OneshotDriver where + +import Control.Applicative +import Control.Lens +import Control.Monad.State +import qualified Data.ByteString as B +import qualified Data.Map as M +import Data.Monoid (mempty) +import Dyna.Main.Defns +import Dyna.Main.Exception +import Dyna.ParserHS.Parser +import Dyna.Term.SurfaceSyntax +import Dyna.Term.TTerm +import Dyna.XXX.Trifecta (prettySpanLoc) +import Text.Parser.LookAhead +import Text.Trifecta +import qualified Text.PrettyPrint.Free as PP + +------------------------------------------------------------------------}}} +-- Output {{{ + +data ParsedDynaProgram = PDP + { _pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)] + } + +------------------------------------------------------------------------}}} +-- Driver state {{{ + +-- | Configuration state threaded into the parser +-- +-- Note that this type is hidden with the exception of some accessors below. +data PCS = PCS + { _pcs_dt_mk :: DisposTabOver -> DisposTab + , _pcs_dt_over :: DisposTabOver + , _pcs_instmap :: M.Map B.ByteString ([DVar] + ,ParsedInst + ,Span) + -- ^ Collects inst pragmas + -- + -- XXX add arity to key? + , _pcs_modemap :: M.Map B.ByteString ([DVar] + ,ParsedModeInst + ,ParsedModeInst + ,Span) + -- ^ Collects mode pragmas + -- + -- XXX add arity to key? + , _pcs_operspec :: OperSpec + , _pcs_opertab :: EOT + -- ^ Cache the operator table so we are not rebuilding it + -- before every parse operation + , _pcs_ruleix :: RuleIx + } +$(makeLenses ''PCS) + +_pcs_dlc pcs = DLC (_pcs_opertab pcs) + +pcs_dt = liftA2 ($) (use pcs_dt_mk) (use pcs_dt_over) + +newtype PCM im a = PCM { unPCM :: StateT PCS im a } + deriving (Alternative,Applicative,CharParsing,DeltaParsing, + Functor,LookAheadParsing,Monad,MonadPlus,Parsing,TokenParsing) + +instance (Monad im) => MonadState PCS (PCM im) where + get = PCM get + put = PCM . put + state = PCM . state + +defPCS :: PCS +defPCS = PCS { _pcs_dt_mk = disposTab_dyna + , _pcs_dt_over = mempty + , _pcs_instmap = mempty -- XXX + , _pcs_modemap = mempty -- XXX + , _pcs_operspec = defOperSpec + , _pcs_opertab = mkEOT (defPCS ^. pcs_operspec) True + , _pcs_ruleix = 0 + } + +-- | Update the PCS to reflect a new pragma +pcsProcPragma :: (Parsing m, MonadState PCS m) => Spanned Pragma -> m () +pcsProcPragma (PDispos s f as :~ _) = do + pcs_dt_over %= dtoMerge (f,length as) (s,as) +pcsProcPragma (PDisposDefl n :~ s) = do + pcs_dt_mk .= case n of + "dyna" -> disposTab_dyna + "prologish" -> disposTab_dyna + _ -> dynacPanic $ "Unknown default disposition table:" + PP. PP.pretty n + PP. "at" PP. prettySpanLoc s +pcsProcPragma (PInst (PNWA n as) pi :~ s) = do + im <- use pcs_instmap + maybe (pcs_instmap %= M.insert n (as,pi,s)) + -- XXX fix this error message once the new trifecta lands upstream + -- with its ability to throw Err. + (\(_,_,s') -> unexpected $ "duplicate definition of inst: " + ++ (show n) + ++ "(prior definition at " + ++ (show s') ++ ")" ) + $ M.lookup n im +pcsProcPragma (PMode (PNWA n as) pmf pmt :~ s) = do + mm <- use pcs_modemap + maybe (pcs_modemap %= M.insert n (as,pmf,pmt,s)) + -- XXX fix this error message once the new trifecta lands upstream + -- with its ability to throw Err. + (\(_,_,_,s') -> unexpected $ "duplicate definition of mode: " + ++ (show n) + ++ "(prior definition at " + ++ (show s') ++ ")" ) + $ M.lookup n mm +pcsProcPragma (PRuleIx r :~ _) = pcs_ruleix .= r + +pcsProcPragma (p :~ s) = dynacSorry $ "Cannot handle pragma" + PP. (PP.text $ show p) + PP. "at" + PP. prettySpanLoc s + +nextRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) + => m (Spanned Rule) +nextRule = do + (l :~ s) <- gets _pcs_dlc >>= parse + case l of + LPragma p -> pcsProcPragma (p :~ s) >> nextRule + LRule r -> return r + +oneshotDynaParser :: (DeltaParsing m, LookAheadParsing m) => m ParsedDynaProgram +oneshotDynaParser = (postProcess =<<) $ flip runStateT defPCS + $ many $ do + r <- nextRule + rix <- pcs_ruleix <<%= (+1) + dtmk <- use pcs_dt_mk + dto <- use pcs_dt_over + return $ (rix, dtmk dto, r) + <* whiteSpace + where + postProcess (rs,pcs) = return $ PDP rs + +------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 9006b39..47b7633 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -26,31 +26,40 @@ -- But: I am not worried about it since we don't handle gensyms -- anywhere else in the pipeline yet) -- - -- Header material {{{ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall #-} module Dyna.ParserHS.Parser ( - PCS, defPCS, - Term(..), rawDTerm, - Rule(..), RuleIx, rawDRule, rawDRules, Line(..), rawDLine, rawDLines + -- * Parser configuration inputs + EOT, mkEOT, DLCfg(..), + -- * Parser output types + NameWithArgs(..), + -- ** Surface langauge + Term(..), Rule(..), + -- ** Pragmas + ParsedInst(..), ParsedModeInst, Pragma(..), + -- ** Line + Line(..), + -- * Action + parse, + -- * Test harness hooks + testTerm, testRule, testPragma, ) where import Control.Applicative -import Control.Lens import Control.Monad +-- import Control.Monad.Identity import Control.Monad.Reader -import Control.Monad.State +-- import Control.Monad.State +-- import Control.Monad.Trans.Either import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B import qualified Data.CharSet as CS @@ -62,22 +71,21 @@ import Data.Monoid (mempty) import Dyna.Analysis.Mode.Inst import Dyna.Analysis.Mode.Uniq import Dyna.Main.Defns -import Dyna.Main.Exception import Dyna.Term.TTerm (Annotation(..), TBase(..), - DFunct, DFunctAr, DVar) + DFunct, DFunctAr) import Dyna.Term.SurfaceSyntax -import Dyna.XXX.MonadUtils (incState) -import Dyna.XXX.Trifecta (identNL,prettySpanLoc, +import Dyna.XXX.DataUtils +import Dyna.XXX.Trifecta (identNL, stringLiteralSQ,unSpan) import Text.Parser.Expression import Text.Parser.LookAhead import Text.Parser.Token.Highlight import Text.Parser.Token.Style -import qualified Text.PrettyPrint.Free as PP +-- import qualified Text.PrettyPrint.Free as PP import Text.Trifecta ------------------------------------------------------------------------}}} --- Parsed output definition {{{ +-- Parsed output definitions {{{ data Term = TFunctor B.ByteString [Spanned Term] @@ -91,24 +99,8 @@ data Term = TFunctor B.ByteString -- 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. --- --- Each 'Rule' additionally carries its own 'DisposTab' for conversion to --- ANF. We cannot return just one 'DisposTab' when we are done parsing --- because each -data Rule = Rule RuleIx (Spanned Term) B.ByteString (Spanned Term) - DisposTab - -instance Show Rule where - showsPrec p (Rule i h a b _) = showParen (p > 9) $ - showString "Rule " . - showsPrec 6 i . - showString " " . - showsPrec 6 h . - showString " " . - showsPrec 6 a . - showString " " . - showsPrec 6 b . - showString " _" +data Rule = Rule (Spanned Term) B.ByteString (Spanned Term) + deriving (Eq,Show) data NameWithArgs = PNWA B.ByteString [B.ByteString] deriving (Eq,Show) @@ -134,7 +126,7 @@ data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] ParsedModeInst -- ^ Declare a mode: name, input, and output - | POperAdd PragmaFixity Integer B.ByteString + | POperAdd Fixity Integer B.ByteString -- ^ Add an operator | POperDel B.ByteString @@ -142,18 +134,20 @@ data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] | 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) -data PragmaFixity = PFIn PAssoc | PFPre | PFPost - deriving (Eq,Show) - --- XXX This is only necessary until parsers upstream cuts a release in which --- 'Assoc' is 'Eq' and 'Show'. It's already committed upstream, but... -data PAssoc = PAssocNone | PAssocLeft | PAssocRight - deriving (Eq,Show) -- | The type of a parsed inst declaration data ParsedInst = PIVar !B.ByteString @@ -167,7 +161,7 @@ data Line = LRule (Spanned Rule) deriving (Show) ------------------------------------------------------------------------}}} --- Parser Configuration State {{{ +-- Parser input definitions {{{ -- | Existentialized operator table; this is a bit of a hack, but it will -- do just fine for now, I hope. @@ -178,41 +172,31 @@ newtype EOT = EOT { unEOT :: forall m . => OperatorTable m (Spanned Term) } --- | Configuration state threaded into the parser --- --- Note that this type is hidden with the exception of some accessors below. -data PCS = - PCS { _pcs_dt_mk :: DisposTabOver -> DisposTab - , _pcs_dt_over :: DisposTabOver - , _pcs_instmap :: M.Map B.ByteString ([DVar] - ,ParsedInst - ,Span) - -- ^ Collects inst pragmas - -- - -- XXX add arity to key? - , _pcs_modemap :: M.Map B.ByteString ([DVar] - ,ParsedModeInst - ,ParsedModeInst - ,Span) - -- ^ Collects mode pragmas - -- - -- XXX add arity to key? - , _pcs_opertab :: EOT - , _pcs_operspec :: M.Map B.ByteString () -- XXX - , _pcs_ruleix :: RuleIx - } -$(makeLenses ''PCS) - -pcs_dt = liftA2 ($) (use pcs_dt_mk) (use pcs_dt_over) - -newtype PCM im a = PCM { unPCM :: StateT PCS im a } - deriving (Alternative,Applicative,CharParsing,DeltaParsing, - Functor,LookAheadParsing,Monad,MonadPlus,Parsing,TokenParsing) - -instance (Monad im) => MonadState PCS (PCM im) where - get = PCM get - put = PCM . put - state = PCM . state + +-- XXX Add support for Haskell-style `foo`. This requires augmenting +-- the PFIn branch of interpret below to check for the ` framing and +-- change the symbol returned (but not the symbol matched!) +mkEOT :: OperSpec + -> Bool -- ^ add some measure of fail-safety using generic + -- parsers + -> {- Either (PP.Doc e) -} EOT +mkEOT s0 f0 = EOT $ addFailSafe $ interpSpec M.empty $ M.toList s0 + where + interpSpec m [] = map snd $ M.toDescList m + interpSpec m ((o,lfs):os) = interpSpec (foldr go m lfs) os + where + go (p,f) = mapInOrCons p (interpret f o) + + interpret (PFIn a) = flip Infix a . bf . spanned . bsf . symbol + interpret PFPre = Prefix . uf . spanned . bsf . symbol + interpret PFPost = Postfix . uf . spanned . bsf . symbol + + addFailSafe = if f0 then (++ failSafe) else id + + failSafe = [ [ Prefix $ uf (spanned $ prefixOper ) ] + , [ Infix (bf (spanned $ normOper )) AssocNone ] + , [ Infix (bf (spanned $ dotOper )) AssocNone ] + ] ------------------------------------------------------------------------}}} -- Utilities {{{ @@ -220,68 +204,24 @@ instance (Monad im) => MonadState PCS (PCM im) where bsf :: Functor f => f String -> f B.ByteString bsf = fmap BU.fromString +parseNameWithArgs :: (Monad m, TokenParsing m) + => m B.ByteString -> m NameWithArgs parseNameWithArgs n = PNWA <$> n <*> choice [ parens ( var `sepBy` comma ) , pure [] ] --- | Smart constructor for building a rule with index -rule :: (Functor f, MonadState PCS f) - => f ( Spanned Term - -> B.ByteString - -> Spanned Term - -> DisposTab - -> Rule) -rule = Rule <$> (pcs_ruleix <<%= (+1)) - -rs :: (MonadState a m) => ReaderT a m b -> m b -rs x = get >>= runReaderT x - -defPCS = PCS { _pcs_dt_mk = disposTab_dyna - , _pcs_dt_over = mempty - , _pcs_instmap = mempty -- XXX - , _pcs_modemap = mempty -- XXX - , _pcs_operspec = mempty -- XXX - , _pcs_opertab = EOT $ - -- The basic expression table for limited expressions. - -- - -- Notably, this excludes @,@ (which is important - -- syntactically), @for@, @whenever@, and @is@ (which are - -- nonsensical in local context) - -- XXX right now all binops are at equal precedence and - -- left-associative; that's wrong. - -- - -- XXX timv suggests that this should be assocnone for - -- binops as a quick fix. Eventually we should still do - -- this properly. - -- - -- XXX this ought to be derived from the default - -- _pcs_operspec rather than being coded as it is. - [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ] - , [ Prefix $ uf (spanned $ prefixOper ) ] - , [ Infix (bf (spanned $ normOper )) AssocLeft ] - , [ Infix (bf (spanned $ dotOper )) AssocRight ] - ] - , _pcs_ruleix = 0 - } - ------------------------------------------------------------------------}}} --- Comment handling {{{ +-- Parser Monad {{{ -dynaCommentStyle :: CommentStyle -dynaCommentStyle = CommentStyle - { _commentStart = "{%" -- XXX? - , _commentEnd = "%}" -- XXX? - , _commentLine = "%" - , _commentNesting = True - } +data DLCfg = DLC { dlc_opertab :: EOT } -newtype DynaLanguage m a = DL { unDL :: m a } +newtype DynaLanguage m a = DL { unDL :: ReaderT DLCfg m a } deriving (Functor,Applicative,Alternative,Monad,MonadPlus, Parsing,CharParsing,LookAheadParsing) instance MonadTrans DynaLanguage where - lift = DL + lift = DL . lift instance (TokenParsing m, MonadPlus m) => TokenParsing (DynaLanguage m) where someSpace = buildSomeSpaceParser (lift someSpace) dynaCommentStyle @@ -295,14 +235,27 @@ instance DeltaParsing m => DeltaParsing (DynaLanguage m) where rend = lift rend restOfLine = lift restOfLine +instance (Monad m) => MonadReader DLCfg (DynaLanguage m) where + ask = DL ask + local f m = DL (local f (unDL m)) + +{- instance MonadState s m => MonadState s (DynaLanguage m) where get = lift get put = lift . put state = lift . state +-} -instance MonadReader r m => MonadReader r (DynaLanguage m) where - ask = lift ask - local f m = DL $ local f (unDL m) +------------------------------------------------------------------------}}} +-- Comment handling {{{ + +dynaCommentStyle :: CommentStyle +dynaCommentStyle = CommentStyle + { _commentStart = "{%" -- XXX? + , _commentEnd = "%}" -- XXX? + , _commentLine = "%" + , _commentNesting = True + } ------------------------------------------------------------------------}}} -- Identifier Syles {{{ @@ -324,6 +277,7 @@ dynaDotOperStyle = IdentifierStyle , _styleReservedHighlight = ReservedOperator } +{- -- | Comma operators dynaCommaOperStyle :: TokenParsing m => IdentifierStyle m dynaCommaOperStyle = IdentifierStyle @@ -334,6 +288,7 @@ dynaCommaOperStyle = IdentifierStyle , _styleHighlight = Operator , _styleReservedHighlight = ReservedOperator } +-} -- | Prefix operators -- @@ -417,6 +372,7 @@ var = bsf $ ident dynaVarStyle parseAtom :: (Monad m, TokenParsing m) => m B.ByteString parseAtom = (liftA BU.fromString stringLiteralSQ <|> name) "Atom" +parseFunctor :: (Monad m, TokenParsing m) => m B.ByteString parseFunctor = highlight Identifier parseAtom "Functor" ------------------------------------------------------------------------}}} @@ -426,6 +382,8 @@ nullaryStar :: DeltaParsing m => m (Spanned Term) nullaryStar = spanned $ flip TFunctor [] <$> (bsf $ string "*") <* (notFollowedBy $ char '(') +term :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) + => m (Spanned Term) term = token $ choice [ parens tfexpr , spanned $ TVar <$> var @@ -480,9 +438,11 @@ commaOper = bsf $ try ( lookAhead (thenAny $ _styleLetter dynaCommaOperStyle) -} -- | A normal operator is handled by trifecta's built-in handling +normOper :: (Monad m, TokenParsing m) => m B.ByteString normOper = bsf $ ident dynaOperStyle -- | Prefix operators also handled by trifecta's built-in handling +prefixOper :: (Monad m, TokenParsing m) => m B.ByteString prefixOper = bsf $ ident dynaPfxOperStyle uf :: (Monad m, Applicative m) @@ -500,9 +460,9 @@ bf f = do pure (\a@(_:~spa) b@(_:~spb) -> (TFunctor x [a,b]):~(spa <> spx <> spb)) -tlexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) +tlexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m (Spanned Term) -tlexpr = view pcs_opertab >>= flip buildExpressionParser term . unEOT +tlexpr = asks dlc_opertab >>= flip buildExpressionParser term . unEOT moreETable :: (LookAheadParsing m, DeltaParsing m) => [[Operator m (Spanned Term)]] moreETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] @@ -513,13 +473,10 @@ moreETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] ] -- | Full Expression -tfexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) +tfexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m (Spanned Term) tfexpr = buildExpressionParser moreETable tlexpr "Expression" -rawDTerm :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term) -rawDTerm = runReaderT (unDL term) defPCS - ------------------------------------------------------------------------}}} -- Rules {{{ @@ -532,38 +489,31 @@ parseAggr = bsf (pure a) ) "Aggregator" -parseRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) - => m Rule -parseRule = optional whiteSpace - *> choice [ - -- HEAD AGGR TFEXPR . - try $ rule <*> rs term - <* whiteSpace - <*> parseAggr - <*> rs tfexpr - <*> pcs_dt - - -- HEAD . - , do - h@(_ :~ s) <- rs term - rule <*> pure h - <*> pure "&=" - <*> pure (TFunctor "true" [] :~ s) - <*> pcs_dt - ] - <* {- optional -} (char '.') - -rawDRule :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Rule) -rawDRule = evalStateT (unPCM $ unDL $ spanned parseRule) defPCS - -rawDRules :: (DeltaParsing m, LookAheadParsing m) => m [Spanned Rule] -rawDRules = evalStateT (unPCM $ unDL $ many (spanned parseRule <* optional whiteSpace)) defPCS +rule :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) + => m Rule +rule = optional whiteSpace + *> choice [ + -- HEAD AGGR TFEXPR . + try $ Rule <$> term + <* whiteSpace + <*> parseAggr + <*> tfexpr + + -- HEAD . + , do + h@(_ :~ s) <- term + Rule <$> pure h + <*> pure "&=" + <*> pure (TFunctor "true" [] :~ s) + ] + <* {- optional -} (char '.') ------------------------------------------------------------------------}}} -- Pragmas {{{ -- Inst Declarations {{{ +instDeclNameStyle :: TokenParsing m => IdentifierStyle m instDeclNameStyle = dynaNameStyle { _styleName = "Inst name" , _styleReserved = H.fromList $ [ "any" @@ -577,8 +527,10 @@ instDeclNameStyle = dynaNameStyle ] } +instName :: (Monad m, TokenParsing m) => m B.ByteString instName = bsf $ ident instDeclNameStyle +parseInst :: (Monad m, TokenParsing m) => m ParsedInst parseInst = choice [ PIVar <$> var , symbol "free" *> pure (PIInst IFree) , symbol "any" *> (PIInst . IAny <$> optUniq) @@ -604,6 +556,7 @@ parseInst = choice [ PIVar <$> var functinst = (,) <$> parseAtom <*> parens (parseInst `sepBy` comma) +parseUniq :: (TokenParsing m) => m Uniq parseUniq = choice [ symbol "clobbered" *> pure UClobbered , symbol "mostlyclobbered" *> pure UMostlyClobbered , symbol "mostlyunique" *> pure UMostlyUnique @@ -613,12 +566,16 @@ parseUniq = choice [ symbol "clobbered" *> pure UClobbered ------------------------------------------------------------------------}}} -parsePragma = choice +pragmaBody :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m) + => m Pragma +pragmaBody = choice [ -- try $ symbol "aggr" *> parseAggr -- XXX alternate syntax for aggr symbol "dispos" *> parseDisposition -- in-place dispositions + , symbol "dispos_def" *> parseDisposDefl -- set default dispositions , symbol "inst" *> parseInstDecl -- instance delcarations , symbol "mode" *> parseMode -- mode/qmode decls , symbol "oper" *> parseOper -- new {pre,in,post}fix oper + , symbol "ruleix" *> (PRuleIx <$> decimal) ] where parseDisposition = PDispos <$> selfdis @@ -670,9 +627,9 @@ parsePragma = choice ifx = choice [ normOper , dotOper, {- commaOper, -} name ] afx = choice [ prefixOper, normOper, dotOper, {- commaOper, -} name] - assoc = choice [ symbol "none" *> pure PAssocNone - , symbol "left" *> pure PAssocLeft - , symbol "right" *> pure PAssocRight + assoc = choice [ symbol "none" *> pure AssocNone + , symbol "left" *> pure AssocLeft + , symbol "right" *> pure AssocRight ] -- Unlike Mercury, mode declarations are used solely to give names to @@ -685,74 +642,49 @@ parsePragma = choice <*> (Right <$> parseInst <|> Left <$> parseNameWithArgs instName) -dpragma :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) - => m Pragma -dpragma = symbol ":-" - *> whiteSpace - *> (parsePragma - <|> fmap PMisc (unSpan <$> tfexpr "Other pragma")) - <* whiteSpace - <* {- optional -} (char '.') - -pcsProcPragma :: (Parsing m, MonadState PCS m) => Spanned Pragma -> m () -pcsProcPragma (PDispos s f as :~ _) = do - pcs_dt_over %= dtoMerge (f,length as) (s,as) -pcsProcPragma (PDisposDefl n :~ s) = do - pcs_dt_mk .= case n of - "dyna" -> disposTab_dyna - "prologish" -> disposTab_dyna - _ -> dynacPanic $ "Unknown default disposition table:" - PP. PP.pretty n - PP. "at" PP. prettySpanLoc s -pcsProcPragma (PInst (PNWA n as) pi :~ s) = do - im <- use pcs_instmap - maybe (pcs_instmap %= M.insert n (as,pi,s)) - -- XXX fix this error message once the new trifecta lands upstream - -- with its ability to throw Err. - (\(_,_,s') -> unexpected $ "duplicate definition of inst: " - ++ (show n) - ++ "(prior definition at " - ++ (show s') ++ ")" ) - $ M.lookup n im -pcsProcPragma (PMode (PNWA n as) pmf pmt :~ s) = do - mm <- use pcs_modemap - maybe (pcs_modemap %= M.insert n (as,pmf,pmt,s)) - -- XXX fix this error message once the new trifecta lands upstream - -- with its ability to throw Err. - (\(_,_,_,s') -> unexpected $ "duplicate definition of mode: " - ++ (show n) - ++ "(prior definition at " - ++ (show s') ++ ")" ) - $ M.lookup n mm -pcsProcPragma (p :~ s) = dynacSorry $ "Cannot handle pragma" - PP. (PP.text $ show p) - PP. "at" - PP. prettySpanLoc s +pragmaline :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) + => m Pragma +pragmaline = symbol ":-" + *> whiteSpace + *> (pragmaBody + <|> fmap PMisc (unSpan <$> tfexpr "Other pragma")) + <* whiteSpace + <* {- optional -} (char '.') ------------------------------------------------------------------------}}} -- Lines {{{ -progline :: (MonadState PCS m, DeltaParsing m, LookAheadParsing m) - => m (Spanned Line) -progline = whiteSpace - *> spanned (choice [ LPragma <$> rs dpragma - , LRule <$> spanned parseRule - ]) +dline :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m) + => m (Spanned Line) +dline = whiteSpace + *> spanned (choice [ LPragma <$> pragmaline + , LRule <$> spanned rule + ]) + +configureParser :: (DeltaParsing m, LookAheadParsing m) + => DynaLanguage m a + -> DLCfg + -> m a +configureParser p c = runReaderT (unDL p) c -rawDLine :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Line) -rawDLine = evalStateT (unPCM $ unDL $ progline <* optional whiteSpace) defPCS +-- | The grand Dyna parser. +parse :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m (Spanned Line) +parse = configureParser dline --- XXX REWRITE +------------------------------------------------------------------------}}} +-- Test hooks {{{ -interpretProgline = do - ls@(l :~ s) <- progline - case l of - LPragma p -> pcsProcPragma (p :~ s) >> interpretProgline - _ -> return ls +testTerm :: (DeltaParsing m, LookAheadParsing m) + => DLCfg -> m (Spanned Term) +testTerm = configureParser term -dparse = (unPCM $ unDL $ many (interpretProgline <* optional whiteSpace) <* eof) +testRule :: (DeltaParsing m, LookAheadParsing m) + => DLCfg -> m Rule +testRule = configureParser rule -rawDLines = evalStateT dparse defPCS +testPragma :: (DeltaParsing m, LookAheadParsing m) + => DLCfg -> m Pragma +testPragma = configureParser pragmaBody ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index faeff3a..7e9ad17 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -23,6 +23,12 @@ import qualified Data.ByteString as B -- 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.Term.SurfaceSyntax +import Dyna.Term.TTerm (Annotation(..), TBase(..)) +import Dyna.XXX.TrifectaTest import qualified Test.Framework as TF import Test.Framework.Providers.HUnit import Test.Framework.TH @@ -30,9 +36,6 @@ import Test.HUnit import Text.Trifecta import Text.Trifecta.Delta -import Dyna.ParserHS.Parser -import Dyna.Term.TTerm (Annotation(..), TBase(..)) -import Dyna.XXX.TrifectaTest ------------------------------------------------------------------------}}} -- Terms and basic handling {{{ @@ -40,8 +43,11 @@ import Dyna.XXX.TrifectaTest _tNumeric :: Either Integer Double -> Term _tNumeric = TBase . TNumeric +defDLC :: DLCfg +defDLC = DLC (mkEOT defOperSpec True) + term :: ByteString -> Spanned Term -term = unsafeParse (rawDTerm <* eof) +term = unsafeParse (testTerm defDLC <* eof) case_basicAtom :: Assertion case_basicAtom = e @=? (term "foo") @@ -153,7 +159,7 @@ case_colonFunctor = e @=? (term pvv) -- gs = "gensym(*)" case_failIncompleteExpr :: Assertion -case_failIncompleteExpr = checkParseFail rawDTerm "foo +" +case_failIncompleteExpr = checkParseFail (testTerm defDLC) "foo +" "(interactive):1:5: error: expected: \"(\",\nend of input\nfoo + \n ^ " ------------------------------------------------------------------------}}} @@ -173,109 +179,104 @@ case_tyAnnot = e @=? (term fintx) ------------------------------------------------------------------------}}} -- Rules {{{ -type MRule = (RuleIx, Spanned Term, B.ByteString, Spanned Term) - -manglerule :: Rule -> MRule -manglerule (Rule i h a b _) = (i,h,a,b) +progrule :: ByteString -> Spanned Rule +progrule = unsafeParse (spanned (testRule defDLC <* eof)) -progrule :: ByteString -> Spanned MRule -progrule = fmap manglerule . unsafeParse (rawDRule <* eof) +progrules :: ByteString -> [Spanned Rule] +progrules = unsafeParse (many (spanned (testRule defDLC)) <* eof) -progrules :: ByteString -> [Spanned MRule] -progrules = fmap (fmap manglerule) . unsafeParse (rawDRules <* eof) +oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)] +oneshotRules = xlate . unsafeParse (oneshotDynaParser) + where + xlate (PDP rs) = map (\(i,_,sr) -> (i,sr)) rs case_ruleFact :: Assertion case_ruleFact = e @=? (progrule sr) where - e = ( 0 - , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr - , "&=" - , (TFunctor "true" [] :~ Span (Columns 0 0) (Columns 4 4) sr) - ) :~ ts + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + "&=" + (TFunctor "true" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + :~ ts ts = Span (Columns 0 0) (Columns 5 5) sr sr = "goal." case_ruleSimple :: Assertion case_ruleSimple = e @=? (progrule sr) where - e = ( 0 - , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr - , "+=" - , _tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 9 9) sr - ) :~ ts + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (_tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 9 9) sr) + :~ ts ts = Span (Columns 0 0) (Columns 10 10) sr sr = "goal += 1." --- XXX for some reason parser is fine with "1." but not "0." --- This is almost surely a bug upstream; it's fixed in parsers --- c707806109119e3f54c3064039a4ee2624f18ff1, but that isn't yet cut into a --- release. --- --- case_ruleSimple0 :: Assertion --- case_ruleSimple0 = e @=? (progline sr) --- where --- e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) --- "+=" --- (_tNumeric (Left 0) :~ Span (Columns 8 8) (Columns 9 9) sr) --- :~ ts) --- :~ ts --- ts = Span (Columns 0 0) (Columns 10 10) sr --- sr = "goal += 0." +case_ruleSimple0 :: Assertion +case_ruleSimple0 = e @=? (progrule sr) + where + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (_tNumeric (Left 0) :~ Span (Columns 8 8) (Columns 9 9) sr) + :~ ts + ts = Span (Columns 0 0) (Columns 10 10) sr + sr = "goal += 0." case_ruleExpr :: Assertion case_ruleExpr = e @=? (progrule sr) where - e = ( 0 - , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr - , "+=" - , TFunctor "+" + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (TFunctor "+" [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 12 12) sr ,TFunctor "bar" [] :~ Span (Columns 14 14) (Columns 18 18) sr ] - :~ Span (Columns 8 8) (Columns 18 18) sr - ) :~ ts + :~ Span (Columns 8 8) (Columns 18 18) sr) + :~ ts ts = Span (Columns 0 0) (Columns 19 19) sr sr = "goal += foo + bar ." case_ruleDotExpr :: Assertion case_ruleDotExpr = e @=? (progrule sr) where - e = ( 0 - , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr - , "+=" - , TFunctor "." + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (TFunctor "." [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 11 11) sr ,TFunctor "bar" [] :~ Span (Columns 12 12) (Columns 15 15) sr ] - :~ Span (Columns 8 8) (Columns 15 15) sr - ) :~ ts + :~ Span (Columns 8 8) (Columns 15 15) sr) + :~ ts ts = Span (Columns 0 0) (Columns 16 16) sr sr = "goal += foo.bar." case_ruleComma :: Assertion case_ruleComma = e @=? (progrule sr) where - e = ( 0 - , TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr - , "+=" - , TFunctor "," [TFunctor "bar" [TVar "X" :~ Span (Columns 11 11) (Columns 12 12) sr] + e = Rule + (TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + "+=" + (TFunctor "," [TFunctor "bar" [TVar "X" :~ Span (Columns 11 11) (Columns 12 12) sr] :~ Span (Columns 7 7) (Columns 13 13) sr ,TFunctor "," [TFunctor "baz" [TVar "X" :~ Span (Columns 19 19) (Columns 20 20) sr] :~ Span (Columns 15 15) (Columns 21 21) sr ,TVar "X" :~ Span (Columns 23 23) (Columns 24 24) sr] :~ Span (Columns 15 15) (Columns 24 24) sr] - :~ Span (Columns 7 7) (Columns 24 24) sr - ) :~ ts + :~ Span (Columns 7 7) (Columns 24 24) sr) + :~ ts ts = Span (Columns 0 0) (Columns 25 25) sr sr = "foo += bar(X), baz(X), X." case_ruleKeywordsComma :: Assertion case_ruleKeywordsComma = e @=? (progrule sr) where - e = ( 0 - , TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr - , "=" - , TFunctor "whenever" [TFunctor "new" [TVar "X" :~ Span (Columns 10 10) (Columns 12 12) sr] + e = Rule + (TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + "=" + (TFunctor "whenever" [TFunctor "new" [TVar "X" :~ Span (Columns 10 10) (Columns 12 12) sr] :~ Span (Columns 6 6) (Columns 12 12) sr ,TFunctor "," [TFunctor "is" [TVar "X" :~ Span (Columns 21 21) (Columns 23 23) sr ,TFunctor "baz" [TVar "Y" :~ Span (Columns 30 30) (Columns 31 31) sr] @@ -285,71 +286,95 @@ case_ruleKeywordsComma = e @=? (progrule sr) ,_tNumeric (Left 3) :~ Span (Columns 39 39) (Columns 41 41) sr] :~ Span (Columns 34 34) (Columns 41 41) sr] :~ Span (Columns 21 21) (Columns 41 41) sr] -- End "whenever" - :~ Span (Columns 6 6) (Columns 41 41) sr -- End expression - ) :~ ts + :~ Span (Columns 6 6) (Columns 41 41) sr) -- End expression + :~ ts ts = Span (Columns 0 0) (Columns 42 42) sr sr = "foo = new X whenever X is baz(Y), Y is 3 ." case_rules :: Assertion case_rules = e @=? (progrules sr) where - e = [ ( 0 - , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr - , "+=" - , _tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 10 10) sr - ) :~ s1 - , ( 1 - , TFunctor "laog" [] :~ Span (Columns 12 12) (Columns 17 17) sr - , "min=" - , _tNumeric (Left 2) :~ Span (Columns 22 22) (Columns 24 24) sr - ) :~ s2 + e = [ Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (_tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 10 10) sr) + :~ s1 + , Rule + (TFunctor "laog" [] :~ Span (Columns 12 12) (Columns 17 17) sr) + "min=" + (_tNumeric (Left 2) :~ Span (Columns 22 22) (Columns 24 24) sr) + :~ s2 ] s1 = Span (Columns 0 0) (Columns 11 11) sr - s2 = Span (Columns 12 12) (Columns 25 25) sr + s2 = Span (Columns 11 11) (Columns 25 25) sr sr = "goal += 1 . laog min= 2 ." +case_rules_ruleix_pragmas :: Assertion +case_rules_ruleix_pragmas = e @=? (oneshotRules sr) + where + e = [ ( 5 + , Rule + (TFunctor "goal" [] :~ Span (Columns 13 13) (Columns 18 18) sr) + "+=" + (_tNumeric (Left 1) :~ Span (Columns 21 21) (Columns 22 22) sr) + :~ s1 + ) + , ( 6 + , Rule + (TFunctor "laog" [] :~ Span (Columns 24 24) (Columns 29 29) sr) + "min=" + (_tNumeric (Left 2) :~ Span (Columns 34 34) (Columns 35 35) sr) + :~ s2 + ) + ] + + s1 = Span (Columns 13 13) (Columns 23 23) sr + s2 = Span (Columns 24 24) (Columns 36 36) sr + sr = ":- ruleix 5. goal += 1. laog min= 2." + + case_rulesWhitespace :: Assertion case_rulesWhitespace = e @=? (progrules sr) where - e = [ ( 0 - , TFunctor "goal" [] :~ Span (Columns 2 2) (Lines 1 1 16 1) l0 - , "+=" - , _tNumeric (Left 1) :~ Span (Lines 1 4 19 4) (Lines 1 6 21 6) l1 - ) :~ s1 - , ( 1 - , TFunctor "goal" [] :~ Span (Lines 3 1 31 1) (Lines 3 6 36 6) l3 - , "+=" - , _tNumeric (Left 2) :~ Span (Lines 3 9 39 9) (Lines 3 11 41 11) l3 - ) :~ s2 + e = [ Rule + (TFunctor "goal" [] :~ Span (Columns 2 2) (Lines 1 1 16 1) l0) + "+=" + (_tNumeric (Left 1) :~ Span (Lines 1 4 19 4) (Lines 1 6 21 6) l1) + :~ s1 + , Rule + (TFunctor "goal" [] :~ Span (Lines 3 1 31 1) (Lines 3 6 36 6) l3) + "+=" + (_tNumeric (Left 2) :~ Span (Lines 3 9 39 9) (Lines 3 11 41 11) l3) + :~ s2 ] l0 = " goal%comment\n" l1 = " += 1 .\n" l2 = "%test \n" - l3 = " goal += 2 . " + l3 = " goal += 2 ." s1 = Span (Columns 0 0) (Lines 1 7 22 7) l0 - s2 = Span (Lines 3 1 31 1) (Lines 3 12 42 12) l3 + s2 = Span (Lines 1 7 22 7) (Lines 3 12 42 12) l1 sr = B.concat [l0,l1,l2,l3] case_rulesDotExpr :: Assertion case_rulesDotExpr = e @=? (progrules sr) where - e = [ ( 0 - , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr - , "+=" - , TFunctor "." + e = [ Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (TFunctor "." [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 11 11) sr ,TFunctor "bar" [] :~ Span (Columns 12 12) (Columns 15 15) sr ] - :~ Span (Columns 8 8) (Columns 15 15) sr - ) :~ s1 - , ( 1 - , TFunctor "goal" [] :~ Span (Columns 17 17) (Columns 22 22) sr - , "+=" - , _tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr - ) :~ s2 + :~ Span (Columns 8 8) (Columns 15 15) sr) + :~ s1 + , Rule + (TFunctor "goal" [] :~ Span (Columns 17 17) (Columns 22 22) sr) + "+=" + (_tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr) + :~ s2 ] s1 = Span (Columns 0 0) (Columns 16 16) sr - s2 = Span (Columns 17 17) (Columns 28 28) sr + s2 = Span (Columns 16 16) (Columns 28 28) sr sr = "goal += foo.bar. goal += 1 ." ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Term/SurfaceSyntax.hs b/src/Dyna/Term/SurfaceSyntax.hs index cb8e2d1..77ce614 100644 --- a/src/Dyna/Term/SurfaceSyntax.hs +++ b/src/Dyna/Term/SurfaceSyntax.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.UTF8 as BU import qualified Data.Char as C import qualified Data.Map as M import Dyna.Term.TTerm +import Text.Parser.Expression (Assoc(..)) ------------------------------------------------------------------------}}} -- Keywords {{{ @@ -28,6 +29,48 @@ dynaConjOper = "," dynaRevConjOpers = ["whenever","for"] dynaUnitTerm = "true" +------------------------------------------------------------------------}}} +-- Operators {{{ + +data Fixity = PFIn Assoc | PFPre | PFPost + deriving (Eq,Show) + +-- | For each possible operator symbol, specify its precedence and fixity. +-- +-- For the precedence, a higher number means tighter binding. +type OperSpec = M.Map String [(Int, Fixity)] + +-- | The basic expression table for limited expressions. +-- +-- Notably, this excludes @,@ (which is important +-- syntactically), @for@, @whenever@, and @is@ (which are +-- nonsensical in local context) +-- +-- The precedence and fixity here are mostly as per Haskell 98. +defOperSpec :: OperSpec +defOperSpec = M.fromList + [ ("-" ,[(6,PFIn AssocLeft ), (9, PFPre)]) + , ("^" ,[(8,PFIn AssocLeft ) ]) + , ("|" ,[(2,PFIn AssocRight) ]) + , ("/" ,[(7,PFIn AssocLeft ) ]) + , ("*" ,[(7,PFIn AssocLeft ) ]) + , ("**" ,[(8,PFIn AssocRight) ]) + , ("&" ,[(3,PFIn AssocRight) ]) + , ("%" ,[(7,PFIn AssocLeft ) ]) + , ("+" ,[(6,PFIn AssocLeft ) ]) + + , ("<=" ,[(4,PFIn AssocNone ) ]) + , ("<" ,[(4,PFIn AssocNone ) ]) + , ("=" ,[(4,PFIn AssocNone ) ]) + , (">=" ,[(4,PFIn AssocNone ) ]) + , (">" ,[(4,PFIn AssocNone ) ]) + , ("!=" ,[(4,PFIn AssocNone ) ]) + + , ("!" ,[(9,PFPre) ]) + + , ("new",[(0,PFPre)]) + ] + ------------------------------------------------------------------------}}} -- Evaluation Disposition {{{ -- Definition {{{ diff --git a/src/Dyna/XXX/MonadUtils.hs b/src/Dyna/XXX/MonadUtils.hs index 46207c1..9d1c069 100644 --- a/src/Dyna/XXX/MonadUtils.hs +++ b/src/Dyna/XXX/MonadUtils.hs @@ -4,11 +4,12 @@ module Dyna.XXX.MonadUtils( -- * Logic utilities andM, andM1, orM, orM1, allM, anyM, -- * MonadState utilities - bracketState, incState, + bracketState, incState, readState, ) where -- import Control.Applicative import Control.Lens +import Control.Monad.Reader import Control.Monad.State import qualified Data.Map as M import qualified Data.Set as S @@ -55,3 +56,7 @@ bracketState bs m = do incState :: (Num a, MonadState a m) => m a incState = id <<%= (+1) + +readState :: (MonadState a m) => ReaderT a m b -> m b +readState x = get >>= runReaderT x + diff --git a/src/Dyna/XXX/TrifectaTest.hs b/src/Dyna/XXX/TrifectaTest.hs index d2da3c4..7c4fd56 100644 --- a/src/Dyna/XXX/TrifectaTest.hs +++ b/src/Dyna/XXX/TrifectaTest.hs @@ -7,7 +7,6 @@ import Data.ByteString (ByteString) import Data.Monoid (mempty) import Test.HUnit import Text.Trifecta -import Text.Trifecta.Result import qualified Text.PrettyPrint.ANSI.Leijen as PPA unsafeFS :: Result t -> t @@ -26,7 +25,7 @@ unsafeFF e (Failure td) = e @=? flip PPA.displayS "" filterSD (PPA.SLine i x) = PPA.SLine i (filterSD x) filterSD (PPA.SSGR _ x) = filterSD x -unsafeParse :: (Show a) => (Parser a) -> ByteString -> a +unsafeParse :: (Parser a) -> ByteString -> a unsafeParse p = unsafeFS . parseByteString (p <* eof) mempty -- XXX this fails to properly check the last argument of the "Diagnostic"s -- 2.50.1