{- |
Module      :  ./Common/Earley.hs
Description :  generic mixfix analysis, using an Earley parser
Copyright   :  Christian Maeder and Uni Bremen 2003-2005
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  experimental
Portability :  portable

Generic mixfix analysis, using an Earley parser

The grammer has a single non-terminal for terms (the double
underscore). A rule of the grammer carries an identifier, a precedence
number, and the actual token list of the identifier to match against
the input token list..

The parser can be instantiated for any term type. A
function parameter determines how applications from identifiers and
arguments are constructed.
-}

module Common.Earley
    ( Rule
    , TokRules
    , Rules (..)
    , emptyRules
    , partitionRules
    -- * special tokens for special ids
    , varTok
    , exprTok
    , parenId
    , exprId
    , varId
    , tupleId
    , unitId
    , protect
    , listRules
    , mixRule
    , getTokenPlaceList
    , getPlainPolyTokenList
    , getPolyTokenList
    -- * resolution chart
    , Chart
    , mixDiags
    , solveDiags
    , ToExpr
    , rules
    , addRules
    , initChart
    , nextChart
    , getResolved
    ) where

import Common.AS_Annotation
import Common.GlobalAnnotations
import Common.Id
import Common.Prec
import Common.Result
import Common.Utils (nubOrd)

import Control.Exception

import Data.List
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set

-- | take the difference of the two input lists take (length l2 - length l1) l2
takeDiff :: [a] -> [b] -> [b]
takeDiff :: [a] -> [b] -> [b]
takeDiff l1 :: [a]
l1 l2 :: [b]
l2 = (b -> b -> b) -> [b] -> [b] -> [b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> b -> b
forall a b. a -> b -> a
const [b]
l2 ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ [a] -> [b] -> [b]
forall a b. [a] -> [b] -> [b]
dropPrefix [a]
l1 [b]
l2

{- | update token positions.
return remaining positions -}
setToksPos :: [Token] -> Range -> ([Token], Range)
setToksPos :: [Token] -> Range -> ([Token], Range)
setToksPos (h :: Token
h : ts :: [Token]
ts) (Range (p :: Pos
p : ps :: [Pos]
ps)) =
    let (rt :: [Token]
rt, rp :: Range
rp) = [Token] -> Range -> ([Token], Range)
setToksPos [Token]
ts ([Pos] -> Range
Range [Pos]
ps)
        in (Token
h {tokPos :: Range
tokPos = [Pos] -> Range
Range ([Pos] -> Range) -> [Pos] -> Range
forall a b. (a -> b) -> a -> b
$ if Token -> Bool
isPlace Token
h then [Pos
p, Pos
p] else [Pos
p]} Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
rt, Range
rp)
setToksPos ts :: [Token]
ts ps :: Range
ps = ([Token]
ts, Range
ps)

reverseRange :: Range -> Range
reverseRange :: Range -> Range
reverseRange = [Pos] -> Range
Range ([Pos] -> Range) -> (Range -> [Pos]) -> Range -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pos] -> [Pos]
forall a. [a] -> [a]
reverse ([Pos] -> [Pos]) -> (Range -> [Pos]) -> Range -> [Pos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Pos]
rangeToList

{- | update positions in 'Id'.
return remaining positions -}
setPlainIdePos :: Id -> Range -> (Id, Range)
setPlainIdePos :: Id -> Range -> (Id, Range)
setPlainIdePos (Id ts :: [Token]
ts cs :: [Id]
cs _) ps :: Range
ps =
    if [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
cs then
       let (newTs :: [Token]
newTs, restPs :: Range
restPs) = [Token] -> Range -> ([Token], Range)
setToksPos [Token]
ts Range
ps
           in ([Token] -> [Id] -> Range -> Id
Id [Token]
newTs [Id]
cs Range
nullRange, Range
restPs)
    else let (toks :: [Token]
toks, pls :: [Token]
pls) = [Token] -> ([Token], [Token])
splitMixToken [Token]
ts
             (front :: [Token]
front, ps2 :: Range
ps2) = [Token] -> Range -> ([Token], Range)
setToksPos [Token]
toks Range
ps
             ps2PL :: [Pos]
ps2PL = Range -> [Pos]
rangeToList Range
ps2
             (newCs :: [Id]
newCs, ps3 :: Range
ps3, ps4 :: Range
ps4) =
                 if Range -> Bool
isNullRange Range
ps2 then [Char] -> ([Id], Range, Range)
forall a. HasCallStack => [Char] -> a
error "setPlainIdePos2"
                    else (([Id], Range, Range) -> Id -> ([Id], Range, Range))
-> ([Id], Range, Range) -> [Id] -> ([Id], Range, Range)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ( \ (prevCs :: [Id]
prevCs, seps :: Range
seps, restPs :: Range
restPs) a :: Id
a ->
                         let (c1 :: Id
c1, qs :: Range
qs) = Id -> Range -> (Id, Range)
setPlainIdePos Id
a Range
restPs
                             qsPL :: [Pos]
qsPL = Range -> [Pos]
rangeToList Range
qs
                         in if Range -> Bool
isNullRange Range
qs then [Char] -> ([Id], Range, Range)
forall a. HasCallStack => [Char] -> a
error "setPlainIdePos1"
                            else (Id
c1 Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
prevCs,
                                  [Pos] -> Range
Range ([Pos] -> Pos
forall a. [a] -> a
head [Pos]
qsPL Pos -> [Pos] -> [Pos]
forall a. a -> [a] -> [a]
: Range -> [Pos]
rangeToList Range
seps),
                                  [Pos] -> Range
Range ([Pos] -> [Pos]
forall a. [a] -> [a]
tail [Pos]
qsPL)))
                           ([], [Pos] -> Range
Range [[Pos] -> Pos
forall a. [a] -> a
head [Pos]
ps2PL], [Pos] -> Range
Range ([Pos] -> [Pos]
forall a. [a] -> [a]
tail [Pos]
ps2PL)) [Id]
cs
             (newPls :: [Token]
newPls, ps7 :: Range
ps7) = [Token] -> Range -> ([Token], Range)
setToksPos [Token]
pls Range
ps4
           in ([Token] -> [Id] -> Range -> Id
Id ([Token]
front [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token]
newPls) ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
newCs) (Range -> Range
reverseRange Range
ps3), Range
ps7)

