{-# OPTIONS_GHC -cpp -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse -fallow-overlapping-instances -fno-warn-orphans #-}
module Pugs.Parser.Operator where
import Pugs.Internals
import Pugs.AST
import Pugs.Types
import Pugs.Lexer
import Pugs.Rule
import {-# SOURCE #-} Pugs.Parser
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as Buf
import qualified Data.HashTable as H
import GHC.Int (Int32(I32#))
import Pugs.Parser.Types
import Pugs.Parser.Unsafe
listCons :: [RuleOperator Exp]
listCons = listSyn (opWords ",") -- List constructor
listInfix :: [RuleOperator Exp]
listInfix = listOps (opWords "Y \xA5 ==> <==") -- List infix
opWords :: String -> Set OpName
opWords xs = Set.fromList (map (MkOpName . cast) (words xs))
newtype OpName = MkOpName ID
deriving (Show, Eq, Typeable, (:>:) String, (:>:) ByteString, (:<:) ByteString, (:>:) ID)
instance Ord OpName where
compare (MkOpName MkID{ idKey = a, idBuf = x }) (MkOpName MkID{ idKey = b, idBuf = y })
= compare (Buf.length y) (Buf.length x) `mappend` compare b a
-- Not yet transcribed into a full optable parser with dynamic precedence --
tightOperators :: RuleParser (TightFunctions, RuleOperatorTable Exp)
tightOperators = do
tights <- currentTightFunctions
return $ (,) tights
( termLevel -- Terms and circumfixes
: methLevel -- Method postfix
: incrLevel -- Auto-Increment
: expoLevel -- Exponentiation
: (preSymOps (r_pre tights) -- Symbolic Unary (user-definable)
++ postOps (r_post tights)
++ symbLevel)
: multLevel -- Multiplicative
: Map.foldWithKey foldInfix addiLevel (r_infix tights) -- Additive (user-definable)
: junaLevel -- Junctive And
: junoLevel -- Junctive Or
: (optOps (r_opt tights) -- Named Unary (user-definable)
++ preOps (r_named tights Set.\\ opWords " true not ")
++ fileTestOps
)
: staticLevels
)
where
foldInfix :: OpName -> SubAssoc -> [RuleOperator Exp] -> [RuleOperator Exp]
foldInfix op assoc xs = let op' = Set.singleton op in case assoc of
A_left -> leftOps op' ++ xs
A_right -> rightOps op' ++ xs
A_non -> nonOps op' ++ xs
A_chain -> chainOps op' ++ xs
A_list -> listOps op' ++ xs
_ -> leftOps op' ++ xs -- Default to left-assoc
-- _ -> error $ "Impossible: " ++ show op ++ " has no assoc?"
termLevel, methLevel, incrLevel, expoLevel, symbLevel, multLevel, addiLevel, junaLevel, junoLevel :: [RuleOperator Exp]
termLevel = circumOps (Set.singleton (MkOpName (cast "\\( )")))
methLevel = methOps (opWords " . .+ .? .* .+ .() .[] .{} .<<>> .= ")
incrLevel = postOps incrOps ++ preOps incrOps
expoLevel = rightOps (opWords " ** ")
symbLevel = preSyn (Set.singleton (MkOpName (cast "|"))) ++ preOps symbPreops
multLevel = leftOps (opWords " * / % x xx +& +< +> ~& ~< ~> ?& ")
addiLevel = leftOps (opWords " + - ~ +| +^ ~| ~^ ?| ")
junaLevel = listOps (opWords " & ")
junoLevel = listOps (opWords " ^ | ")
symbPreops :: Set OpName
symbPreops = opWords " = ! + - ~ ? +^ ~^ ?^ \\ ^"
incrOps :: Set OpName
incrOps = opWords " ++ -- "
-- The lower levels of immutable ops. This will be replaced once we have
-- user-defineable precedences.
staticLevels :: [[RuleOperator Exp]]
staticLevels =
[ nonSyn (opWords " but does ") -- Traits
++ nonOps (opWords " leg cmp <=> .. ^.. ..^ ^..^ ff ^ff ff^ ^ff^ fff ^fff fff^ ^fff^ ") -- Non-chaining Binary
, chainOps (opWords " != == < <= > >= eqv eq ne lt le gt ge =:= === ")
++ matchOps (opWords " ~~ ")
, leftOps (opWords "&&") -- Tight And
, leftOps (opWords " || ^^ // ") -- Tight Or
, [ternOp "??" "!!" "if"] -- Ternary
-- Assignment
, (rightOps (opWords " => ") ++) . -- Pair constructor
(DependentPostfix listAssignment :) .
(DependentPostfix immediateBinding :) .
(rightAssignSyn :) .
(rightDotAssignSyn :) $
rightSyn infixAssignmentOps
, preOps (opWords " true not ") -- Loose unary
]
fileTestOps :: [RuleOperator Exp]
fileTestOps = optSymOps (Set.fromAscList (map (MkOpName . cast . (\x -> ['-', x])) fileTestOperatorNames))
infixAssignmentOps :: Set OpName
infixAssignmentOps = opWords
( " := ~= += -= *= /= %= x= Y= \xA5= **= xx= ||= &&= //= ^^= "
++ " +<= +>= ~<= ~>= +&= +|= +^= ~&= ~|= ~^= ?|= ?^= |= ^= &= "
)
fromSet :: Set OpName -> [String]
fromSet = cast . Set.toAscList
listAssignment :: Exp -> RuleParser Exp
listAssignment x = do
try $ do
char '='
guard (not (isScalarLValue x))
notFollowedBy (oneOf "=>" <|> (char ':' >> char '='))
whiteSpace
y <- parseExpWithTightOps
rhs <- option y $ do
-- If we see comma, then convert this to a Syn ",".
ruleComma
ys <- parseExpWithTightOps `sepEndBy` ruleComma
return (Syn "," (y:ys))
return (Syn "=" [forceParens x, rhs])
where
-- XXX - Special casing ($x) = 1,2,3 to ($x,) = 1,2,3
forceParens exp@(Ann Parens inner)
| Syn "," _ <- unwrap exp = exp
| otherwise = Ann Parens (Syn "," [inner])
forceParens (Ann x inner) = Ann x (forceParens inner)
forceParens (Sym x y inner) = Sym x y (forceParens inner)
forceParens (Pad x y inner) = Pad x y (forceParens inner)
forceParens exp = exp
immediateBinding :: Exp -> RuleParser Exp
immediateBinding x = do
symbol "::="
y <- parseExpWithTightOps
unsafeEvalExp (Syn ":=" [x, y])
return x
looseOperators :: RuleParser (RuleOperatorTable Exp)
looseOperators = do
-- names <- currentListFunctions
return $
[ -- preOps names -- List Operator
leftOps (opWords " ==> ") -- Pipe Forward
, leftOps (opWords " and ") -- Loose And
, leftOps (opWords " or xor err ") -- Loose Or
]
data CurrentFunction = MkCurrentFunction
{ f_var :: !Var
, f_assoc :: !SubAssoc
, f_params :: !Params
}
deriving (Show)
-- Read just the current state (i.e. not actually consuming anything)
currentFunctions :: RuleParser [CurrentFunction]
currentFunctions = do
env <- getRuleEnv
let funs = catMaybes $! inlinePerformSTM $! do
glob <- readTVar $ envGlobal env
let syms = padToList (filterPad cur glob)
++ padToList (filterPad cur (envLexical env))
pkg = envPackage env
cur var@MkVar{ v_sigil = SCode } = inScope pkg var
cur _ = False
vars = concat [ map (\(_, tvar) -> (var, tvar)) tvars
| (var, tvars) <- syms
]
mapM (uncurry filterFun) vars
return (length funs `seq` funs)
{-# NOINLINE _RefToFunction #-}
_RefToFunction :: H.HashTable (TVar VRef) CurrentFunction
_RefToFunction = unsafePerformIO (H.new (==) hashTVar)
hashTVar :: TVar VRef -> Int32
hashTVar x = I32# (unsafeCoerce# x)
filterFun :: Var -> TVar VRef -> STM (Maybe CurrentFunction)
filterFun var tvar = do
res <- unsafeIOToSTM (H.lookup _RefToFunction tvar)
case res of
Just rv -> return (rv `seq` res)
Nothing -> do
ref <- readTVar tvar
case ref of
MkRef (ICode cv)
| relevantToParsing (code_type cv) (code_assoc cv) -> do
let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)
unsafeIOToSTM (H.insert _RefToFunction tvar rv)
return (rv `seq` Just rv)
MkRef (IScalar sv)
| Just (VCode cv) <- scalar_const sv
, relevantToParsing (code_type cv) (code_assoc cv) -> do
let rv = MkCurrentFunction var (code_assoc cv) (code_params cv)
unsafeIOToSTM (H.insert _RefToFunction tvar rv)
return (rv `seq` Just rv)
_ -> return Nothing
inScope :: Pkg -> Var -> Bool
inScope pkg var
| isGlobalVar var = True
| not (isQualifiedVar var) = True
| pkg == varPkg = True
| listPkg == varPkg = True -- XXX wrong - special case for List::*
| otherwise = False
where
varPkg = v_package var
relevantToParsing :: SubType -> SubAssoc -> Bool
relevantToParsing SubMethod _ = False
relevantToParsing SubPrim ANil = True
relevantToParsing SubPrim _ = False
relevantToParsing _ AIrrelevantToParsing = False
relevantToParsing _ _ = True
-- XXX Very bad hacky kluge just for Parser.Operator
-- Switch to macro export for push(@x, 1) instead!
listPkg :: Pkg
listPkg = cast (mkType "List")
-- read just the current state
currentTightFunctions :: RuleParser TightFunctions
currentTightFunctions = do
funs <- currentFunctions
let finalResult = foldr splitUnary termResult unary
termResult = foldr splitTerm initResult maybeTerm
initResult = MkTightFunctions emptySet emptySet emptySet emptySet emptyMap infixOps
(unary, notUnary) = partition matchUnary funs
slurpyNames = namesFrom (filter matchSlurpy notUnary)
(maybeTerm, notTerm)= partition matchTerm funs
nonTermNames = namesFrom notTerm
infixOps = Map.fromList
[ (MkOpName name, assoc)
| MkCurrentFunction { f_var = MkVar { v_categ = C_infix, v_name = name }, f_assoc = assoc } <- notUnary
, name /= commaID
]
splitTerm :: CurrentFunction -> TightFunctions -> TightFunctions
splitTerm (MkCurrentFunction MkVar{ v_categ = cat, v_name = n } _ _)
res@MkTightFunctions{ r_term = term }
| n `Set.member` nonTermNames = res
| otherwise = res{ r_term = Map.insert (MkOpName n) cat term }
splitUnary :: CurrentFunction -> TightFunctions -> TightFunctions
splitUnary (MkCurrentFunction MkVar{ v_categ = cat, v_name = n } _ [param])
res@MkTightFunctions{ r_opt = opt, r_named = named, r_pre = pre, r_post = post }
| n `Set.member` slurpyNames = res
| isOptional param = res{ r_opt = Set.insert (MkOpName n) opt }
| C_prefix <- cat = res{ r_pre = Set.insert (MkOpName n) pre }
| C_postfix <- cat = res{ r_post = Set.insert (MkOpName n) post }
| otherwise = res{ r_named = Set.insert (MkOpName n) named }
splitUnary _ res = res
return finalResult
namesFrom :: [CurrentFunction] -> Set ID
namesFrom = Set.fromList . map (v_name . f_var)
commaID :: ID
commaID = cast ","
data TightFunctions = MkTightFunctions
{ r_opt :: !(Set OpName)
, r_named :: !(Set OpName)
, r_pre :: !(Set OpName)
, r_post :: !(Set OpName)
, r_term :: !(Map OpName VarCateg)
, r_infix :: !(Map OpName SubAssoc)
}
emptySet :: Set OpName
emptySet = Set.empty
emptyMap :: Map OpName VarCateg
emptyMap = Map.empty
matchUnary :: CurrentFunction -> Bool
matchUnary MkCurrentFunction
{ f_assoc = ANil, f_params = [MkOldParam
{ paramContext = CxtItem{}, isNamed = False }] } = True
matchUnary _ = False
matchTerm :: CurrentFunction -> Bool
matchTerm MkCurrentFunction{ f_var = MkVar{ v_categ = C_term } } = True
matchTerm MkCurrentFunction{ f_assoc = ANil, f_params = [] } = True
matchTerm _ = False
matchSlurpy :: CurrentFunction -> Bool
matchSlurpy MkCurrentFunction
{ f_params = (_:_:_) } = True
matchSlurpy MkCurrentFunction
{ f_params = [MkOldParam
{ paramContext = CxtSlurpy{}, paramName = MkVar{ v_sigil = sig } }] }
= sig == SArray || sig == SArrayMulti
matchSlurpy _ = False
fileTestOperatorNames :: String
fileTestOperatorNames = "ABCMORSTWXbcdefgkloprstuwxz"
circumOps, rightSyn, chainOps, matchOps, nonSyn, listSyn, preSyn, optPreSyn, preOps, preSymOps, optSymOps, postOps, optOps, leftOps, rightOps, nonOps, listOps :: Set OpName -> [RuleOperator Exp]
preSyn = ops $ makeOp1 Prefix "" Syn
optPreSyn = ops $ makeOp1 OptionalPrefix "" Syn
preOps = (ops $ makeOp1 Prefix "&prefix:" doApp) . addHyperPrefix
preSymOps = (ops $ makeOp1 Prefix "&prefix:" doAppSym) . addHyperPrefix
optSymOps = (ops $ makeOp1 OptionalPrefix "&prefix:" doAppSym) . addHyperPrefix
postOps = (ops $ makeOp1 Postfix "&postfix:" doApp) . addHyperPostfix
optOps = (ops $ makeOp1 OptionalPrefix "&prefix:" doApp) . addHyperPrefix
leftOps = (ops $ makeOp2 AssocLeft "&infix:" doApp) . addHyperInfix
rightOps = (ops $ makeOp2 AssocRight "&infix:" doApp) . addHyperInfix
nonOps = ops $ makeOp2 AssocNone "&infix:" doApp
listOps = ops $ makeOp2 AssocLeft "&infix:" doApp
matchOps = (ops $ makeOp2Match AssocLeft "&infix:" doApp) . addHyperInfix . addNegation
chainOps = (ops $ makeOp2 AssocLeft "&infix:" doApp) . addHyperInfix . addNegation
rightSyn = ops $ makeOp2 AssocRight "" Syn
nonSyn = ops $ makeOp2 AssocNone "" Syn
listSyn = ops $ makeOp0 AssocList "" Syn
circumOps = ops $ makeCircumOp "&circumfix:"
rightAssignSyn :: RuleOperator Exp
rightAssignSyn = makeOp2Assign AssocRight "" Syn
rightDotAssignSyn :: RuleOperator Exp
rightDotAssignSyn = makeOp2DotAssign AssocRight "" Syn
{-# INLINE ops #-}
{-# SPECIALISE ops :: (String -> RuleOperator Exp) -> Set OpName -> [RuleOperator Exp] #-}
{-# SPECIALISE ops :: (String -> RuleParser String) -> Set OpName -> [RuleParser String] #-}
ops :: (String -> a) -> Set OpName -> [a]
ops f = map f . cast . Set.toAscList
makeOp1 :: (RuleParser (Exp -> Exp) -> RuleOperator Exp) ->
String ->
(String -> [Exp] -> Exp) ->
String ->
RuleOperator Exp
makeOp1 fixity sigil con name = fixity $ try $ do
symbol name
-- `int(3)+4` should not be parsed as `int((3)+4)`
lookAheadLiterals
where
lookAheadLiterals
| "-" <- name =
-- Horrible, horrible kluge to make "-e" etc work across prec levels.
(try parseFileTestOp >>= makeFileTestOp)
<|> conOp fullName
| isWordAny (last name) = choice autoquoters
| otherwise = conOp fullName
autoquoters =
[ char '(' >> unexpected "("
, string "=>" >> unexpected "=>"
, conOp fullName
]
parseFileTestOp = do
rv <- oneOf fileTestOperatorNames
lookAhead (satisfy (not . isWordAny))
whiteSpace
return rv
fullName
| isAlpha (head name)
, "&prefix:" <- sigil
= ('&':name)
| otherwise
= sigil ++ name
makeFileTestOp ch = conOp ("&prefix:-" ++ [ch])
conOp name = return $ \x -> case x of
Syn "" [] -> con name []
_ -> con name [x]
makeCircumOp :: String -> String -> RuleOperator Exp
makeCircumOp sigil op = Term . try $
between (lexeme $ string opener) (string closer) $
enterBracketLevel ParensBracket $ do
(invs, args) <- option (Nothing, []) parseNoParenArgList
possiblyApplyMacro $ App (_Var name) invs args
where
name = sigil ++ opener ++ " " ++ closer
[opener, closer] = words op
-- Just for the "state $foo = 1" rewriting
makeOp2Assign :: Assoc -> String -> (String -> [Exp] -> Exp) -> RuleOperator Exp
makeOp2Assign prec _ con = (`Infix` prec) $ do
symbol "="
return $ \invExp argExp -> stateAssignHack (con "=" [invExp, argExp])
-- Rewrite "EXP ~~ .meth" into "?(EXP.meth)"
makeOp2Match :: Assoc -> String -> (String -> [Exp] -> Exp) -> String -> RuleOperator Exp
makeOp2Match prec sigil con name = (`Infix` prec) $ do
symbol name
return $ \x y -> case y of
Syn syn [Var var, rhs] | var == varTopic ->
App (_Var "&prefix:?") Nothing [Syn syn [x, rhs]]
App app (Just (Var var)) args | var == varTopic ->
App (_Var "&prefix:?") Nothing [App app (Just x) args]
_ -> con (sigil ++ name) [x,y]
stateAssignHack :: Exp -> Exp
stateAssignHack exp@(Syn "=" [lhs, _]) | isStateAssign lhs =
let pad = unsafePerformSTM $! do
state_first_run <- newTVar =<< (fmap scalarRef $! newTVar (VInt 0))
state_fresh <- newTVar False
return $! mkPad [(cast "$?STATE_START_RUN", [(state_fresh, state_first_run)])] in
Syn "block"
[ Pad SState pad $!
Syn "if"
[ App (_Var "&postfix:++") Nothing [_Var "$?STATE_START_RUN"]
, lhs
, exp
]
]
where
isStateAssign (Ann (Decl SState) _) = True
isStateAssign (Ann _ exp) = isStateAssign exp
isStateAssign _ = False
stateAssignHack others = others
-- Just for the ".=" rewriting
makeOp2DotAssign :: Assoc -> String -> (String -> [Exp] -> Exp) -> RuleOperator Exp
makeOp2DotAssign prec _ con = (`Infix` prec) $ do
symbol ".="
insertIntoPosition '.' -- "$x .= foo" becomes "$x .= .foo"
return $ \invExp argExp -> case argExp of
-- XXX - App meth _ args -> stateAssignHack (con ".=" [invExp, App meth Nothing args])
App meth _ args -> stateAssignHack (con "=" [invExp, App meth (Just invExp) args])
_ -> Val (VError (VStr "the right-hand-side of .= must be a function application") [])
makeOp2 :: Assoc ->
String ->
(String -> [Exp] -> Exp) ->
String ->
RuleOperator Exp
makeOp2 prec sigil con name = (`Infix` prec) $ do
symbol name
return $ \x y -> con (sigil ++ name) [x,y]
makeOp0 :: Assoc ->
String ->
(String -> [Exp] -> Exp) ->
String ->
RuleOperator Exp
makeOp0 prec sigil con name = (`InfixList` prec) $ do
many1 $ do
string name
whiteSpace
return . con $ sigil ++ name
doApp :: String -> [Exp] -> Exp
doApp str args = App (_Var str) Nothing args
{-|
Take a list of infix-operator names (as a space-separated string), and return
a similar string also containing both Texas-style and French-style infixed
hyperized forms.
For example, the string @\"+ -\"@ would be transformed into
@\"+ >>+\<\< »+« - >>-\<\< »-«\"@.
-}
addHyperInfix :: Set OpName -> Set OpName
addHyperInfix xs = xs `Set.union` hyperTexan `Set.union` hyperFrench
where
hyperTexan = Set.mapMonotonic texan xs
hyperFrench = Set.mapMonotonic french xs
texan x = cast (Buf.concat [__">>", cast x, __"<<"])
french x = cast (Buf.concat [__"\187", cast x, __"\171"])
{-|
Similar to 'addHyperInfix', but for prefix ops.
For example, @\"++ --\"@ would become
@\"++ ++\<\< ++« -- --\<\< --«\"@.
-}
addHyperPrefix :: Set OpName -> Set OpName
addHyperPrefix xs = xs `Set.union` hyperTexan `Set.union` hyperFrench
where
hyperTexan = Set.mapMonotonic texan xs
hyperFrench = Set.mapMonotonic french xs
texan x = cast (cast x +++ __"<<")
french x = cast (cast x +++ __"\171")
{-|
Similar to 'addHyperInfix', but for postfix ops.
For example, @\"++ --\"@ would become
@\"++ >>++ »++ -- >>-- »--\"@.
-}
addHyperPostfix :: Set OpName -> Set OpName
addHyperPostfix xs = xs `Set.union` hyperTexan `Set.union` hyperFrench
where
hyperTexan = Set.mapMonotonic texan xs
hyperFrench = Set.mapMonotonic french xs
texan x = cast (__">>" +++ cast x)
french x = cast (cast "\187" +++ cast x)
{-|
Add prefix \
-}
addScanPrefix :: Set OpName -> Set OpName
addScanPrefix xs = xs `Set.union` scanPrefix
where
scanPrefix = Set.mapMonotonic scan xs
scan x = cast (Buf.cons '\\' (cast x))
addNegation :: Set OpName -> Set OpName
addNegation xs = xs `Set.union` Set.mapMonotonic negation xs
where
negation x = let buf = cast x in
if Buf.head buf == '!'
then x
else cast (Buf.cons '!' (cast x))
methOps :: a -> [b]
methOps _ = []
doAppSym :: String -> [Exp] -> Exp
doAppSym name@(_:'p':'r':'e':'f':'i':'x':':':_) args = App (_Var name) Nothing args
doAppSym (sigil:name) args = App (_Var (sigil:("prefix:"++name))) Nothing args
doAppSym _ _ = error "doAppSym: bad name"
ternOp :: String -> String -> String -> RuleOperator Exp
ternOp pre post syn = (`Infix` AssocRight) $ do
symbol pre
y <- parseExpWithTightOps
symbol post
return $ \x z -> Syn syn [x, y, z]
emptyTerm :: Exp
emptyTerm = Syn "" []
type TermOperator = RuleParser Exp
type UnaryOperator = RuleParser (Exp -> Exp)
type BinaryOperator = RuleParser (Exp -> Exp -> Exp)
type ListOperator = RuleParser ([Exp] -> Exp)
type DependentOperator = Exp -> RuleParser Exp
data OpRow = MkOpRow
{ o_rassoc :: ![BinaryOperator]
, o_lassoc :: ![BinaryOperator]
, o_nassoc :: ![BinaryOperator]
, o_prefix :: ![UnaryOperator]
, o_postfix :: ![UnaryOperator]
, o_optPrefix :: ![UnaryOperator]
, o_listAssoc :: ![ListOperator]
, o_depPostfix :: ![DependentOperator]
, o_term :: ![TermOperator]
}
-----------------------------------------------------------
-- Convert an OperatorTable and basic term parser into
-- a full fledged expression parser
-----------------------------------------------------------
buildExpressionParser :: RuleOperatorTable Exp -> RuleParser Exp -> RuleParser Exp
buildExpressionParser = flip (foldl makeParser)
{-# INLINE makeParser #-}
makeParser :: RuleParser Exp -> [RuleOperator Exp] -> RuleParser Exp
makeParser simpleTerm ops = do
x <- termP
rassocP x <|> lassocP x <|> nassocP x <|> listAssocP x <|> return x <?> "operator"
where
MkOpRow rassoc lassoc nassoc prefix postfix optPrefix listAssoc depPostfix term
= foldr splitOp (MkOpRow [] [] [] [] [] [] [] [] []) ops
rassocOp = {-# SCC "rassocOp" #-} choice rassoc <?> ""
lassocOp = {-# SCC "lassocOp" #-} choice lassoc <?> ""
nassocOp = {-# SCC "nassocOp" #-} choice nassoc <?> ""
prefixOp = {-# SCC "prefixOp" #-} choice prefix <?> ""
postfixOp = {-# SCC "postfixOp" #-} choice postfix <?> ""
optPrefixOp = {-# SCC "optPrefixOp" #-} choice optPrefix <?> ""
listAssocOp = {-# SCC "listAssocOp" #-} choice listAssoc <?> ""
depPostfixOp x = {-# SCC "depPostfixOp" #-} choice (map ($ x) depPostfix) <?> ""
termOp = {-# SCC "termOp" #-} choice term <|> simpleTerm
ambig assoc op = try
(op >> fail ("ambiguous use of a " ++ assoc ++ " associative operator"))
ambigRight = ambig "right" rassocOp
ambigLeft = ambig "left" lassocOp
ambigNon = ambig "non" nassocOp
foldOp = foldr (.) id
termP = {-# SCC "termP" #-} do
pres <- many $ (fmap Left prefixOp) <|> (fmap Right optPrefixOp)
-- Here we handle optional-prefix operators.
x <- if null pres then termOp else case last pres of
Left _ -> termOp
_ -> option emptyTerm termOp
x' <- depPostP x
posts <- many postfixOp
fmap (foldOp posts) $ foldM maybeApplyPrefixMacro x' (map liftEither $ reverse pres)
maybeApplyPrefixMacro t f = {-# SCC "maybeApplyPrefixMacro" #-} possiblyApplyMacro (f t)
liftEither (Left x) = x
liftEither (Right x) = x
depPostP x = (<|> return x) $ do
x' <- depPostfixOp x
depPostP x'
rassocP x = (do
f <- rassocOp
y <- rassocP1 =<< termP
return (f x y)) <|> ambigLeft <|> ambigNon
rassocP1 x = rassocP x <|> return x
lassocP x = (do
f <- lassocOp
y <- termP
lassocP1 (f x y)) <|> ambigRight <|> ambigNon
lassocP1 x = lassocP x <|> return x
nassocP x = do
f <- nassocOp
y <- termP
ambigRight <|> ambigLeft <|> ambigNon <|> return (f x y)
listAssocP x = do
f <- listAssocOp
xs <- option [] $ listAssocP1 =<< termP
return (f (x:xs))
listAssocP0 x = do
listAssocOp
xs <- option [] $ listAssocP1 =<< termP
return (x:xs)
listAssocP1 x = listAssocP0 x <|> return [x]
{-# INLINE splitOp #-}
splitOp :: RuleOperator Exp -> OpRow -> OpRow
splitOp col row@(MkOpRow rassoc lassoc nassoc prefix postfix optPrefix listAssoc depPostfix term) = case col of
Infix op AssocNone -> row{ o_nassoc = op:nassoc }
Infix op AssocLeft -> row{ o_lassoc = op:lassoc }
Infix op AssocRight -> row{ o_rassoc = op:rassoc }
InfixList op AssocList -> row{ o_listAssoc = op:listAssoc }
Prefix op -> row{ o_prefix = op:prefix }
Postfix op -> row{ o_postfix = op:postfix }
OptionalPrefix op -> row{ o_optPrefix = op:optPrefix }
DependentPostfix op -> row{ o_depPostfix= op:depPostfix }
Term op -> row{ o_term = op:term }
-- FIXME: add AssocChain
_ -> internalError $ "Unhandled operator type" ++ show (op_assoc col)
refillCache :: RuleState -> (DynParsers -> RuleParser a) -> RuleParser a
refillCache state f = do
(tights, opsTight) <- tightOperators
opsLoose <- looseOperators
let tightExprs = buildExpressionParser opsTight parseTerm
parseTight = expRule tightExprs
parseFull = expRule (buildExpressionParser opsFull tightExprs)
parseLit = expRule (buildExpressionParser opsLoose tightExprs)
parsePost = pp "&postfix:" $ incrOps `Set.union` r_post tights
-- parsePre = pp "&prefix:" $ symbPreops `Set.union` r_pre tights
-- parsePreNam = pp "&" $ r_named tights `Set.union` r_opt tights
pp pre ops = fmap (pre ++) (tryChoice . map string . fromSet $ ops)
opParsers = MkDynParsers parseFull parseTight parseLit parseNullary parsePost -- <|> parsePre <|> parsePreNam)
opsFull = listCons:listInfix:opsLoose
parseNullary= try $ do
var <- (choice . map parseOneTerm . Map.toAscList $ r_term tights) <?> "term"
notFollowedBy (char '(' <|> (char ':' >> char ':'))
possiblyApplyMacro $ App (Var var) Nothing []
parseOneTerm (name, categ) = do
symbol (cast name)
return MkVar
{ v_name = cast name
, v_sigil = SCode
, v_twigil = TNil
, v_categ = categ
, v_package = emptyPkg
, v_meta = MNil
}
setState state{ s_dynParsers = opParsers }
f opParsers
-- was: parseOp
parseExpWithOps :: RuleParser Exp
parseExpWithOps = parseExpWithCachedParser dynParseOp
-- was: parseTightOp
parseExpWithTightOps :: RuleParser Exp
parseExpWithTightOps = parseExpWithCachedParser dynParseTightOp
-- Parse something in item context -- i.e. everything minus list-associative ones
parseExpWithItemOps :: RuleParser Exp
parseExpWithItemOps = parseExpWithCachedParser dynParseLitOp
-- was: parseOpWith
parseExpWithCachedParser :: (DynParsers -> RuleParser a) -> RuleParser a
parseExpWithCachedParser f = do
state <- getState
case s_dynParsers state of
MkDynParsersEmpty -> refillCache state f
p -> f p
ruleHyperPre :: RuleParser String
ruleHyperPre = ((char '\187' >> return ">>") <|> (string ">>"))
ruleHyperPost :: RuleParser String
ruleHyperPost = ((char '\171' >> return "<<") <|> (string "<<"))
-- XXX - the rulePipeHyper below should be more generic and put all +<< etc to listop level
rulePipeHyper :: RuleParser Var
rulePipeHyper = verbatimRule "" $ do
-- sig <- (fmap show ruleSigil) <|> string "|"
char '|'
ruleHyperPost
return $ cast "&prefix:|<<"
ruleInfixOp :: RuleParser String
ruleInfixOp = verbatimRule "infix operator" $ do
-- XXX - Instead of a lookup, add a cached parseInfix here!
MkTightFunctions{ r_infix = infixOps } <- currentTightFunctions
choice $ ops (try . string)
(addScanPrefix (addHyperInfix (Map.keysSet infixOps `Set.union` defaultInfixOps)))
ruleInfixAssignment :: RuleParser String
ruleInfixAssignment = choice $ ops (try . string) infixAssignmentOps
-- XXX !~~ needs to turn into metaop plus ~~
defaultInfixOps :: Set OpName
defaultInfixOps = opWords $ concat
[ " ** * / % x xx +& +< +> ~& ~< ~> "
, " + - ~ +| +^ ~| ~^ ?| , Y \xA5 "
, " & ^ | "
, " => = "
, " != == < <= > >= ~~ "
, " !== !< !<= !> !>= !~~ "
, " eq ne lt le gt ge =:= === eqv "
, " !eq !ne !lt !le !gt !ge !=:= !=== !eqv "
, " && "
, " || ^^ // "
, " and or xor err "
, " .[] .{} "
]
ruleFoldOp :: RuleParser Var
ruleFoldOp = tryVerbatimRule "reduce metaoperator" $ rulePipeHyper <|> do
char '['
name <- ruleInfixOp
char ']'
-- possiblyHyper <- option "" ruleHyperPost
--
-- S03: If there is ambiguity between a triangular reduce and an infix operator
-- beginning with backslash, the infix operator is chosen.
let var = cast ("&prefix:[" ++ name ++ "]")
nameID = cast name
case name of
('\\':_) -> do
MkTightFunctions{ r_infix = infixOps } <- currentTightFunctions
return $ if MkOpName nameID `Map.member` infixOps
then var{ v_name = nameID, v_meta = MFold }
else var
_ -> return var