From f8d378464e56ca588585610512e9814b85f14f1e Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 4 Jun 2013 15:41:33 -0400 Subject: [PATCH] Some work towards resumable parsing --- src/Dyna/Analysis/Mode/InstPretty.hs | 10 +++ src/Dyna/ParserHS/OneshotDriver.hs | 68 ++++++++++------ src/Dyna/ParserHS/Parser.hs | 112 ++++++++++++++++++++++----- src/Dyna/ParserHS/Selftest.hs | 23 ++++++ 4 files changed, 168 insertions(+), 45 deletions(-) diff --git a/src/Dyna/Analysis/Mode/InstPretty.hs b/src/Dyna/Analysis/Mode/InstPretty.hs index 98bbad3..be19e93 100644 --- a/src/Dyna/Analysis/Mode/InstPretty.hs +++ b/src/Dyna/Analysis/Mode/InstPretty.hs @@ -2,6 +2,9 @@ -- | Functions for pretty-printing Insts -- -- Intended to be imported qualified +-- +-- XXX Maybe some of the parser's handling of insts should end up over here, +-- too? -- Header material {{{ {-# LANGUAGE OverloadedStrings #-} @@ -19,6 +22,13 @@ compactUniq UMostlyUnique = "mu" compactUniq UShared = "sh" compactUniq UMostlyClobbered = "mc" compactUniq UClobbered = "cl" + +fullUniq :: (IsString a) => Uniq -> a +fullUniq UUnique = "unique" +fullUniq UMostlyUnique = "mostlyunique" +fullUniq UShared = "shared" +fullUniq UMostlyClobbered = "mostlyclobbered" +fullUniq UClobbered = "clobbered" compactly :: (f -> Doc e) -> (a -> Doc e) diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs index 0735f0b..5d8d3fc 100644 --- a/src/Dyna/ParserHS/OneshotDriver.hs +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -12,6 +12,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Dyna.ParserHS.OneshotDriver where @@ -36,19 +37,22 @@ import qualified Text.PrettyPrint.Free as PP -- Output {{{ data ParsedDynaProgram = PDP - { _pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)] - , _pdp_next_rix :: RuleIx + { pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)] + + -- | A rather ugly hack for resumable parsing: this records the set of + -- pragmas to restore the current PCS. + , pdp_parser_resume :: forall e . PP.Doc e } ------------------------------------------------------------------------}}} -- Driver state {{{ --- | Configuration state threaded into the parser --- --- Note that this type is hidden with the exception of some accessors below. +-- | Parser Configuration State data PCS = PCS - { _pcs_dt_mk :: DisposTabOver -> DisposTab + { _pcs_dt_mk :: String , _pcs_dt_over :: DisposTabOver + , _pcs_dt_cache :: DisposTab + -- ^ Cache the disposition table , _pcs_instmap :: M.Map B.ByteString ([DVar] ,ParsedInst ,Span) @@ -72,7 +76,14 @@ $(makeLenses ''PCS) _pcs_dlc pcs = DLC (_pcs_opertab pcs) -pcs_dt = liftA2 ($) (use pcs_dt_mk) (use pcs_dt_over) +update_pcs_dt = pcs_dt_cache <<~ + liftA2 ($) (uses pcs_dt_mk dtmk) (use pcs_dt_over) + +dtmk "dyna" = disposTab_dyna +dtmk "prologish" = disposTab_dyna +dtmk n = dynacPanic $ "Unknown default disposition table:" + PP. PP.pretty n + newtype PCM im a = PCM { unPCM :: StateT PCS im a } deriving (Alternative,Applicative,CharParsing,DeltaParsing, @@ -84,12 +95,17 @@ instance (Monad im) => MonadState PCS (PCM im) where state = PCM . state defPCS :: PCS -defPCS = PCS { _pcs_dt_mk = disposTab_dyna +defPCS = PCS { _pcs_dt_mk = "dyna" , _pcs_dt_over = mempty + , _pcs_dt_cache = dtmk (defPCS ^. pcs_dt_mk) + (defPCS ^. pcs_dt_over) + , _pcs_instmap = mempty -- XXX , _pcs_modemap = mempty -- XXX + , _pcs_operspec = defOperSpec , _pcs_opertab = mkEOT (defPCS ^. pcs_operspec) True + , _pcs_ruleix = 0 } @@ -97,13 +113,12 @@ defPCS = PCS { _pcs_dt_mk = disposTab_dyna pcsProcPragma :: (Parsing m, MonadState PCS m) => Spanned Pragma -> m () pcsProcPragma (PDispos s f as :~ _) = do pcs_dt_over %= dtoMerge (f,length as) (s,as) + update_pcs_dt + return () 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 + pcs_dt_mk .= n + update_pcs_dt + return () pcsProcPragma (PInst (PNWA n as) pi :~ s) = do im <- use pcs_instmap maybe (pcs_instmap %= M.insert n (as,pi,s)) @@ -131,6 +146,9 @@ pcsProcPragma (p :~ s) = dynacSorry $ "Cannot handle pragma" PP. "at" PP. prettySpanLoc s +-- XXX +pragmasFromPCS pcs = empty + nextRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) => m (Spanned Rule) nextRule = do @@ -139,16 +157,18 @@ nextRule = do 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 +oneshotDynaParser :: (DeltaParsing m, LookAheadParsing m) + => m ParsedDynaProgram +oneshotDynaParser = (postProcess =<<) + $ flip runStateT defPCS + $ many $ do + r <- nextRule + rix <- pcs_ruleix <<%= (+1) + dt <- use pcs_dt_cache + return $ (rix, dt, r) + <* whiteSpace where - postProcess (rs,pcs) = return $ PDP rs (pcs^.pcs_ruleix) + postProcess (rs,pcs) = return $ PDP rs (pragmasFromPCS pcs) + ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index f752bf7..ba854a5 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -45,7 +45,7 @@ module Dyna.ParserHS.Parser ( -- ** Surface langauge Term(..), Rule(..), -- ** Pragmas - ParsedInst(..), ParsedModeInst, Pragma(..), + ParsedInst(..), ParsedModeInst, Pragma(..), renderPragma, -- ** Line Line(..), -- * Action @@ -69,19 +69,20 @@ import qualified Data.Map as M import Data.Semigroup ((<>)) import Data.Monoid (mempty) import Dyna.Analysis.Mode.Inst +import qualified Dyna.Analysis.Mode.InstPretty as IP import Dyna.Analysis.Mode.Uniq import Dyna.Main.Defns import Dyna.Term.TTerm (Annotation(..), TBase(..), - DFunct, DFunctAr) + DFunct) import Dyna.Term.SurfaceSyntax import Dyna.XXX.DataUtils import Dyna.XXX.Trifecta (identNL, - stringLiteralSQ,unSpan) + stringLiteralSQ) 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 ------------------------------------------------------------------------}}} @@ -132,7 +133,7 @@ data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] | POperDel B.ByteString -- ^ Remove an operator - | PQMode DFunctAr + -- | PQMode DFunctAr -- ^ A query mode declaration | PRuleIx RuleIx @@ -144,7 +145,7 @@ data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] -- interpreted. Eventually this will go away, when our -- REPLs have captive compilers. - | PMisc Term + -- | PMisc Term -- ^ Fall-back parser for :- lines. deriving (Eq,Show) @@ -532,7 +533,7 @@ parseInst = choice [ PIVar <$> var , symbol "free" *> pure (PIInst IFree) , symbol "any" *> (PIInst . IAny <$> optUniq) , symbol "ground" *> (PIInst . IUniv <$> optUniq) - , symbol "bound" *> boundinst UShared + , symbol "bound" *> (optBUniq >>= boundinst) -- Some uniques are acceptable in this context and have -- slightly different meanings @@ -542,7 +543,8 @@ parseInst = choice [ PIVar <$> var , symbol "clobbered" *> pure (PIInst (IUniv UClobbered)) ] where - optUniq = parens ( parseUniq ) <|> pure UShared + optUniq = parens ( parseUniq ) <|> pure UShared + optBUniq = brackets ( parseUniq ) <|> pure UShared -- XXX this $base thing is pretty bad. Suggestions are welcome. boundinst u = braces $ (PIInst <$>) $ @@ -562,13 +564,14 @@ parseUniq = choice [ symbol "clobbered" *> pure UClobbered ] ------------------------------------------------------------------------}}} +-- Parsing pragma bodies {{{ -pragmaBody :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m) +pragmaBody :: (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 "dispos_def" *> parseDisposDefl -- set default dispositions + , symbol "dispos" *> parseDisposition -- in-place dispositions , symbol "inst" *> parseInstDecl -- instance delcarations , symbol "mode" *> parseMode -- mode/qmode decls , symbol "oper" *> parseOper -- new {pre,in,post}fix oper @@ -638,15 +641,82 @@ pragmaBody = choice <* symbol ">>" <*> (Right <$> parseInst <|> Left <$> parseNameWithArgs instName) +------------------------------------------------------------------------}}} +-- Printing pragma bodies {{{ + +renderFunctor :: B.ByteString -> PP.Doc e +renderFunctor f = PP.squotes (PP.pretty f) + +renderInst :: ParsedInst -> PP.Doc e +renderInst (PIVar v) = PP.pretty v +renderInst (PIInst IFree) = "free" +renderInst (PIInst (IAny u)) = "any" PP.<> PP.parens (IP.fullUniq u) +renderInst (PIInst (IUniv u)) = "ground" PP.<> PP.parens (IP.fullUniq u) +renderInst (PIInst (IBound u m b)) = + "bound" PP.<> PP.brackets (IP.fullUniq u) + PP.<> (if b then "$base" PP.<> PP.semi else PP.empty) + PP.<> (PP.encloseSep PP.lparen PP.rparen PP.semi + $ map (\(k,v) -> PP.pretty k PP.<> PP.tupled (map renderInst v)) + $ M.toList m) + +renderMode :: ParsedModeInst -> PP.Doc e +renderMode = either renderPNWA renderInst + +renderPNWA :: NameWithArgs -> PP.Doc e +renderPNWA (PNWA n as) = PP.pretty n PP.<> PP.tupled (map PP.pretty as) + +renderPragma_ :: Pragma -> PP.Doc e +renderPragma_ (PDisposDefl s) = "dispos_def" PP.<+> PP.text s + +renderPragma_ (PDispos s f as) = "dispos" PP.<+> rs s + PP.<> renderFunctor f + PP.<> PP.tupled (map ra as) + where + rs SDInherit = PP.empty + rs SDQuote = "&" + rs SDEval = "*" -pragmaline :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) - => m Pragma -pragmaline = symbol ":-" - *> whiteSpace - *> (pragmaBody - <|> fmap PMisc (unSpan <$> tfexpr "Other pragma")) - <* whiteSpace - <* {- optional -} (char '.') + ra ADQuote = "&" + ra ADEval = "*" + +renderPragma_ (PInst n i) = "inst" PP.<+> renderPNWA n + PP.<+> renderInst i + +renderPragma_ (POperAdd f i n) = "oper" PP.<+> "add" + PP.<+> rf f + PP.<+> PP.pretty i + PP.<+> PP.pretty n + where + rf PFPre = "pre" + rf PFPost = "post" + rf (PFIn a) = "in" PP.<+> ra a + + ra AssocLeft = "left" + ra AssocNone = "none" + ra AssocRight = "right" + +renderPragma_ (POperDel n) = "oper" PP.<+> "del" PP.<+> PP.pretty n + +renderPragma_ (PMode n i o) = "mode" PP.<+> renderPNWA n + PP.<+> renderMode i + PP.<+> renderMode o + +renderPragma_ (PRuleIx r) = "ruleix" PP.<+> PP.pretty r + +renderPragma :: Pragma -> PP.Doc e +renderPragma = PP.enclose ":-" PP.dot . renderPragma_ + +------------------------------------------------------------------------}}} + +pragma :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) + => m Pragma +pragma = symbol ":-" + *> whiteSpace + *> (pragmaBody + -- <|> fmap PMisc (unSpan <$> tfexpr "Other pragma") + ) + <* whiteSpace + <* {- optional -} (char '.') ------------------------------------------------------------------------}}} @@ -655,7 +725,7 @@ pragmaline = symbol ":-" dline :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m) => m (Spanned Line) dline = whiteSpace - *> spanned (choice [ LPragma <$> pragmaline + *> spanned (choice [ LPragma <$> pragma , LRule <$> spanned rule ]) @@ -686,6 +756,6 @@ testRule = configureParser rule testPragma :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m Pragma -testPragma = configureParser pragmaBody +testPragma = configureParser pragma ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 706096b..ae4ad69 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -32,8 +32,11 @@ import Dyna.Term.TTerm (Annotation(..), TBase(..)) import Dyna.XXX.TrifectaTest import Test.Framework as TF import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 import Test.Framework.TH import Test.HUnit as H +import qualified Text.PrettyPrint.Free as PP +import Test.QuickCheck as Q import Text.Trifecta import Text.Trifecta.Delta @@ -413,6 +416,26 @@ case_rulesDotExpr = e @=? (progrules sr) s2 = Span (Columns 16 16) (Columns 28 28) sr sr = "goal += foo.bar. goal += 1 ." +------------------------------------------------------------------------}}} +-- Pragmas {{{ + +arbPragma :: Gen Pragma +arbPragma = oneof + [ PDispos <$> arbSD <*> arbAtom <*> listOf arbAD + , PDisposDefl <$> elements ["dyna", "prologish"] + ] + where + arbSD = elements [SDInherit, SDEval, SDQuote] + arbAD = elements [ADEval, ADQuote] + + arbAtom = elements [ "f", "+" ] + +prop_pragma_roundtrip = + forAll arbPragma (\p -> p == unsafeParse (testPragma defDLC) + (BU.fromString + (flip PP.displayS "" $ PP.renderCompact + $ renderPragma p))) + ------------------------------------------------------------------------}}} -- Harness toplevel {{{ -- 2.50.1