{- no special index type anymore (assuming not much more development)
the info Int denotes fast precedence -}

data Item a = Item
    { Item a -> Id
rule :: Id        -- the rule to match
    , Item a -> Int
info :: Int       -- additional precedence info for 'rule'
    , Item a -> Id
lWeight :: Id     -- weights for lower precedence pre- and postfixes
    , Item a -> Id
rWeight :: Id     -- given by the 'Id's itself
    , Item a -> Range
posList :: Range  -- positions of Id tokens
    , Item a -> [a]
args :: [a]       -- collected arguments are in reverse order
    , Item a -> [[a]]
ambigArgs :: [[a]] -- field for ambiguities
    , Item a -> [[a]]
ambigs :: [[a]]   -- field for ambiguities
    , Item a -> [Token]
rest :: [Token]   -- part of the rule after the "dot"
    , Item a -> Int
index :: Int    -- index into the Table/input string
    }

-- | the non-terminal
termStr :: String
termStr :: [Char]
termStr = "(__)"
-- | builtin terminals
commaTok, termTok, oParenTok, cParenTok :: Token
commaTok :: Token
commaTok = [Char] -> Token
mkSimpleId "," -- for list elements
termTok :: Token
termTok = [Char] -> Token
mkSimpleId [Char]
termStr
oParenTok :: Token
oParenTok = [Char] -> Token
mkSimpleId "("
cParenTok :: Token
cParenTok = [Char] -> Token
mkSimpleId ")"
listTok :: Token
listTok :: Token
listTok = [Char] -> Token
mkSimpleId "[]" -- impossible token
protectTok :: Token
protectTok :: Token
protectTok = [Char] -> Token
mkSimpleId "()" -- impossible token

-- | token for a fixed (or recursively resolved) operator expression
exprTok :: Token
exprTok :: Token
exprTok = [Char] -> Token
mkSimpleId "(op )"

-- | token for a fixed (or recursively resolved) argument expression
varTok :: Token
varTok :: Token
varTok = [Char] -> Token
mkSimpleId "(var )"

-- | parenthesis around one place
parenId :: Id
parenId :: Id
parenId = [Token] -> Id
mkId [Token
oParenTok, Token
placeTok, Token
cParenTok]

-- | id for tuples with at least two arguments
tupleId :: Id
tupleId :: Id
tupleId = [Token] -> Id
mkId [Token
oParenTok, Token
placeTok, Token
commaTok, Token
placeTok, Token
cParenTok]

-- | id for the emtpy tuple
unitId :: Id
unitId :: Id
unitId = [Token] -> Id
mkId [Token
oParenTok, Token
cParenTok]

-- | see 'exprTok'
exprId :: Id
exprId :: Id
exprId = [Token] -> Id
mkId [Token
exprTok]

-- | see 'varTok'
varId :: Id
varId :: Id
varId = [Token] -> Id
mkId [Token
varTok]

listId :: (Id, Id) -> Id
listId :: (Id, Id) -> Id
listId (f :: Id
f, c :: Id
c) = [Token] -> [Id] -> Range -> Id
Id [Token
listTok] [Id
f, Id
c] Range
nullRange

