{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- {-# LANGUAGE TemplateHaskell #-}

-- {-# OPTIONS_GHC -Wunused-imports #-}

-- | Abstract syntax instance for grammars with single-character tokens.

module CharacterTokenGrammar where

import Control.Monad
import Control.Monad.Except
import Control.Monad.State

import qualified Data.List as List
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map

import Data.Maybe
import Data.Semigroup ((<>))

-- uses microlens-platform
import Lens.Micro
import Lens.Micro.Extras (view)

import qualified LBNF.Abs as A
import LBNF.Print (printTree)

import CFG
import DebugPrint

-- | Grammar over single-character terminals with identifiers as rule names.

type Term     = Char
type NTName   = A.Ident
type RuleName = A.Ident
type Grammar  = Grammar' NTName RuleName Term
type NT       = NT' NTName
type NTDef    = NTDef' NTName RuleName Term
type Form     = Form' Term

-- | Intermediate rule format.
type IRule = (NT, RuleName, [A.Entry])

type Error = Either String

-- | Convert grammar to internal format; check for single-character terminals.
--   Also return start non-terminal if the grammar has any rules
checkGrammar :: A.Grammar -> Error (Maybe NT, Grammar)
checkGrammar :: Grammar -> Error (Maybe NT, Grammar)
checkGrammar (A.Rules [Rule]
rs) = (StateT Grammar (Either String) (Maybe NT)
-> Grammar -> Error (Maybe NT, Grammar)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` Grammar
forall x r t. Grammar' x r t
emptyGrammar) (StateT Grammar (Either String) (Maybe NT)
 -> Error (Maybe NT, Grammar))
-> StateT Grammar (Either String) (Maybe NT)
-> Error (Maybe NT, Grammar)
forall a b. (a -> b) -> a -> b
$ do
  irs <- (Rule -> StateT Grammar (Either String) IRule)
-> [Rule] -> StateT Grammar (Either String) [IRule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Rule -> StateT Grammar (Either String) IRule
addNT [Rule]
rs
  mapM_ addRule irs
  -- The start symbol is the lhs of the first rule
  return $ listToMaybe $ map (\ (NT
x, Ident
_, [Entry]
_) -> NT
x) irs
  where
  -- Pass 1: collect non-terminals from lhss of rules.
  addNT :: A.Rule -> StateT Grammar Error IRule
  addNT :: Rule -> StateT Grammar (Either String) IRule
addNT (A.Prod Ident
r Ident
x [Entry]
es) = (Grammar -> Error (IRule, Grammar))
-> StateT Grammar (Either String) IRule
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Grammar -> Error (IRule, Grammar))
 -> StateT Grammar (Either String) IRule)
-> (Grammar -> Error (IRule, Grammar))
-> StateT Grammar (Either String) IRule
forall a b. (a -> b) -> a -> b
$ \ grm :: Grammar
grm@(Grammar NTId
n Map Ident NTId
dict IntMap (NTDef' Ident Ident Term)
defs) -> do
    -- Check if we have seen NT x before.
    case Ident -> Map Ident NTId -> Maybe NTId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
x Map Ident NTId
dict of
      -- Yes, use its number.
      Just NTId
i  -> (IRule, Grammar) -> Error (IRule, Grammar)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((NTId -> Ident -> NT
forall x. NTId -> x -> NT' x
NT NTId
i Ident
x, Ident
r, [Entry]
es), Grammar
grm)
      -- No, insert a new entry into the dictionary.
      Maybe NTId
Nothing -> (IRule, Grammar) -> Error (IRule, Grammar)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((NTId -> Ident -> NT
forall x. NTId -> x -> NT' x
NT NTId
n Ident
x, Ident
r, [Entry]
es), NTId
-> Map Ident NTId -> IntMap (NTDef' Ident Ident Term) -> Grammar
forall x r t.
NTId -> Map x NTId -> IntMap (NTDef' x r t) -> Grammar' x r t
Grammar (NTId
nNTId -> NTId -> NTId
forall a. Num a => a -> a -> a
+NTId
1) (Ident -> NTId -> Map Ident NTId -> Map Ident NTId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
x NTId
n Map Ident NTId
dict) IntMap (NTDef' Ident Ident Term)
defs)

  -- Pass 2: scope-check and convert rhss of rules.
  addRule :: IRule -> StateT Grammar Error ()
  addRule :: IRule -> StateT Grammar (Either String) ()
addRule (NT NTId
i Ident
x, Ident
r, [Entry]
es) = (Grammar -> Error ((), Grammar))
-> StateT Grammar (Either String) ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Grammar -> Error ((), Grammar))
 -> StateT Grammar (Either String) ())
-> (Grammar -> Error ((), Grammar))
-> StateT Grammar (Either String) ()
forall a b. (a -> b) -> a -> b
$ \ Grammar
grm -> do
    alt <- Ident -> Form' Ident Term -> Alt' Ident Ident Term
forall x r t. r -> Form' x t -> Alt' x r t
Alt Ident
r (Form' Ident Term -> Alt' Ident Ident Term)
-> ([Symbol' Ident Term] -> Form' Ident Term)
-> [Symbol' Ident Term]
-> Alt' Ident Ident Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol' Ident Term] -> Form' Ident Term
forall x t. [Symbol' x t] -> Form' x t
Form ([Symbol' Ident Term] -> Alt' Ident Ident Term)
-> Either String [Symbol' Ident Term]
-> Either String (Alt' Ident Ident Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
     [Entry]
-> (Entry -> Either String (Symbol' Ident Term))
-> Either String [Symbol' Ident Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Entry]
es ((Entry -> Either String (Symbol' Ident Term))
 -> Either String [Symbol' Ident Term])
-> (Entry -> Either String (Symbol' Ident Term))
-> Either String [Symbol' Ident Term]
forall a b. (a -> b) -> a -> b
$ \case
      -- Current limitation: Since we have no lexer, terminals are characters.
      A.Term [Term
a] -> Symbol' Ident Term -> Either String (Symbol' Ident Term)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol' Ident Term -> Either String (Symbol' Ident Term))
-> Symbol' Ident Term -> Either String (Symbol' Ident Term)
forall a b. (a -> b) -> a -> b
$ Term -> Symbol' Ident Term
forall x t. t -> Symbol' x t
Term Term
a
      A.Term String
_   -> String -> Either String (Symbol' Ident Term)
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"terminals must be single-character strings"
      -- Convert non-terminal names into de Bruijn indices (numbers).
      A.NT Ident
y -> case Ident -> Map Ident NTId -> Maybe NTId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
y (Map Ident NTId -> Maybe NTId) -> Map Ident NTId -> Maybe NTId
forall a b. (a -> b) -> a -> b
$ Getting (Map Ident NTId) Grammar (Map Ident NTId)
-> Grammar -> Map Ident NTId
forall a s. Getting a s a -> s -> a
view Getting (Map Ident NTId) Grammar (Map Ident NTId)
forall x r t (f :: * -> *).
Functor f =>
(Map x NTId -> f (Map x NTId))
-> Grammar' x r t -> f (Grammar' x r t)
grmNTDict Grammar
grm of
        Maybe NTId
Nothing -> String -> Either String (Symbol' Ident Term)
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String (Symbol' Ident Term))
-> String -> Either String (Symbol' Ident Term)
forall a b. (a -> b) -> a -> b
$ String
"undefined non-terminal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
forall a. Print a => a -> String
printTree Ident
y
        Just NTId
j  -> Symbol' Ident Term -> Either String (Symbol' Ident Term)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol' Ident Term -> Either String (Symbol' Ident Term))
-> Symbol' Ident Term -> Either String (Symbol' Ident Term)
forall a b. (a -> b) -> a -> b
$ NT -> Symbol' Ident Term
forall x t. NT' x -> Symbol' x t
NonTerm (NT -> Symbol' Ident Term) -> NT -> Symbol' Ident Term
forall a b. (a -> b) -> a -> b
$ NTId -> Ident -> NT
forall x. NTId -> x -> NT' x
NT NTId
j Ident
y
    return ((), over grmNTDefs (IntMap.insertWith (<>) i (NTDef x [alt])) grm)

-- | Turn grammar back to original format.

reifyGrammar :: Grammar -> A.Grammar
reifyGrammar :: Grammar -> Grammar
reifyGrammar grm :: Grammar
grm@(Grammar NTId
_ Map Ident NTId
dict IntMap (NTDef' Ident Ident Term)
defs) =
  [Rule] -> Grammar
A.Rules ([Rule] -> Grammar)
-> (((NTId, NTDef' Ident Ident Term) -> [Rule]) -> [Rule])
-> ((NTId, NTDef' Ident Ident Term) -> [Rule])
-> Grammar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((NTId, NTDef' Ident Ident Term) -> [Rule])
-> [(NTId, NTDef' Ident Ident Term)] -> [Rule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` IntMap (NTDef' Ident Ident Term)
-> [(NTId, NTDef' Ident Ident Term)]
forall a. IntMap a -> [(NTId, a)]
IntMap.toList IntMap (NTDef' Ident Ident Term)
defs) (((NTId, NTDef' Ident Ident Term) -> [Rule]) -> Grammar)
-> ((NTId, NTDef' Ident Ident Term) -> [Rule]) -> Grammar
forall a b. (a -> b) -> a -> b
$ \ (NTId
i, NTDef Ident
x [Alt' Ident Ident Term]
alts) ->
    ((Alt' Ident Ident Term -> Rule)
-> [Alt' Ident Ident Term] -> [Rule]
forall a b. (a -> b) -> [a] -> [b]
`map` [Alt' Ident Ident Term]
alts) ((Alt' Ident Ident Term -> Rule) -> [Rule])
-> (Alt' Ident Ident Term -> Rule) -> [Rule]
forall a b. (a -> b) -> a -> b
$ \ (Alt Ident
r (Form [Symbol' Ident Term]
alpha)) ->
      Ident -> Ident -> [Entry] -> Rule
A.Prod Ident
r Ident
x ([Entry] -> Rule)
-> ((Symbol' Ident Term -> Entry) -> [Entry])
-> (Symbol' Ident Term -> Entry)
-> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Symbol' Ident Term -> Entry) -> [Symbol' Ident Term] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
`map` [Symbol' Ident Term]
alpha) ((Symbol' Ident Term -> Entry) -> Rule)
-> (Symbol' Ident Term -> Entry) -> Rule
forall a b. (a -> b) -> a -> b
$ \case
        Term Term
a    -> String -> Entry
A.Term [Term
a]
        NonTerm NT
j -> Ident -> Entry
A.NT (Ident -> Entry) -> Ident -> Entry
forall a b. (a -> b) -> a -> b
$ Grammar -> NT -> Ident
ntToIdent Grammar
grm NT
j

ntToIdent :: Grammar -> NT -> NTName
ntToIdent :: Grammar -> NT -> Ident
ntToIdent Grammar
grm (NT NTId
i Ident
x) = Ident
x
-- -- Lookup in Grammar no longer needed as NT's carry their name.
-- ntToIdent grm (NT i x) =
--   view ntName $
--     IntMap.findWithDefault (error "printGrammar: impossible") i $
--       view grmNTDefs grm

-- * Printing

instance DebugPrint (A.Ident) where
  debugPrint :: Ident -> String
debugPrint (A.Ident String
s) = String
s

instance DebugPrint Term where
  debugPrint :: Term -> String
debugPrint = Term -> String
forall a. Show a => a -> String
show
  -- debugPrint = (:[])