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.
-- 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,
-- 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,
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,
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,
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
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
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
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)
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
--- /dev/null
+---------------------------------------------------------------------------
+-- | 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
+
+------------------------------------------------------------------------}}}
-- 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
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]
-- 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)
ParsedModeInst
-- ^ Declare a mode: name, input, and output
- | POperAdd PragmaFixity Integer B.ByteString
+ | POperAdd Fixity Integer B.ByteString
-- ^ Add an operator
| POperDel B.ByteString
| 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
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.
=> 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 {{{
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
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 {{{
, _styleReservedHighlight = ReservedOperator
}
+{-
-- | Comma operators
dynaCommaOperStyle :: TokenParsing m => IdentifierStyle m
dynaCommaOperStyle = IdentifierStyle
, _styleHighlight = Operator
, _styleReservedHighlight = ReservedOperator
}
+-}
-- | Prefix operators
--
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"
------------------------------------------------------------------------}}}
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
-}
-- | 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)
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 ]
]
-- | 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 {{{
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"
]
}
+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)
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
------------------------------------------------------------------------}}}
-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
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
<*> (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
------------------------------------------------------------------------}}}
-- 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
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 {{{
_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")
-- 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 +<EOF> \n ^ "
------------------------------------------------------------------------}}}
------------------------------------------------------------------------}}}
-- 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]
,_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 ."
------------------------------------------------------------------------}}}
import qualified Data.Char as C
import qualified Data.Map as M
import Dyna.Term.TTerm
+import Text.Parser.Expression (Assoc(..))
------------------------------------------------------------------------}}}
-- Keywords {{{
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 {{{
-- * 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
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
+
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
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
projects / dyna2 / commitdiff