{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Dyna.ParserHS.OneshotDriver where
-- 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)
_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,
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
}
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))
PP.<//> "at"
PP.<//> prettySpanLoc s
+-- XXX
+pragmasFromPCS pcs = empty
+
nextRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m)
=> m (Spanned Rule)
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)
+
------------------------------------------------------------------------}}}
-- ** Surface langauge
Term(..), Rule(..),
-- ** Pragmas
- ParsedInst(..), ParsedModeInst, Pragma(..),
+ ParsedInst(..), ParsedModeInst, Pragma(..), renderPragma,
-- ** Line
Line(..),
-- * Action
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
------------------------------------------------------------------------}}}
| POperDel B.ByteString
-- ^ Remove an operator
- | PQMode DFunctAr
+ -- | PQMode DFunctAr
-- ^ A query mode declaration
| PRuleIx RuleIx
-- interpreted. Eventually this will go away, when our
-- REPLs have captive compilers.
- | PMisc Term
+ -- | PMisc Term
-- ^ Fall-back parser for :- lines.
deriving (Eq,Show)
, 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
, 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 <$>) $
]
------------------------------------------------------------------------}}}
+-- 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
<* 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 '.')
------------------------------------------------------------------------}}}
dline :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m)
=> m (Spanned Line)
dline = whiteSpace
- *> spanned (choice [ LPragma <$> pragmaline
+ *> spanned (choice [ LPragma <$> pragma
, LRule <$> spanned rule
])
testPragma :: (DeltaParsing m, LookAheadParsing m)
=> DLCfg -> m Pragma
-testPragma = configureParser pragmaBody
+testPragma = configureParser pragma
------------------------------------------------------------------------}}}
projects / dyna2 / commitdiff