Interface.hs

{-# LANGUAGE TypeOperators, FlexibleInstances #-}

module GLL.Combinators.Interface (
    SymbParser(..), IMParser(..), SPPF,
    parse, parseString, grammar, sppf, 
    char, token, Token(..),
    epsilon, satisfy,
    many, some, optional,
    (<$>),
    (<$),
    (<*>),
    (<*),
    (<::=>),(<:=>),
    (<|>)
    ) where

import Prelude hiding ((<*>), (<*), (<$>), (<$))

import GLL.Combinators.Options
import GLL.Common
import GLL.Types.Grammar hiding (epsilon)
import GLL.Types.Abstract
import GLL.Parser (gllSPPF, pNodeLookup, ParseResult(..))

import Control.Compose
import Control.Monad
import Data.List (unfoldr,intersperse)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Set as S

type SymbVisit1 b = Symbol 
type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt]
type SymbVisit3 b = PCOptions -> ParseContext -> SPPF -> Int -> Int -> [b]

type IMVisit1 b   = [Symbol] 
type IMVisit2 b   = M.Map Nt [Alt] -> M.Map Nt [Alt]
type IMVisit3 b   = PCOptions -> (Alt,Int) -> ParseContext -> SPPF -> Int -> Int -> [b]

type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt))

data SymbParser b = SymbParser (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b)
data IMParser b   = IMParser (IMVisit1 b, IMVisit2 b, IMVisit3 b)

parse' :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> (Grammar, ParseResult, [a])
parse' opts p' input' =  
    let input               = input' ++ [Char 'z']
        SymbParser (Nt start,vpa2,vpa3) = toSymb (id <$> p' <* char 'z')
        snode               = (start, 0, m)
        m                   = length input
        rules               = vpa2 M.empty
        as                  = vpa3 opts IM.empty sppf 0 m
        grammar = Grammar start [] [ Rule x alts [] | (x, alts) <- M.assocs rules ]
        parse_res           = gllSPPF grammar input
        sppf                = sppf_result parse_res
    in (grammar, parse_res, as)

-- | The grammar of a given parser
grammar :: (IsSymbParser s) => s a -> Grammar
grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])

-- | The semantic results of a parser, given a string of Tokens
parse :: (IsSymbParser s) => s a -> [Token] -> [a]
parse = parseWithOptions defaultOptions 

-- | Change the behaviour of the parse using GLL.Combinators.Options
parseWithOptions :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> [a]
parseWithOptions opts p = (\(_,_,t) -> t) . parse' opts p

-- | Parse a string of characters
parseString :: (IsSymbParser s) => s a -> String -> [a]
parseString = parseStringWithOptions defaultOptions

-- | Parse a string of characters using options
parseStringWithOptions :: (IsSymbParser s) => PCOptions -> s a -> String -> [a]
parseStringWithOptions opts p  = parseWithOptions opts p . map Char

-- | Get the SPPF produced by parsing the given input with the given parser
sppf :: (IsSymbParser s) => s a -> [Token] -> ParseResult
sppf p str =  (\(_,s,_) -> s) $ parse' defaultOptions p str

inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool
inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx
 where  inner = maybe False (S.member x) . IM.lookup r

toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext
toParseContext ctx (x, l, r) = IM.alter inner l ctx
 where  inner mm = case mm of 
                    Nothing -> Just $ singleRX
                    Just m  -> Just $ IM.insertWith (S.union) r singleX m
        singleRX = IM.singleton r singleX
        singleX  = S.singleton x

infixl 2 <::=>
-- | Use this combinator on all combinators that might have an infinite
--  number of derivations for some input string. A non-terminal has
--  this property if and only if it is left-recursive and would be
--  left-recursive if all the right-hand sides of the productions of the
--  grammar are reversed.
(<::=>) :: (HasAlts b) => String -> b a -> SymbParser a 
x <::=> altPs' =
    let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ]
        alts  = map (Alt x) vas1    
        altPs = unO $ altsOf altPs' in SymbParser
        (Nt x
       ,\rules ->
           if x `M.member` rules 
            then rules 
            else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs)
       ,\opts ctx sppf l r -> 
        let ctx' = ctx `toParseContext` (x,l,r)
            vas2 = [ va3 opts (alt,length rhs) ctx' sppf l r 
                   | (alt@(Alt _ rhs), va3) <- zip alts (map (\(IMParser (_,_,t)) -> t) altPs) ]
        in if ctx `inParseContext` (Nt x, l, r) 
                then []
                else concatChoice opts vas2
       )

infixl 2 <:=>
-- | Use this combinator on all recursive non-terminals
(<:=>) :: (HasAlts b) => String -> b a -> SymbParser a 
x <:=> altPs' =
    let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ]
        alts  = map (Alt x) vas1    
        altPs = unO $ altsOf altPs' in SymbParser
        (Nt x
       ,\rules ->
           if x `M.member` rules 
            then rules 
            else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs)
       ,\opts ctx sppf l r -> 
        let vas2 = [ va3 opts (alt,length rhs) ctx sppf l r 
                   | (alt@(Alt _ rhs), va3) <- zip alts (map (\(IMParser (_,_,t)) -> t) altPs) ]
        in concatChoice opts vas2
       )

