{-# LANGUAGE FlexibleInstances #-}

module GLL.Combinators.Visit.Join where

import GLL.Types.Derivations
import GLL.Types.Grammar
import GLL.Combinators.Visit.Sem
import GLL.Combinators.Visit.Grammar
import GLL.Combinators.Options

import GLL.Types.TypeCompose (OO(..),unOO)
import Data.List (intercalate)
import Data.Text (pack)

-- | A combinator expression representing a symbol.
-- A 'SymbExpr' either represents a terminal or a nonterminal.
-- In the latter case it is constructed with (a variant of) '<:=>' and 
-- adds a rule to the grammar of which the represented symbol is the 
-- left-hand side.
data SymbExpr t a = SymbExpr (Symbol t, Grammar_Expr t, Sem_Symb t a)
-- | A combinator expression representing a BNF-grammar. The terminals of
-- the grammar are of type 't'. When used to parse, the expression yields
-- semantic results of type 'a'. 
type BNF t a = SymbExpr t a
-- | 
-- A combinator expression representing an alternative: 
-- the right-hand side of a production.
data AltExpr t a = AltExpr ([Symbol t], Grammar_Expr t, Sem_Alt t a)

-- | A list of alternatives represents the right-hand side of a rule.
type AltExprs = OO [] AltExpr

mkNtRule :: (Show t, Ord t, HasAlts b) => Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule :: forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule Bool
use_ctx Bool
left_biased String
x' b t a
altPs' =
    let vas1 :: [[Symbol t]]
vas1 = forall a b. (a -> b) -> [a] -> [b]
map (\(AltExpr ([Symbol t]
f,Grammar_Expr t
_,Sem_Alt t a
_)) -> [Symbol t]
f) [AltExpr t a]
altPs 
        vas2 :: [Grammar_Expr t]
vas2 = forall a b. (a -> b) -> [a] -> [b]
map (\(AltExpr ([Symbol t]
_,Grammar_Expr t
s,Sem_Alt t a
_)) -> Grammar_Expr t
s) [AltExpr t a]
altPs
        vas3 :: [Sem_Alt t a]
vas3 = forall a b. (a -> b) -> [a] -> [b]
map (\(AltExpr ([Symbol t]
_,Grammar_Expr t
_,Sem_Alt t a
t)) -> Sem_Alt t a
t) [AltExpr t a]
altPs
        alts :: [Prod t]
alts  = forall a b. (a -> b) -> [a] -> [b]
map (forall t. Nt -> Symbols t -> Prod t
Prod Nt
x) [[Symbol t]]
vas1    
        altPs :: [AltExpr t a]
altPs = forall (a :: * -> * -> *) t b.
(HasAlts a, Show t, Ord t) =>
a t b -> [AltExpr t b]
altsOf b t a
altPs'
        x :: Nt
x     = String -> Nt
pack String
x'
    in forall t a.
(Symbol t, Grammar_Expr t, Sem_Symb t a) -> SymbExpr t a
SymbExpr (forall t. Nt -> Symbol t
Nt Nt
x, forall t. Nt -> [Prod t] -> [Grammar_Expr t] -> Grammar_Expr t
grammar_nterm Nt
x [Prod t]
alts [Grammar_Expr t]
vas2, forall t a.
Bool -> Bool -> Nt -> [Prod t] -> [Sem_Alt t a] -> Sem_Symb t a
sem_nterm Bool
use_ctx Bool
left_biased Nt
x [Prod t]
alts [Sem_Alt t a]
vas3)

join_apply :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b
join_apply :: forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
join_apply a -> b
f s t a
p' = 
    let SymbExpr (Symbol t
vpa1,Grammar_Expr t
vpa2,Sem_Symb t a
vpa3) = forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> BNF t b
mkRule s t a
p' in forall t a.
([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
AltExpr
          ([Symbol t
vpa1],forall t. Grammar_Expr t -> Grammar_Expr t
grammar_apply Grammar_Expr t
vpa2, forall t a b. Ord t => (a -> b) -> Sem_Symb t a -> Sem_Alt t b
sem_apply a -> b
f Sem_Symb t a
vpa3)

join_seq :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => 
              CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
join_seq :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
join_seq CombinatorOptions
local_opts i t (a -> b)
pl' s t a
pr' = 
  let AltExpr ([Symbol t]
vimp1,Grammar_Expr t
vimp2,Sem_Alt t (a -> b)
vimp3) = forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt i t (a -> b)
pl'
      SymbExpr (Symbol t
vpa1,Grammar_Expr t
vpa2,Sem_Symb t a
vpa3)  = forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> BNF t b
mkRule s t a
pr' in forall t a.
([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
AltExpr
  ([Symbol t]
vimp1forall a. [a] -> [a] -> [a]
++[Symbol t
vpa1], forall t. Grammar_Expr t -> Grammar_Expr t -> Grammar_Expr t
grammar_seq Grammar_Expr t
vimp2 Grammar_Expr t
vpa2, forall t a b.
Ord t =>
CombinatorOptions
-> Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b
sem_seq CombinatorOptions
local_opts Sem_Alt t (a -> b)
vimp3 Sem_Symb t a
vpa3)

-- | 
-- Class for lifting to 'SymbExpr'.
class IsSymbExpr a where
    toSymb :: (Show t, Ord t) => a t b -> SymbExpr t b
    -- | Synonym of 'toSymb' for creating /derived combinators/. 
    mkRule :: (Show t, Ord t) => a t b -> BNF t b
    mkRule = forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> BNF t b
toSymb

instance IsSymbExpr AltExpr where
    toSymb :: forall t b. (Show t, Ord t) => AltExpr t b -> BNF t b
toSymb = forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> BNF t b
toSymb forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) 

instance IsSymbExpr SymbExpr where
    toSymb :: forall t b. (Show t, Ord t) => BNF t b -> BNF t b
toSymb = forall a. a -> a
id 

instance IsSymbExpr AltExprs where
    toSymb :: forall t b. (Show t, Ord t) => AltExprs t b -> BNF t b
toSymb AltExprs t b
a = forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule Bool
False Bool
False String
mkName AltExprs t b
a 
        where mkName :: String
mkName = String
"_" forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"|" (forall a b. (a -> b) -> [a] -> [b]
map forall {t} {a}. Show t => AltExpr t a -> String
op (forall (f :: * -> *) (j :: * -> * -> *) a b.
OO f j a b -> f (j a b)
unOO AltExprs t b
a)) forall a. [a] -> [a] -> [a]
++ String
")"
                where op :: AltExpr t a -> String
op (AltExpr ([Symbol t]
rhs,Grammar_Expr t
_,Sem_Alt t a
_)) = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"*" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Symbol t]
rhs) forall a. [a] -> [a] -> [a]
++ String
")"
              
                
-- | 
-- Class for lifting to 'AltExprs'. 
class HasAlts a where
    altsOf :: (Show t, Ord t) => a t b -> [AltExpr t b]

instance HasAlts AltExpr where
    altsOf :: forall t b. (Show t, Ord t) => AltExpr t b -> [AltExpr t b]
altsOf = (forall a. a -> [a] -> [a]
:[])

instance HasAlts SymbExpr where
    altsOf :: forall t b. (Show t, Ord t) => SymbExpr t b -> [AltExpr t b]
altsOf = forall (a :: * -> * -> *) t b.
(HasAlts a, Show t, Ord t) =>
a t b -> [AltExpr t b]
altsOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt

instance HasAlts AltExprs where
    altsOf :: forall t b. (Show t, Ord t) => AltExprs t b -> [AltExpr t b]
altsOf = forall (f :: * -> *) (j :: * -> * -> *) a b.
OO f j a b -> f (j a b)
unOO 

-- | 
-- Class for lifting to 'AltExpr'. 
class IsAltExpr a where
    toAlt :: (Show t, Ord t) => a t b -> AltExpr t b

instance IsAltExpr AltExpr where
    toAlt :: forall t b. (Show t, Ord t) => AltExpr t b -> AltExpr t b
toAlt = forall a. a -> a
id

instance IsAltExpr SymbExpr where
    toAlt :: forall t b. (Show t, Ord t) => SymbExpr t b -> AltExpr t b
toAlt SymbExpr t b
p = forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
join_apply forall a. a -> a
id SymbExpr t b
p

instance IsAltExpr AltExprs where
    toAlt :: forall t b. (Show t, Ord t) => AltExprs t b -> AltExpr t b
toAlt = forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> BNF t b
mkRule