{-# LANGUAGE ExistentialQuantification, GADTs, EmptyDataDecls,
    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

module Language.Grammars.Grammar where

import Language.AbstractSyntax.TTTAS
--import Data.HList

import Control.Applicative


-------------------------------------------
-- GRAMMAR REPRESENTATION
-------------------------------------------


data Grammar a  
  = forall env . Grammar  (Ref a env)  
                          (FinalEnv (Productions NF) env)


type GramEnv     = Env (Productions NF)
type PreGramEnv  = Env (Productions TL)



------------------------
-- Productions
------------------------

-- Labels for a production
data TL   -- toplevel production
data FL a -- fixpoint level production
data NF   -- no fixpoint production



-- The datatype to represent an applicative style production
data Prod l a env where
      Star      ::  Prod l (a->b) env -> Prod l  a      env 
                ->  Prod l b  env
      FlipStar  ::  Prod NF a     env -> Prod NF (a->b) env 
                ->  Prod NF b  env
      Sym       ::  Symbol a t env                         
                ->  Prod l a  env
      Pure      ::  a                                      
                ->  Prod l a  env

      -- internally used for recursion in productions
      Fix       ::  Productions (FL a) a env               
                ->  Prod TL     a  env
      Var       ::  Prod (FL a) a  env 



newtype Productions l a env 
  = PS {unPS :: [Prod l a env]}

newtype PreProductions l env a 
  = PP {unPP :: [Prod l a env]}

--------------------------
-- Symbols
--------------------------


-- Labels for a symbol
data TTerm -- Terminal
data TNonT -- Non terminal
data TAttT -- Attributed terminal


-- | Represents a symbol in a production, either a terminal or non terminal. 
--  Additional attributed terminal symbols exist for common lexical structures.
data Symbol a t env where
  Term    :: String    ->  Symbol  (DTerm String)    TTerm   env

  Nont    :: Ref a env ->  Symbol  a                 TNonT   env
  -- attributed terminals
  TermInt   ::             Symbol  (DTerm Int)       TAttT   env
  TermChar  ::             Symbol  (DTerm Char)      TAttT   env
  TermVarid ::             Symbol  (DTerm String)    TAttT   env
  TermConid ::             Symbol  (DTerm String)    TAttT   env
  TermOp    ::             Symbol  (DTerm String)    TAttT   env 
  TermAnyOf     :: [Char] ->     Symbol  (DTerm Char)      TAttT   env
  TermAnyExcept :: [Char] ->     Symbol  (DTerm Char)      TAttT   env


-- | Gets the reference into the environment from the non terminal.  
getRefNT :: Symbol a TNonT env -> Ref a env
getRefNT (Nont ref) = ref



-- | Matches two symbols
matchSym  ::  Symbol a t1 env -> Symbol b t2 env 
          ->  Maybe (Equal (a,t1) (b,t2))
matchSym (Nont x)           (Nont y)                        = pairEq $ match x y
matchSym (Term x)           (Term y)            | x == y    = Just Eq
matchSym TermInt            TermInt                         = Just Eq
matchSym TermVarid          TermVarid                       = Just Eq
matchSym TermConid          TermConid                       = Just Eq
matchSym TermOp             TermOp                          = Just Eq
matchSym (TermAnyOf cs)     (TermAnyOf cs')     | cs == cs' = Just Eq
matchSym (TermAnyExcept cs) (TermAnyExcept cs') | cs == cs' = Just Eq
matchSym _          _                                       = Nothing

pairEq :: Maybe (Equal a b) -> Maybe (Equal (a,t) (b,t))
pairEq (Just Eq) = Just Eq
pairEq Nothing   = Nothing


-- Smart constructors for symbols
int   ::  Symbol (DTerm Int)     TAttT  env
char  ::  Symbol (DTerm Char)    TAttT  env
var, con, op     ::  Symbol (DTerm String)  TAttT  env
anyOf, anyExcept :: [Char] -> Symbol (DTerm Char) TAttT env

int       = TermInt
char      = TermChar
var       = TermVarid
con       = TermConid
op        = TermOp
anyOf     = TermAnyOf
anyExcept = TermAnyExcept


-------------------------
-- DTerm
-------------------------


type Line      = Int
type Column    = Int
type Filename  = String

data Pos  =  Pos      !Line !Column 
          |  PosFile  !Line !Column Filename
  deriving (Eq)

instance Show Pos where
 show (Pos (-1) (-1)) = "Built-in"
 show (Pos l    c)    = "Line: " ++ show l ++ " Column: " ++ show c
 show (PosFile (-1) (-1) _)  = "Built-in"
 show (PosFile l    c    f)  = "Line: " ++ show l ++ " Column: " ++ show c ++ " File: " ++ f
 
data DTerm a = DTerm {pos :: Pos, value :: a}
  deriving (Show, Eq)

mkDTerm :: a -> DTerm a
mkDTerm v = DTerm (Pos 0 0) v


------------------------
-- APPLICATIVE INTERFACE

-- | Lifts a single symbol into a singleton PreProductions
sym  ::  Symbol a  t  env -> PreProductions l env a
sym  s = PP [ Sym $ s ]

-- | Lifts a non terminal into a singleton PreProductions
nt :: Symbol a  TNonT  env -> PreProductions l env a
nt s = sym s

ntPrd :: Symbol a  TNonT  env -> PreProductions l env a
ntPrd s =  id <$> nt s
 

-- | Lifts a string, as terminal into a singleton PreProductions
tr ::  String -> PreProductions l env (DTerm String)
tr s = PP [ Sym $ Term s ]


-- | Conversion between Productions and PreProductions
prod :: PreProductions l env a -> Productions l a env
prod (PP ps) = PS ps

-- | A PreProductions for a variable used on fixpoint level
varPrd   ::  PreProductions (FL a) env a
varPrd    = PP [ Var ]


-- | The fixpoint of a production
fixPrd  ::  PreProductions (FL a) env a -> PreProductions TL env a
fixPrd p  = PP [ (Fix . prod) p ]


instance Functor (PreProductions l env) where
 fmap f (PP p) = PP [ Star (Pure f) p' | p' <- p ]

instance Applicative (PreProductions l env) where
 pure f = PP [ Pure f ]
 
 (PP f) <*> (PP g) = PP [ Star f' g' | f' <- f, g' <- g ]

instance Alternative (PreProductions l env) where
 empty = PP []
 
 (PP f) <|> (PP g) = PP (f ++ g)
{-
 some p = fixPrd (one <|> more)
     where  one  = (:[]) <$> toFL p 
            more = (:)   <$> toFL p <*> varPrd


 many p = fixPrd (none <|> more) 
     where  none = pure [] 
            more = (:)   <$> toFL p <*> varPrd

toFL :: PreProductions l env a -> PreProductions (FL b) env a
toFL (PP p) = PP $ map prodToFL p

prodToFL :: Prod l a env -> Prod (FL b) a env
prodToFL (Star      f  g)  = Star      (prodToFL f) (prodToFL g)
prodToFL (FlipStar  f  g)  = FlipStar  (prodToFL f) (prodToFL g)
prodToFL (Sym       s)     = Sym s
prodToFL (Pure      a)     = Pure a
prodToFL (Fix       f)     = Fix f
prodToFL Var               = error "ERROR: Language.Grammars.Grammar:1"
-}

pSome :: PreProductions (FL [a]) env a -> PreProductions TL env [a]
pSome p = fixPrd (one <|> more)
     where  one  = (:[]) <$> p 
            more = (:)   <$> p <*> varPrd

pMany :: PreProductions (FL [a]) env a -> PreProductions TL env [a]
pMany p = fixPrd (none <|> more)
     where  none = pure [] 
            more = (:)   <$> p <*> varPrd
{-
pMaybe :: PreProductions l env a -> PreProductions l env (Maybe a)
pMaybe p = (nothing <|> just)
     where  nothing = pure Nothing 
            just    = Just   <$> p 


pEither :: PreProductions l env a -> PreProductions l env b -> PreProductions l env (Either a b)
pEither p q = (left <|> right)
     where  left  = Left  <$> p
            right = Right <$> q 
-}

opt :: PreProductions l env a -> a -> PreProductions l env a
opt p a = p <|> pure a

pMaybe :: (b, (a -> b)) -> PreProductions TL env a -> PreProductions TL env b
pMaybe (n, j) p = (nothing <|> just)
     where  nothing = pure n 
            just    = j  <$> p 


pFoldr :: (a -> b -> b, b) -> PreProductions (FL b) env a -> PreProductions TL env b
pFoldr (c, e) p = fixPrd (none <|> more)
     where  none = pure e 
            more = c   <$> p <*> varPrd


------------------------
-- IDIOMS

-- | The  'Ii' is to be pronounced as @stop@
data Ii = Ii 

-- | The function 'iI' is to be pronounced as @start@
iI ::Idiomatic  l env (a -> a) g => g
iI = idiomatic (pure id)

class Idiomatic l env f g  | g -> f l env  where
    idiomatic :: PreProductions l env f -> g

instance  Idiomatic l env x  (Ii -> PreProductions l env x) where
    idiomatic ix Ii = ix


instance  Idiomatic l env f g  => Idiomatic  l env (a -> f) (PreProductions l env a -> g) where
    idiomatic isf is = idiomatic (isf <*> is)

instance  Idiomatic l env f g  => Idiomatic  l env (a -> f) (Symbol a TNonT env -> g) where
    idiomatic isf is = idiomatic (isf <*> (sym is))

{-
instance  Idiomatic l env f g  => Idiomatic  l env ((Record HNil -> a) -> f) (Symbol a TAttT env -> g) where
    idiomatic isf is = idiomatic (isf <*> ((\x (Record HNil) -> x) <$> (sym is :: PreProductions l env a)))
-}

instance Idiomatic l env f g => Idiomatic l env ((a -> b) -> f)  ((a -> b) -> g) where
    idiomatic isf f = idiomatic (isf <*> (pure f :: PreProductions l env (a->b)))

instance (Idiomatic  l env f g) 
       => Idiomatic  l env f (String -> g) where
    idiomatic isf str = idiomatic (isf <* (tr str))


data Kw = Kw String

kw :: String -> Kw
kw = Kw

{-
instance  Idiomatic l env f g  => Idiomatic  l env ((Record HNil -> DTerm String) -> f) (Kw -> g) where
    idiomatic isf (Kw is) = idiomatic (isf <*> ((\x (Record HNil) -> x) <$> (tr is)))
-}

-------------------------------------------------------------------------------

{-
newtype  LSPair nt a t env = LSPair { symLSPair :: (Symbol a t env) }  

labelLSPair :: LSPair nt a t env -> nt
labelLSPair _ = undefined

infixr 6 ^= 
(^=) :: nt -> Symbol a t env -> LSPair nt a t env
(^=) _ = LSPair

infixr 6 <=>

class LabelSymbol t v v' | t v -> v' where 
 (<=>) :: label -> Symbol v t env -> PreProductions l env (LVPair label v')


instance LabelSymbol TAttT v (Record HNil -> v) where
 l <=> v =  (\x -> l .=. (\(Record HNil) -> x)) <$> (sym v)


instance LabelSymbol TNonT v v where
 l <=> v =  (l .=.) <$> (sym v)

instance LabelSymbol TTerm v v where -- only to have all the instances
 l <=> v =  (l .=.) <$> (sym v)
-}

{-
-------------------------------------------------------------------------------
-- Show instances for the Grammars
-- Just for debugging purposes

instance Show (Grammar a) where
 show (Grammar r prods) = show r ++ "\n" ++ show prods

instance ShowEnv (Env (Productions l) env env') => Show (Env (Productions l) env env') where
 show env = showEnv 0 env

class ShowEnv a where
    showEnv :: Int -> a -> String

instance ShowEnv (Env (Productions l) env env') where
    showEnv _ (Empty)         = "\n"
    showEnv n (Ext nts nont)  = show n ++ "->" ++ show nont ++ "\n" ++ showEnv (n+1) nts
 
instance Show (Productions l a env) where
 show (PS prods) = show prods

instance Show (Prod l a env) where
 show (Star pf pa)      = "(" ++ show pf ++ "<*>" ++ show pa ++ ")"
 show (FlipStar pa pf)  = "(" ++ show pa ++ "<**>" ++ show pf  ++ ")"
 show (Sym s)           = show s 
 show (Pure _)          = "pure"
 show (Fix f)           = "fix " ++ show f
 show Var               = "var"

instance Show (Symbol a t env) where
 show (Term s)    = show s
 show (Nont r)    = show r
 show (TermInt)   = "int"
 show (TermChar)  = "char"
 show (TermVarid) = "var"
 show (TermConid) = "con"
 show (TermOp)    = "op"

instance Show (Ref a env) where
 show Zero     = "0"
 show (Suc r)  = show  $ (1::Int) + ((read . show) r)
-}