concatChoice :: PCOptions -> [[a]] -> [a]
concatChoice opts ress = if left_biased_choice opts
                            then firstRes ress
                            else concat ress
 where  firstRes []         = []
        firstRes ([]:ress)  = firstRes ress
        firstRes (res:_)    = res

infixl 4 <*>
(<*>) :: (IsIMParser i, IsSymbParser s) => i (a -> b) -> s a -> IMParser b
pl' <*> pr' = 
  let IMParser (vimp1,vimp2,vimp3) = toImp pl'
      SymbParser (vpa1,vpa2,vpa3)  = toSymb pr' in IMParser
  (vimp1++[vpa1]
  ,\rules ->  let rules1  = vpa2 rules
                  rules2  = vimp2 rules1 in rules2
  ,\opts (alt@(Alt x rhs),j) ctx sppf l r ->
    let ks     = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)
        filter = maybe id id $ pivot_select opts
    in [ a2b a  | k <- (filter ks)  , a <- vpa3 opts ctx sppf k r
                                    , a2b <- vimp3 opts(alt,j-1) ctx sppf l k ]
  )


infixl 4 <*
(<*) :: (IsIMParser i, IsSymbParser s) => i b -> s a -> IMParser b

pl' <* pr' = 
  let IMParser (vimp1,vimp2,vimp3) = toImp pl'
      SymbParser (vpa1,vpa2,vpa3)  = toSymb pr' in IMParser
  (vimp1++[vpa1]
  ,\rules ->
    let rules1  = vpa2 rules
        rules2  = vimp2 rules1
    in rules2
  ,\opts (alt@(Alt x rhs),j) ctx sppf l r ->
    let ks      = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)
        filter  = maybe id id $ pivot_select opts
    in [ b | k <- (filter ks)   , a <- vpa3 opts ctx sppf k r
                                , b <- vimp3 opts (alt,j-1) ctx sppf l k ]
  )

infixl 4 <$>
(<$>) :: (IsSymbParser s) => (a -> b) -> s a -> IMParser b
f <$> p' = 
    let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser
      ([vpa1]
      ,\rules -> 
        vpa2 rules
      ,\opts (alt,j) ctx sppf l r ->
        let a = vpa3 opts ctx sppf l r
        in maybe [] (const (map f a)) $ sppf `pNodeLookup` ((alt,1),l,r)
      )

infixl 4 <$
(<$) :: (IsSymbParser s) => b -> s a -> IMParser b
f <$ p' = 
    let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser 
      ([vpa1]
      ,\rules -> 
        vpa2 rules
      ,\opts (alt,j) ctx sppf l r ->
        let a = vpa3 opts ctx sppf l r
        in maybe [] (const (map (const f) a)) $ sppf `pNodeLookup` ((alt,1),l,r)
      )

infixr 3 <|>
(<|>) :: (IsIMParser i, HasAlts b) => i a -> b a -> ([] :. IMParser) a
l' <|> r' = let l = toImp l'
                r = altsOf r'
            in O (l : unO r)

raw_parser :: Token -> (Token -> a) -> SymbParser a 
raw_parser t f = SymbParser (Term t, id,\_ _ _ _ _ -> [f t])

token :: Token -> SymbParser Token
token t = raw_parser t id 

char :: Char -> SymbParser Char
char c = raw_parser (Char c) (\(Char c) -> c) 

epsilon :: SymbParser ()
epsilon = raw_parser (Epsilon) (\_ -> ()) 

satisfy :: a -> IMParser a
satisfy a = a <$ epsilon

many :: SymbParser a -> SymbParser [a]
many p = SymbParser f
 where  SymbParser (myx,_,_) = p
        SymbParser f = many_ ("(" ++ show myx ++ ")^") p

many_ x p = x <:=> (:) <$> p <*> many_ x p <|> [] <$ epsilon

some :: SymbParser a -> SymbParser [a]
some p = SymbParser f
 where  SymbParser (myx,_, _) = p
        SymbParser f = some_ ("(" ++ show myx ++ ")+") p 

some_ x p = x <:=> (:) <$> p <*> some_ x p <|> (:[]) <$> p

optional :: SymbParser a -> SymbParser (Maybe a)
optional p = SymbParser f
    where SymbParser (myx, _, _) = p 
          SymbParser f = optional_ ("(" ++ show myx ++ ")?") p

optional_ x p = x <:=> Just <$> p <|> (Nothing <$ epsilon)

class HasAlts a where
    altsOf :: a b -> ([] :. IMParser) b

instance HasAlts IMParser where
    altsOf = O . (:[])

instance HasAlts SymbParser where
    altsOf = altsOf . toImp

instance HasAlts ([] :. IMParser) where
    altsOf = id

class IsIMParser a where
    toImp :: a b -> IMParser b

instance IsIMParser IMParser where
    toImp = id

instance IsIMParser SymbParser where
    toImp p = id <$> p

instance IsIMParser ([] :. IMParser) where
    toImp = toImp . toSymb

class IsSymbParser a where
    toSymb :: a b -> SymbParser b

instance IsSymbParser IMParser where
    toSymb = toSymb . O . (:[]) 

instance IsSymbParser SymbParser where
    toSymb = id 

instance IsSymbParser ([] :. IMParser) where
    toSymb a = mkName <:=> a 
        where mkName = "_" ++ concat (intersperse "|" (map op (unO a)))
                where op (IMParser (rhs,_,_)) = concat (intersperse "*" (map show rhs))