isListId :: Id -> Bool
isListId :: Id -> Bool
isListId (Id ts :: [Token]
ts _ _) = Bool -> Bool
not ([Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
ts) Bool -> Bool -> Bool
&& [Token] -> Token
forall a. [a] -> a
head [Token]
ts Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
listTok

-- | interpret placeholders as literal places
protect :: Id -> Id
protect :: Id -> Id
protect i :: Id
i = [Token] -> [Id] -> Range -> Id
Id [Token
protectTok] [Id
i] Range
nullRange

unProtect :: Id -> Maybe Id
unProtect :: Id -> Maybe Id
unProtect (Id ts :: [Token]
ts cs :: [Id]
cs _) = case [Id]
cs of
    [i :: Id
i] -> case [Token]
ts of
      [tok :: Token
tok] | Token
tok Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
protectTok -> Id -> Maybe Id
forall a. a -> Maybe a
Just Id
i
      _ -> Maybe Id
forall a. Maybe a
Nothing
    _ -> Maybe Id
forall a. Maybe a
Nothing

-- | get the token list for a mixfix rule
getPolyTokenList :: Id -> [Token]
getPolyTokenList :: Id -> [Token]
getPolyTokenList = [Char] -> Id -> [Token]
getGenPolyTokenList [Char]
termStr

-- | get the plain token list for prefix applications
getPlainPolyTokenList :: Id -> [Token]
getPlainPolyTokenList :: Id -> [Token]
getPlainPolyTokenList = [Char] -> Id -> [Token]
getGenPolyTokenList [Char]
place

type Rule = (Id, Int, [Token])

mkItem :: Int -> Rule -> Item a
mkItem :: Int -> Rule -> Item a
mkItem ind :: Int
ind (ide :: Id
ide, inf :: Int
inf, toks :: [Token]
toks) = Item :: forall a.
Id
-> Int
-> Id
-> Id
-> Range
-> [a]
-> [[a]]
-> [[a]]
-> [Token]
-> Int
-> Item a
Item
   { rule :: Id
rule = Id
ide
   , info :: Int
info = Int
inf
   , lWeight :: Id
lWeight = Id
ide
   , rWeight :: Id
rWeight = Id
ide
   , posList :: Range
posList = Range
nullRange
   , args :: [a]
args = []
   , ambigArgs :: [[a]]
ambigArgs = []
   , ambigs :: [[a]]
ambigs = []
   , rest :: [Token]
rest = [Token]
toks
   , index :: Int
index = Int
ind }

-- | extract tokens with the non-terminal for places
getTokenPlaceList :: Id -> [Token]
getTokenPlaceList :: Id -> [Token]
getTokenPlaceList = [Char] -> Id -> [Token]
getTokenList [Char]
termStr

-- | construct a rule for a mixfix
mixRule :: Int -> Id -> Rule
mixRule :: Int -> Id -> Rule
mixRule b :: Int
b i :: Id
i = (Id
i, Int
b, Id -> [Token]
getTokenPlaceList Id
i)

asListAppl :: ToExpr a -> Id -> [a] -> Range -> a
asListAppl :: ToExpr a -> ToExpr a
asListAppl toExpr :: ToExpr a
toExpr i :: Id
i ra :: [a]
ra br :: Range
br
  | Id -> Bool
isListId Id
i =
      let Id _ [f :: Id
f, c :: Id
c] _ = Id
i
          mkList :: [a] -> Range -> a
mkList [] ps :: Range
ps = ToExpr a
toExpr Id
c [] Range
ps
          mkList (hd :: a
hd : tl :: [a]
tl) ps :: Range
ps = ToExpr a
toExpr Id
f [a
hd, [a] -> Range -> a
mkList [a]
tl Range
ps] Range
ps
      in [a] -> Range -> a
mkList [a]
ra Range
br
  | Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Id
i [Id
typeId, Id
exprId, Id
parenId, Id
varId] = case [a]
ra of
         [arg :: a
arg] -> a
arg
         _ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error "asListAppl"
  | Bool
otherwise = ToExpr a
toExpr Id
i [a]
ra Range
br

-- | construct the list rules
listRules :: Int -> GlobalAnnos -> [Rule]
listRules :: Int -> GlobalAnnos -> [Rule]
listRules inf :: Int
inf g :: GlobalAnnos
g =
    let lists :: Map Id (Id, Id)
lists = LiteralAnnos -> Map Id (Id, Id)
list_lit (LiteralAnnos -> Map Id (Id, Id))
-> LiteralAnnos -> Map Id (Id, Id)
forall a b. (a -> b) -> a -> b
$ GlobalAnnos -> LiteralAnnos
literal_annos GlobalAnnos
g
        listRule :: (Id, Id) -> c -> (Id, Int, c)
listRule co :: (Id, Id)
co toks :: c
toks = ((Id, Id) -> Id
listId (Id, Id)
co, Int
inf, c
toks)
    in ((Id, (Id, Id)) -> [Rule]) -> [(Id, (Id, Id))] -> [Rule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ( \ (bs :: Id
bs, (n :: Id
n, c :: Id
c)) ->
       let (b1 :: [Token]
b1, b2 :: [Token]
b2, cs :: [Id]
cs) = Id -> ([Token], [Token], [Id])
getListBrackets Id
bs
           e :: Id
e = [Token] -> [Id] -> Range -> Id
Id ([Token]
b1 [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token]
b2) [Id]
cs Range
nullRange in
           (if Id
e Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
n then [] -- add b1 ++ b2 if its not yet included by n
               else [(Id, Id) -> [Token] -> Rule
forall c. (Id, Id) -> c -> (Id, Int, c)
listRule (Id
c, Id
n) ([Token] -> Rule) -> [Token] -> Rule
forall a b. (a -> b) -> a -> b
$ Id -> [Token]
getPlainTokenList Id
e])
           [Rule] -> [Rule] -> [Rule]
forall a. [a] -> [a] -> [a]
++ [(Id, Id) -> [Token] -> Rule
forall c. (Id, Id) -> c -> (Id, Int, c)
listRule (Id
c, Id
n) ([Token]
b1 [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
termTok] [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token]
b2),
               (Id, Id) -> [Token] -> Rule
forall c. (Id, Id) -> c -> (Id, Int, c)
listRule (Id
c, Id
n) ([Token]
b1 [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
termTok, Token
commaTok, Token
termTok] [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token]
b2)]
                 ) ([(Id, (Id, Id))] -> [Rule]) -> [(Id, (Id, Id))] -> [Rule]
forall a b. (a -> b) -> a -> b
$ Map Id (Id, Id) -> [(Id, (Id, Id))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Id (Id, Id)
lists

type Table a = Map.Map Int [Item a]

lookUp :: Table a -> Int -> [Item a]
lookUp :: Table a -> Int -> [Item a]
lookUp ce :: Table a
ce k :: Int
k = [Item a] -> Int -> Table a -> [Item a]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Int
k Table a
ce

-- | recognize next token (possible introduce new tuple variable)
scanItem :: (a -> a -> a) -> (a, Token) -> Item a -> [Item a]
scanItem :: (a -> a -> a) -> (a, Token) -> Item a -> [Item a]
scanItem addType :: a -> a -> a
addType (trm :: a
trm, t :: Token
t)
  p :: Item a
p@Item { rest :: forall a. Item a -> [Token]
rest = [Token]
ts, args :: forall a. Item a -> [a]
args = [a]
pArgs, posList :: forall a. Item a -> Range
posList = Range
pRange } = case [Token]
ts of
       [] -> []
       hd :: Token
hd : tt :: [Token]
tt -> let
          q :: Item a
q = Item a
p { posList :: Range
posList = case Range -> [Pos]
rangeToList (Range -> [Pos]) -> Range -> [Pos]
forall a b. (a -> b) -> a -> b
$ Token -> Range
tokPos Token
t of
                [] -> Range
pRange
                ps :: [Pos]
ps@(po :: Pos
po : _) -> [Pos] -> Range
Range ([Pos] -> Range) -> [Pos] -> Range
forall a b. (a -> b) -> a -> b
$ (if [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
tt then [Pos] -> Pos
forall a. [a] -> a
last [Pos]
ps else Pos
po)
                   Pos -> [Pos] -> [Pos]
forall a. a -> [a] -> [a]
: Range -> [Pos]
rangeToList Range
pRange }
          r :: Item a
r = Item a
q { rest :: [Token]
rest = [Token]
tt } in
          if Token
hd Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
t Bool -> Bool -> Bool
|| Token
t Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
exprTok Bool -> Bool -> Bool
&& Token
hd Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
varTok then
               if Token
t Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
commaTok then
                  case [Token]
tt of
                  sd :: Token
sd : _ | Token
sd Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
termTok ->
                      -- tuple or list elements separator
                             [ Item a
r, Item a
q { rest :: [Token]
rest = Token
termTok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
ts } ]
                  _ -> [Item a
r]
              else if Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Token
t [Token
exprTok, Token
varTok, Token
typeInstTok] then
                   [Item a
r { args :: [a]
args = a
trm a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
pArgs }]
              else if Token
t Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
typeTok then
                  case ([Token]
tt, [a]
pArgs) of
                  ([], [arg :: a
arg]) -> [Item a
q { rest :: [Token]
rest = [], args :: [a]
args = [a -> a -> a
addType a
trm a
arg] }]
                  _ -> [Char] -> [Item a]
forall a. HasCallStack => [Char] -> a
error "scanItem: typeTok"
              else [Item a
r]
          else []

scan :: (a -> a -> a) -> (a, Token) -> [Item a] -> [Item a]
scan :: (a -> a -> a) -> (a, Token) -> [Item a] -> [Item a]
scan f :: a -> a -> a
f = (Item a -> [Item a]) -> [Item a] -> [Item a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Item a -> [Item a]) -> [Item a] -> [Item a])
-> ((a, Token) -> Item a -> [Item a])
-> (a, Token)
-> [Item a]
-> [Item a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> (a, Token) -> Item a -> [Item a]
forall a. (a -> a -> a) -> (a, Token) -> Item a -> [Item a]
scanItem a -> a -> a
f

mkAmbigs :: ToExpr a -> Item a -> [a]
mkAmbigs :: ToExpr a -> Item a -> [a]
mkAmbigs toExpr :: ToExpr a
toExpr p :: Item a
p@Item { args :: forall a. Item a -> [a]
args = [a]
l, ambigArgs :: forall a. Item a -> [[a]]
ambigArgs = [[a]]
aArgs } =
    ([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ( \ aas :: [a]
aas -> (a, Range) -> a
forall a b. (a, b) -> a
fst ((a, Range) -> a) -> (a, Range) -> a
forall a b. (a -> b) -> a -> b
$
          ToExpr a -> Item a -> (a, Range)
forall a. ToExpr a -> Item a -> (a, Range)
mkExpr ToExpr a
toExpr
          Item a
p { args :: [a]
args = [a] -> [a] -> [a]
forall a b. [a] -> [b] -> [b]
takeDiff [a]
aas [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
aas
            } ) [[a]]
aArgs

addArg :: GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a
addArg :: GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a
addArg ga :: GlobalAnnos
ga toExpr :: ToExpr a
toExpr argItem :: Item a
argItem@Item { ambigs :: forall a. Item a -> [[a]]
ambigs = [[a]]
ams, posList :: forall a. Item a -> Range
posList = Range
aRange }
  p :: Item a
p@Item { args :: forall a. Item a -> [a]
args = [a]
pArgs, rule :: forall a. Item a -> Id
rule = Id
op, posList :: forall a. Item a -> Range
posList = Range
pRange, ambigs :: forall a. Item a -> [[a]]
ambigs = [[a]]
pAmbs
        , rest :: forall a. Item a -> [Token]
rest = [Token]
pRest} =
    let (arg :: a
arg, _) = ToExpr a -> Item a -> (a, Range)
forall a. ToExpr a -> Item a -> (a, Range)
mkExpr ToExpr a
toExpr Item a
argItem
        newAms :: [a]
newAms = ToExpr a -> Item a -> [a]
forall a. ToExpr a -> Item a -> [a]
mkAmbigs ToExpr a
toExpr Item a
argItem
        q :: Item a
q = case [Token]
pRest of
            _ : tl :: [Token]
tl ->
               Item a
p { rest :: [Token]
rest = [Token]
tl
                 , posList :: Range
posList = case Range -> [Pos]
rangeToList Range
aRange of
                     [] -> Range
pRange
                     qs :: [Pos]
qs@(h :: Pos
h : _) -> [Pos] -> Range
Range ([Pos] -> Range) -> [Pos] -> Range
forall a b. (a -> b) -> a -> b
$ (if [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
tl then
                        [Pos] -> Pos
forall a. [a] -> a
last [Pos]
qs else Pos
h) Pos -> [Pos] -> [Pos]
forall a. a -> [a] -> [a]
: Range -> [Pos]
rangeToList Range
pRange
                 , args :: [a]
args = a
arg a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
pArgs
                 , ambigs :: [[a]]
ambigs = (if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
newAms then [[a]]
ams else [a]
newAms [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
ams)
                            [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]]
pAmbs }
            _ -> [Char] -> Item a
forall a. HasCallStack => [Char] -> a
error "addArg"
        in if Id -> [a] -> Bool
forall a. Id -> [a] -> Bool
isLeftArg Id
op [a]
pArgs then
              Item a
q { lWeight :: Id
lWeight = AssocEither -> GlobalAnnos -> Item a -> Id -> Id
forall a. AssocEither -> GlobalAnnos -> Item a -> Id -> Id
getNewWeight AssocEither
ALeft GlobalAnnos
ga Item a
argItem Id
op }
           else if Id -> [a] -> Bool
forall a. Id -> [a] -> Bool
isRightArg Id
op [a]
pArgs then
                Item a
q { rWeight :: Id
rWeight = AssocEither -> GlobalAnnos -> Item a -> Id -> Id
forall a. AssocEither -> GlobalAnnos -> Item a -> Id -> Id
getNewWeight AssocEither
ARight GlobalAnnos
ga Item a
argItem Id
op }
           else Item a
q

-- | shortcut for a function that constructs an expression
type ToExpr a = Id -> [a] -> Range -> a

mkExpr :: ToExpr a -> Item a -> (a, Range)
mkExpr :: ToExpr a -> Item a -> (a, Range)
mkExpr toExpr :: ToExpr a
toExpr Item { rule :: forall a. Item a -> Id
rule = Id
orig, posList :: forall a. Item a -> Range
posList = Range
ps, args :: forall a. Item a -> [a]
args = [a]
iArgs } =
    let rs :: Range
rs = Range -> Range
reverseRange Range
ps
        (ide :: Id
ide, qs :: Range
qs) = if Id -> Bool
isListId Id
orig then (Id
orig, Range
rs) else
                    Id -> Range -> (Id, Range)
setPlainIdePos (Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe Id
orig (Maybe Id -> Id) -> Maybe Id -> Id
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
unProtect Id
orig) Range
rs
        in (ToExpr a -> ToExpr a
forall a. ToExpr a -> ToExpr a
asListAppl ToExpr a
toExpr Id
ide ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
iArgs) Range
qs, Range
rs)

reduce :: GlobalAnnos -> Table a -> ToExpr a -> Item a -> [Item a]
reduce :: GlobalAnnos -> Table a -> ToExpr a -> Item a -> [Item a]
reduce ga :: GlobalAnnos
ga table :: Table a
table toExpr :: ToExpr a
toExpr itm :: Item a
itm =
    (Item a -> Item a) -> [Item a] -> [Item a]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a
forall a. GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a
addArg GlobalAnnos
ga ToExpr a
toExpr Item a
itm)
        ([Item a] -> [Item a]) -> [Item a] -> [Item a]
forall a b. (a -> b) -> a -> b
$ (Item a -> Bool) -> [Item a] -> [Item a]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalAnnos -> Item a -> Item a -> Bool
forall a. GlobalAnnos -> Item a -> Item a -> Bool
checkPrecs GlobalAnnos
ga Item a
itm)
        ([Item a] -> [Item a]) -> [Item a] -> [Item a]
forall a b. (a -> b) -> a -> b
$ Table a -> Int -> [Item a]
forall a. Table a -> Int -> [Item a]
lookUp Table a
table (Int -> [Item a]) -> Int -> [Item a]
forall a b. (a -> b) -> a -> b
$ Item a -> Int
forall a. Item a -> Int
index Item a
itm

getWeight :: AssocEither -> Item a -> Id
getWeight :: AssocEither -> Item a -> Id
getWeight side :: AssocEither
side = case AssocEither
side of
    ALeft -> Item a -> Id
forall a. Item a -> Id
lWeight
    ARight -> Item a -> Id
forall a. Item a -> Id
rWeight

getNewWeight :: AssocEither -> GlobalAnnos -> Item a -> Id -> Id
getNewWeight :: AssocEither -> GlobalAnnos -> Item a -> Id -> Id
getNewWeight side :: AssocEither
side ga :: GlobalAnnos
ga = AssocEither -> GlobalAnnos -> Id -> Id -> Id
nextWeight AssocEither
side GlobalAnnos
ga (Id -> Id -> Id) -> (Item a -> Id) -> Item a -> Id -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssocEither -> Item a -> Id
forall a. AssocEither -> Item a -> Id
getWeight AssocEither
side

-- | check precedences of an argument and a top-level operator.
checkPrecs :: GlobalAnnos -> Item a -> Item a -> Bool
checkPrecs :: GlobalAnnos -> Item a -> Item a -> Bool
checkPrecs ga :: GlobalAnnos
ga argItem :: Item a
argItem@Item { rule :: forall a. Item a -> Id
rule = Id
arg, info :: forall a. Item a -> Int
info = Int
argPrec }
              Item { rule :: forall a. Item a -> Id
rule = Id
op, info :: forall a. Item a -> Int
info = Int
opPrec, args :: forall a. Item a -> [a]
args = [a]
oArgs } =
    GlobalAnnos
-> (Id, Int) -> (Id, Int) -> [a] -> (AssocEither -> Id) -> Bool
forall a.
GlobalAnnos
-> (Id, Int) -> (Id, Int) -> [a] -> (AssocEither -> Id) -> Bool
checkPrec GlobalAnnos
ga (Id
op, Int
opPrec) (Id
arg, Int
argPrec) [a]
oArgs ((AssocEither -> Id) -> Bool) -> (AssocEither -> Id) -> Bool
forall a b. (a -> b) -> a -> b
$ (AssocEither -> Item a -> Id) -> Item a -> AssocEither -> Id
forall a b c. (a -> b -> c) -> b -> a -> c
flip AssocEither -> Item a -> Id
forall a. AssocEither -> Item a -> Id
getWeight Item a
argItem

reduceCompleted :: GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
reduceCompleted :: GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
reduceCompleted ga :: GlobalAnnos
ga table :: Table a
table toExpr :: ToExpr a
toExpr =
    (Item a -> [Item a] -> [Item a])
-> [Item a] -> [Item a] -> [Item a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Item a] -> [Item a] -> [Item a]
forall a. [Item a] -> [Item a] -> [Item a]
mergeItems ([Item a] -> [Item a] -> [Item a])
-> (Item a -> [Item a]) -> Item a -> [Item a] -> [Item a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalAnnos -> Table a -> ToExpr a -> Item a -> [Item a]
forall a. GlobalAnnos -> Table a -> ToExpr a -> Item a -> [Item a]
reduce GlobalAnnos
ga Table a
table ToExpr a
toExpr) [] ([Item a] -> [Item a])
-> ([Item a] -> [Item a]) -> [Item a] -> [Item a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item a -> Bool) -> [Item a] -> [Item a]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Token] -> Bool) -> (Item a -> [Token]) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> [Token]
forall a. Item a -> [Token]
rest)

recReduce :: GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
recReduce :: GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
recReduce ga :: GlobalAnnos
ga table :: Table a
table toExpr :: ToExpr a
toExpr items :: [Item a]
items =
    let reduced :: [Item a]
reduced = GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
forall a.
GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
reduceCompleted GlobalAnnos
ga Table a
table ToExpr a
toExpr [Item a]
items
        in if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
reduced then [Item a]
items
           else GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
forall a.
GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
recReduce GlobalAnnos
ga Table a
table ToExpr a
toExpr [Item a]
reduced [Item a] -> [Item a] -> [Item a]
forall a. [Item a] -> [Item a] -> [Item a]
`mergeItems` [Item a]
items

complete :: ToExpr a -> GlobalAnnos -> Table a -> [Item a] -> [Item a]
complete :: ToExpr a -> GlobalAnnos -> Table a -> [Item a] -> [Item a]
complete toExpr :: ToExpr a
toExpr ga :: GlobalAnnos
ga table :: Table a
table items :: [Item a]
items =
    let reducedItems :: [Item a]
reducedItems = GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
forall a.
GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
recReduce GlobalAnnos
ga Table a
table ToExpr a
toExpr ([Item a] -> [Item a]) -> [Item a] -> [Item a]
forall a b. (a -> b) -> a -> b
$
                       GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
forall a.
GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
reduceCompleted GlobalAnnos
ga Table a
table ToExpr a
toExpr [Item a]
items
        in [Item a]
reducedItems [Item a] -> [Item a] -> [Item a]
forall a. [a] -> [a] -> [a]
++ [Item a]
items

doPredict :: [Item a] -> ([Item a], [Item a])
doPredict :: [Item a] -> ([Item a], [Item a])
doPredict = (Item a -> Bool) -> [Item a] -> ([Item a], [Item a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ( \ Item { rest :: forall a. Item a -> [Token]
rest = [Token]
ts } ->
                      Bool -> Bool
not ([Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
ts) Bool -> Bool -> Bool
&& [Token] -> Token
forall a. [a] -> a
head [Token]
ts Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
termTok)

ordItem :: Item a -> Item a -> Ordering
ordItem :: Item a -> Item a -> Ordering
ordItem Item { index :: forall a. Item a -> Int
index = Int
i1, rest :: forall a. Item a -> [Token]
rest = [Token]
r1, rule :: forall a. Item a -> Id
rule = Id
n1 }
    Item { index :: forall a. Item a -> Int
index = Int
i2, rest :: forall a. Item a -> [Token]
rest = [Token]
r2, rule :: forall a. Item a -> Id
rule = Id
n2 } =
    (Int, [Token], Id) -> (Int, [Token], Id) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int
i1, [Token]
r1, Id
n1) (Int
i2, [Token]
r2, Id
n2)

ambigItems :: Item a -> Item a -> Item a
ambigItems :: Item a -> Item a -> Item a
ambigItems i1 :: Item a
i1@Item { ambigArgs :: forall a. Item a -> [[a]]
ambigArgs = [[a]]
ams1, args :: forall a. Item a -> [a]
args = [a]
as1 }
    Item { ambigArgs :: forall a. Item a -> [[a]]
ambigArgs = [[a]]
ams2, args :: forall a. Item a -> [a]
args = [a]
as2 } =
    Item a
i1 { ambigArgs :: [[a]]
ambigArgs = case [[a]]
ams1 [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]]
ams2 of
         [] -> [[a]
as1, [a]
as2]
         ams :: [[a]]
ams -> [[a]]
ams }

mergeItems :: [Item a] -> [Item a] -> [Item a]
mergeItems :: [Item a] -> [Item a] -> [Item a]
mergeItems [] i2 :: [Item a]
i2 = [Item a]
i2
mergeItems i1 :: [Item a]
i1 [] = [Item a]
i1
mergeItems (i1 :: Item a
i1 : r1 :: [Item a]
r1) (i2 :: Item a
i2 : r2 :: [Item a]
r2) =
    case Item a -> Item a -> Ordering
forall a. Item a -> Item a -> Ordering
ordItem Item a
i1 Item a
i2 of
    LT -> Item a
i1 Item a -> [Item a] -> [Item a]
forall a. a -> [a] -> [a]
: [Item a] -> [Item a] -> [Item a]
forall a. [Item a] -> [Item a] -> [Item a]
mergeItems [Item a]
r1 (Item a
i2 Item a -> [Item a] -> [Item a]
forall a. a -> [a] -> [a]
: [Item a]
r2)
    EQ -> Item a -> Item a -> Item a
forall a. Item a -> Item a -> Item a
ambigItems Item a
i1 Item a
i2 Item a -> [Item a] -> [Item a]
forall a. a -> [a] -> [a]
: [Item a] -> [Item a] -> [Item a]
forall a. [Item a] -> [Item a] -> [Item a]
mergeItems [Item a]
r1 [Item a]
r2
    GT -> Item a
i2 Item a -> [Item a] -> [Item a]
forall a. a -> [a] -> [a]
: [Item a] -> [Item a] -> [Item a]
forall a. [Item a] -> [Item a] -> [Item a]
mergeItems (Item a
i1 Item a -> [Item a] -> [Item a]
forall a. a -> [a] -> [a]
: [Item a]
r1) [Item a]
r2

type TokRules = Token -> Set.Set Rule

-- | the whole state for mixfix resolution
data Chart a = Chart
    { Chart a -> Table a
prevTable :: Table a
    , Chart a -> Int
currIndex :: Int
    , Chart a -> ([Item a], [Item a])
currItems :: ([Item a], [Item a])
    , Chart a -> Rules
rules :: Rules
    , Chart a -> TokRules
addRules :: TokRules
    , Chart a -> [Diagnosis]
solveDiags :: [Diagnosis] }

{- | make one scan, complete, and predict step.
The first function adds a type to the result.
The second function filters based on argument and operator info.
If filtering yields 'Nothing' further filtering by precedence is applied. -}
nextChart :: (a -> a -> a) -> ToExpr a -> GlobalAnnos
          -> Chart a -> (a, Token) -> Chart a
nextChart :: (a -> a -> a)
-> ToExpr a -> GlobalAnnos -> Chart a -> (a, Token) -> Chart a
nextChart addType :: a -> a -> a
addType toExpr :: ToExpr a
toExpr ga :: GlobalAnnos
ga st :: Chart a
st term :: (a, Token)
term@(_, tok :: Token
tok) = let
    table :: Table a
table = Chart a -> Table a
forall a. Chart a -> Table a
prevTable Chart a
st
    idx :: Int
idx = Chart a -> Int
forall a. Chart a -> Int
currIndex Chart a
st
    igz :: Bool
igz = Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
    (cItems :: [Item a]
cItems, sItems :: [Item a]
sItems) = Chart a -> ([Item a], [Item a])
forall a. Chart a -> ([Item a], [Item a])
currItems Chart a
st
    Rules cRules :: Set Rule
cRules sRules :: Set Rule
sRules = Chart a -> Rules
forall a. Chart a -> Rules
rules Chart a
st
    pItems :: [Item a]
pItems = if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
cItems Bool -> Bool -> Bool
&& Bool
igz then [Item a]
sItems else
        (Rule -> Item a) -> [Rule] -> [Item a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Rule -> Item a
forall a. Int -> Rule -> Item a
mkItem Int
idx) (Set Rule -> [Rule]
forall a. Set a -> [a]
Set.toList (Set Rule -> [Rule]) -> Set Rule -> [Rule]
forall a b. (a -> b) -> a -> b
$ Set Rule -> Set Rule -> Set Rule
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Rule
sRules (Set Rule -> Set Rule) -> Set Rule -> Set Rule
forall a b. (a -> b) -> a -> b
$ Chart a -> TokRules
forall a. Chart a -> TokRules
addRules Chart a
st Token
tok)
        [Item a] -> [Item a] -> [Item a]
forall a. [a] -> [a] -> [a]
++ [Item a]
sItems
    scannedItems :: [Item a]
scannedItems = (a -> a -> a) -> (a, Token) -> [Item a] -> [Item a]
forall a. (a -> a -> a) -> (a, Token) -> [Item a] -> [Item a]
scan a -> a -> a
addType (a, Token)
term [Item a]
pItems
    nextTable :: Table a
nextTable = if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
cItems Bool -> Bool -> Bool
&& Bool
igz then Table a
table else
        Int -> [Item a] -> Table a -> Table a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
idx ((Rule -> Item a) -> [Rule] -> [Item a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Rule -> Item a
forall a. Int -> Rule -> Item a
mkItem Int
idx) (Set Rule -> [Rule]
forall a. Set a -> [a]
Set.toList Set Rule
cRules) [Item a] -> [Item a] -> [Item a]
forall a. [a] -> [a] -> [a]
++ [Item a]
cItems) Table a
table
    completedItems :: [Item a]
completedItems = ToExpr a -> GlobalAnnos -> Table a -> [Item a] -> [Item a]
forall a.
ToExpr a -> GlobalAnnos -> Table a -> [Item a] -> [Item a]
complete ToExpr a
toExpr GlobalAnnos
ga Table a
nextTable ([Item a] -> [Item a]) -> [Item a] -> [Item a]
forall a b. (a -> b) -> a -> b
$ (Item a -> Item a -> Ordering) -> [Item a] -> [Item a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Item a -> Item a -> Ordering
forall a. Item a -> Item a -> Ordering
ordItem [Item a]
scannedItems
    nextIdx :: Int
nextIdx = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
    in if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
pItems Bool -> Bool -> Bool
&& Bool
igz then Chart a
st else Chart a
st
    { prevTable :: Table a
prevTable = Table a
nextTable
    , currIndex :: Int
currIndex = Int
nextIdx
    , currItems :: ([Item a], [Item a])
currItems = [Item a] -> ([Item a], [Item a])
forall a. [Item a] -> ([Item a], [Item a])
doPredict [Item a]
completedItems
    , solveDiags :: [Diagnosis]
solveDiags =
        [ DiagKind -> [Char] -> Range -> Diagnosis
Diag DiagKind
Error ("unexpected mixfix token: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Token -> [Char]
tokStr Token
tok) (Range -> Diagnosis) -> Range -> Diagnosis
forall a b. (a -> b) -> a -> b
$ Token -> Range
tokPos Token
tok
        | [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
scannedItems ] [Diagnosis] -> [Diagnosis] -> [Diagnosis]
forall a. [a] -> [a] -> [a]
++ Chart a -> [Diagnosis]
forall a. Chart a -> [Diagnosis]
solveDiags Chart a
st }

-- | add intermediate diagnostic messages
mixDiags :: [Diagnosis] -> Chart a -> Chart a
mixDiags :: [Diagnosis] -> Chart a -> Chart a
mixDiags ds :: [Diagnosis]
ds st :: Chart a
st = Chart a
st { solveDiags :: [Diagnosis]
solveDiags = [Diagnosis]
ds [Diagnosis] -> [Diagnosis] -> [Diagnosis]
forall a. [a] -> [a] -> [a]
++ Chart a -> [Diagnosis]
forall a. Chart a -> [Diagnosis]
solveDiags Chart a
st }

-- | postfix and prefix rules
data Rules = Rules
  { Rules -> Set Rule
postRules :: Set.Set Rule
  , Rules -> Set Rule
scanRules :: Set.Set Rule }

emptyRules :: Rules
emptyRules :: Rules
emptyRules = Rules :: Set Rule -> Set Rule -> Rules
Rules
  { postRules :: Set Rule
postRules = Set Rule
forall a. Set a
Set.empty
  , scanRules :: Set Rule
scanRules = Set Rule
forall a. Set a
Set.empty }

-- | presort rules
partitionRules :: [Rule] -> Rules
partitionRules :: [Rule] -> Rules
partitionRules l :: [Rule]
l =
  let (p :: [Rule]
p, s :: [Rule]
s) = (Rule -> Bool) -> [Rule] -> ([Rule], [Rule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ( \ (_, _, ts :: [Token]
ts) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
ts Bool -> Bool -> Bool
|| [Token] -> Token
forall a. [a] -> a
head [Token]
ts Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
termTok) [Rule]
l
  in Set Rule -> Set Rule -> Rules
Rules ([Rule] -> Set Rule
forall a. Ord a => [a] -> Set a
Set.fromList [Rule]
p) (Set Rule -> Rules) -> Set Rule -> Rules
forall a b. (a -> b) -> a -> b
$ [Rule] -> Set Rule
forall a. Ord a => [a] -> Set a
Set.fromList [Rule]
s

-- | create the initial chart
initChart :: TokRules -> Rules -> Chart a
initChart :: TokRules -> Rules -> Chart a
initChart adder :: TokRules
adder ruleS :: Rules
ruleS = Chart :: forall a.
Table a
-> Int
-> ([Item a], [Item a])
-> Rules
-> TokRules
-> [Diagnosis]
-> Chart a
Chart
    { prevTable :: Table a
prevTable = Table a
forall k a. Map k a
Map.empty
    , currIndex :: Int
currIndex = 0
    , currItems :: ([Item a], [Item a])
currItems = ([], [])
    , rules :: Rules
rules = Rules
ruleS
    , addRules :: TokRules
addRules = TokRules
adder
    , solveDiags :: [Diagnosis]
solveDiags = [] }

-- | extract resolved result
getResolved :: (a -> ShowS) -> Range -> ToExpr a -> Chart a -> Result a
getResolved :: (a -> [Char] -> [Char]) -> Range -> ToExpr a -> Chart a -> Result a
getResolved pp :: a -> [Char] -> [Char]
pp p :: Range
p toExpr :: ToExpr a
toExpr st :: Chart a
st = let
   (predicted :: [Item a]
predicted, items' :: [Item a]
items') = Chart a -> ([Item a], [Item a])
forall a. Chart a -> ([Item a], [Item a])
currItems Chart a
st
   ds :: [Diagnosis]
ds = Chart a -> [Diagnosis]
forall a. Chart a -> [Diagnosis]
solveDiags Chart a
st
   items :: [Item a]
items = if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
items' Bool -> Bool -> Bool
&& [Diagnosis] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnosis]
ds then [Item a]
predicted else [Item a]
items'
   in case [Item a]
items of
   [] -> Bool -> Result a -> Result a
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Diagnosis] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnosis]
ds) (Result a -> Result a) -> Result a -> Result a
forall a b. (a -> b) -> a -> b
$ [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [Diagnosis]
ds Maybe a
forall a. Maybe a
Nothing
   _ -> let
     (finals :: [Item a]
finals, r1 :: [Item a]
r1) = (Item a -> Bool) -> [Item a] -> ([Item a], [Item a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool) -> (Item a -> Int) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> Int
forall a. Item a -> Int
index) [Item a]
items
     (result :: [Item a]
result, r2 :: [Item a]
r2) = (Item a -> Bool) -> [Item a] -> ([Item a], [Item a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Token] -> Bool) -> (Item a -> [Token]) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> [Token]
forall a. Item a -> [Token]
rest) [Item a]
finals
     in case [Item a]
result of
     [] -> let
       expected :: [Item a]
expected = if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
r2 then (Item a -> Bool) -> [Item a] -> [Item a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Item a -> Bool) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Token] -> Bool) -> (Item a -> [Token]) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> [Token]
forall a. Item a -> [Token]
rest) [Item a]
r1 else [Item a]
r2
       withpos :: [Item a]
withpos = (Item a -> Bool) -> [Item a] -> [Item a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Item a -> Bool) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Bool
isNullRange (Range -> Bool) -> (Item a -> Range) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> Range
forall a. Item a -> Range
posList) [Item a]
expected
       (q :: Range
q, errs :: [Item a]
errs) = if [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Item a]
withpos then (Range
p, [Item a]
expected) else
         ((Item a -> Range) -> [Item a] -> Range
forall a. (a -> Range) -> [a] -> Range
concatMapRange (Range -> Range
reverseRange (Range -> Range) -> (Item a -> Range) -> Item a -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> Range
forall a. Item a -> Range
posList) [Item a]
withpos, [Item a]
withpos)
       in [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result (DiagKind -> [Char] -> Range -> Diagnosis
Diag DiagKind
Error ("expected further mixfix token: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take 5 ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubOrd ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (Item a -> [Char]) -> [Item a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Token -> [Char]
tokStr (Token -> [Char]) -> (Item a -> Token) -> Item a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Token
forall a. [a] -> a
head ([Token] -> Token) -> (Item a -> [Token]) -> Item a -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> [Token]
forall a. Item a -> [Token]
rest) [Item a]
errs)) Range
q Diagnosis -> [Diagnosis] -> [Diagnosis]
forall a. a -> [a] -> [a]
: [Diagnosis]
ds)
          Maybe a
forall a. Maybe a
Nothing
     [har :: Item a
har] -> case Item a -> [[a]]
forall a. Item a -> [[a]]
ambigs Item a
har of
       [] -> case ToExpr a -> Item a -> [a]
forall a. ToExpr a -> Item a -> [a]
mkAmbigs ToExpr a
toExpr Item a
har of
         [] -> [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [Diagnosis]
ds (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ (a, Range) -> a
forall a b. (a, b) -> a
fst ((a, Range) -> a) -> (a, Range) -> a
forall a b. (a -> b) -> a -> b
$ ToExpr a -> Item a -> (a, Range)
forall a. ToExpr a -> Item a -> (a, Range)
mkExpr ToExpr a
toExpr Item a
har
         ambAs :: [a]
ambAs -> [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result ((a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
forall a. (a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
showAmbigs a -> [Char] -> [Char]
pp Range
p (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take 5 [a]
ambAs) Diagnosis -> [Diagnosis] -> [Diagnosis]
forall a. a -> [a] -> [a]
: [Diagnosis]
ds) Maybe a
forall a. Maybe a
Nothing
       ams :: [[a]]
ams -> [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result (([a] -> Diagnosis) -> [[a]] -> [Diagnosis]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
forall a. (a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
showAmbigs a -> [Char] -> [Char]
pp Range
p) (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
take 5 [[a]]
ams) [Diagnosis] -> [Diagnosis] -> [Diagnosis]
forall a. [a] -> [a] -> [a]
++ [Diagnosis]
ds) Maybe a
forall a. Maybe a
Nothing
     _ -> [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result ((a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
forall a. (a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
showAmbigs a -> [Char] -> [Char]
pp Range
p ((Item a -> a) -> [Item a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a, Range) -> a
forall a b. (a, b) -> a
fst ((a, Range) -> a) -> (Item a -> (a, Range)) -> Item a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToExpr a -> Item a -> (a, Range)
forall a. ToExpr a -> Item a -> (a, Range)
mkExpr ToExpr a
toExpr) [Item a]
result) Diagnosis -> [Diagnosis] -> [Diagnosis]
forall a. a -> [a] -> [a]
: [Diagnosis]
ds)
       Maybe a
forall a. Maybe a
Nothing

showAmbigs :: (a -> ShowS) -> Range -> [a] -> Diagnosis
showAmbigs :: (a -> [Char] -> [Char]) -> Range -> [a] -> Diagnosis
showAmbigs pp :: a -> [Char] -> [Char]
pp p :: Range
p as :: [a]
as = DiagKind -> [Char] -> Range -> Diagnosis
Diag DiagKind
Error
    ("ambiguous mixfix term\n  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char])
-> (a -> [Char] -> [Char]) -> [a] -> [Char] -> [Char]
forall a.
([Char] -> [Char])
-> (a -> [Char] -> [Char]) -> [a] -> [Char] -> [Char]
showSepList ([Char] -> [Char] -> [Char]
showString "\n  ") a -> [Char] -> [Char]
pp
     (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take 5 [a]
as) "") Range
p