{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}

-- | First pass of processing a LBNF file.
--
-- - Find all the categories defined in a LBNF grammar.
--
-- - Complain about duplicate categories, e.g. defined both by rules and @list@ or @token@ pragmas.
--
-- - Drops errorneous definitions, returning a list of errors.
--   It is possible to continue into pass 2 with the remaining definitions,
--   should the user desire so (switch @--force@).
--
-- - Produces a map whose keys are the grammar categories parsed into 'ICat' intermediate format
--   and whose values are their first defining occurrences plus kind information.
--
-- This pass does not transform the list of parsed definitions into an intermediate format,
-- e.g. for saving the translations of category names to 'ICat'.
-- This could be done, but the translation is cheap and deterministic, so it can be repeated in pass 2.

module BNFC.Check.Pass1 where

import BNFC.Prelude

import qualified Data.Map           as Map
import Lens.Micro.TH (makeLenses)

import qualified BNFC.Abs as A
import BNFC.Abs (HasPosition(..))
import BNFC.CF
import BNFC.Types.Position

import BNFC.Check.Monad

-- | The state and result of pass1.
data Pass1 = Pass1
  { _stDefinedCats :: DefinedICats
      -- ^ The categories defined by the grammar.
  , _stUsedCats    :: Map ICat    (List1 (WithPosition Parseable))
      -- ^ The categories referenced (used) in the grammar.
      --   Occurrences in @internal@ rules will be labeled 'Internal'.
  , _stKeywords    :: Map Keyword (List1 Position)
      -- ^ The keywords used in the grammar.
  }
  deriving Show

type DefinedICats = Map ICat PCatKind

-- | The kind of a category definition.

data CatKind
  = KRules (List1 RuleKind)  -- ^ given by rules and/or @rules@ pragma
  | KList                    -- ^ given by @separator@ or @terminator@ pragma
  | KToken PositionToken     -- ^ given by @token@ pragma
  deriving (Show)

type PCatKind = WithPosition CatKind

-- | The kind of a rule definition.

data RuleKind
  = ROrdinary Parseable  -- ^ ordinary or @internal@ rule
  | RRules               -- ^ @rules@ pragma
  | RCoercion            -- ^ @coercion@ pragma
  deriving (Show)

makeLenses ''Pass1

-- | Entry point for pass 1.

checkLBNF :: A.Grammar -> Check (A.Grammar, Pass1)
checkLBNF grammar = runStateT (checkGrammar grammar) $ Pass1
  { _stDefinedCats = mempty
  , _stUsedCats    = mempty
  , _stKeywords    = mempty
  }

-- * Pass 1 checker
---------------------------------------------------------------------------

-- | The monad for pass 1, manipulates 'Pass1'.
type M = StateT Pass1 Check

-- | Check a whole grammar, swallowing errorneous definitions.

checkGrammar :: A.Grammar -> M A.Grammar
checkGrammar (A.Grammar p defs) = A.Grammar p . catMaybes <$> mapM checkDef defs

-- | Check a definition.  Swallow it if it produces a recoverable error.

checkDef :: A.Def -> M (Maybe A.Def)
checkDef def =
  case def of
    A.Rule       (Just p) _ cat rhs -> may (useCats rhs >> addKeywords rhs) =<< do
                                       addCat p (ruleKind $ ROrdinary Parseable) cat
    A.Internal   (Just p) _ cat rhs -> may (useCatsInternal rhs) =<< do   -- no keywords when 'internal'!
                                       addCat p (ruleKind $ ROrdinary Internal ) cat
    A.Token      (Just p) x _       -> addCat p (KToken NoPositionToken) $ identifierToCat x
    A.PosToken   (Just p) x _       -> addCat p (KToken   PositionToken) $ identifierToCat x
    A.Separator  (Just p) _ cat s   -> may (useCats cat >> addKeywords (p, s)) =<< addListCat p cat
    A.Terminator (Just p) _ cat s   -> may (useCats cat >> addKeywords (p, s)) =<< addListCat p cat
    A.Delimiters (Just p) _ _ _ _ _ -> failure p DelimitersNotSupported
    A.Coercions  (Just p) x n       -> may (addKeywords [(p, "("), (p, ")")]) =<< addCoercions p x n
    A.Rules      (Just p) x rhs     -> may (useCats rhs >> addKeywords rhs) =<< do
                                       addCat p (ruleKind RRules) $ identifierToCat x
    A.Entryp     _        cats      -> useCats cats >> nop
    -- Ignore these definitions forms in pass 1:
    A.Function{}   -> nop
    -- Lexer stuff:
    A.Comment{}    -> nop
    A.Comments{}   -> nop
    A.Layout{}     -> nop
    A.LayoutStop{} -> nop
    A.LayoutTop{}  -> nop
    A.Rule       Nothing _ _ _     -> panic panicStr
    A.Internal   Nothing _ _ _     -> panic panicStr
    A.Token      Nothing _ _       -> panic panicStr
    A.PosToken   Nothing _ _       -> panic panicStr
    A.Separator  Nothing _ _ _     -> panic panicStr
    A.Terminator Nothing _ _ _     -> panic panicStr
    A.Delimiters Nothing _ _ _ _ _ -> panic panicStr
    A.Coercions  Nothing _ _       -> panic panicStr
    A.Rules      Nothing _ _       -> panic panicStr

  where
  nop = return $ Just def
  keep = (Just def <$)
  skip = (Nothing <$)
  failure p err = skip $ atPosition p $ recoverableError err
  panicStr = "position cannot be Nothing"

  -- Run a computation if definition wasn't dropped.
  may :: M () -> Maybe A.Def -> M (Maybe A.Def)
  may m = traverse (<$ m)

  addListCat apos acat  = addCat' (toPosition apos) KList (ListCat $ parseCat acat)
  addCat apos kind acat = addCat' (toPosition apos) kind (parseCat acat)
  addCat' p kind cat = do
    lookupCat cat >>= \case
      Nothing -> storeCat kind
      Just (WithPosition pold old) -> do
        case mergeKind old kind of
          Right new -> storeCat new
          Left ()   -> failure p $ IncompatibleDefinition cat pold
    where
    storeCat k = keep $ modifying stDefinedCats $ Map.insert cat $ WithPosition p k

  addCoercions p (A.Identifier (_, x)) n = do
    case parseCoerceCat x of
      c@(Cat y)   -> keep $ do
        add c
        mapM_ (add . CoerceCat y) [1..n]
      CoerceCat{} -> failure p CoercionsOfCoerceCat
      ListCat{}   -> panic "parseCoerceCat returned a list category"
    where
    add :: ICat -> M ()
    add = void . addCat' (toPosition p) (ruleKind RCoercion)

  lookupCat :: ICat -> M (Maybe PCatKind)
  lookupCat cat = Map.lookup cat <$> use stDefinedCats

-- * Collecting categories
---------------------------------------------------------------------------

useCats :: AddCategories a => a -> M ()
useCats a = addCategories a `runReaderT` Parseable

useCatsInternal :: AddCategories a => a -> M ()
useCatsInternal a = addCategories a `runReaderT` Internal

-- | Collect categories used in something.
class AddCategories a where
  addCategories :: a -> ReaderT Parseable M ()

-- | Directly add to '_stUsedCats'.
instance AddCategories (WithPosition ICat) where
  addCategories (WithPosition p c) = do
    parseable <- ask
    modifying stUsedCats $ Map.insertWith (<>) c $ singleton $ WithPosition (toPosition p) parseable

-- | Also adds for each list category its element category, transitively.
instance AddCategories A.Cat where
  addCategories c0 =
    case c0 of
      A.ListCat (Just p0) c1 -> do
        addCategories $ WithPosition (toPosition p0) c
        addCategories c1
      A.IdCat   (Just p0) _  -> do
        addCategories $ WithPosition (toPosition p0) c
      A.ListCat Nothing _ -> panic panicStr
      A.IdCat   Nothing _ -> panic panicStr
    where
    c = parseCat c0
    panicStr = "position cannot be Nothing"

instance AddCategories a => AddCategories [a] where
  addCategories = mapM_ addCategories

instance AddCategories A.RHS where
  addCategories (A.RHS _ rhs) = addCategories rhs

instance AddCategories A.Item where
  addCategories = \case
    A.NTerminal _ c -> addCategories c
    A.Terminal  _ _ -> return ()

-- * Collecting keywords
---------------------------------------------------------------------------

class AddKeywords a where
  addKeywords :: a -> M ()

instance ToPosition p => AddKeywords (p, String) where
  addKeywords (p, s) =
    -- Ignore empty keywords.
    forM_ (parseKeyword s) $ \ kw -> do
      modifying stKeywords $ Map.insertWith (<>) kw $ singleton $ toPosition p

instance AddKeywords a => AddKeywords [a] where
  addKeywords = mapM_ addKeywords

instance AddKeywords A.RHS where
  addKeywords (A.RHS _ rhs) = addKeywords rhs

instance AddKeywords A.Item where
  addKeywords = \case
    A.Terminal (Just p) s -> addKeywords (p, s)
    A.Terminal Nothing  _ -> panic "postion cannot be Nothing"
    A.NTerminal{}  -> return ()

-- * Utilities
---------------------------------------------------------------------------

ruleKind :: RuleKind -> CatKind
ruleKind k = KRules $ k :| []

mergeKind :: CatKind -> CatKind -> Either () CatKind
mergeKind = curry $ \case
  (KRules rs1, KRules rs2) -> Right $ KRules $ rs1 <> rs2
  _ -> Left ()

parseCat :: A.Cat -> ICat
parseCat = \case
  A.ListCat _ c                   -> ListCat $ parseCat c
  A.IdCat _ (A.Identifier (_, x)) -> parseCoerceCat x

parseCoerceCat :: String -> ICat
parseCoerceCat x =
  case spanEnd isDigit x of
    (_ , []  ) -> panic "category name starts with a letter"
    ([], c:cs) -> Cat (c :| cs)
    (ds, c:cs) -> CoerceCat (c :| cs) $ read ds

identifierToCat :: A.Identifier -> A.Cat
identifierToCat x = A.IdCat (hasPosition x) x

-- | Resolve category.
parseICat :: ICat -> ReaderT DefinedICats Check Cat
parseICat = \case
  ListCat c -> ListCat <$> parseICat c
  CoerceCat x n -> do
    asks (fmap wpThing . Map.lookup (Cat x)) >>= \case
      Nothing       -> do
        case parseBuiltinCat x of
          Nothing        -> recoverableError $ UnknownCatName x
          Just (Left  i) -> recoverableError $ CoerceIdentCat i
          Just (Right b) -> recoverableError $ CoerceBuiltinCat b
      Just KToken{} -> recoverableError $ CoerceTokenCat x
      Just KList{}  -> recoverableError $ CoerceListCat x
      Just KRules{} -> return ()
    return $ CoerceCat x n
  c@(Cat x) -> Cat <$> do
    asks (fmap wpThing . Map.lookup c) >>= \case
      Just KRules{} -> return $ BaseCat x
      Just KToken{} -> return $ TokenCat x
      Just KList    -> panic "base category cannot have KList kind"
      Nothing       -> do
        case parseBuiltinCat x of
          Just (Left  i) -> return $ IdentCat i
          Just (Right b) -> return $ BuiltinCat b
          Nothing -> do
            recoverableError $ UnknownCatName x
            return $ BaseCat x  -- fallback


-- * Trash
---------------------------------------------------------------------------

data WithDefinition a = WithDefinition
  { wdDef   :: A.Def
  , wdThing :: a
  }
  deriving (Show, Functor, Foldable, Traversable)

type PCatOrigin = WithPosition CatOrigin
data CatOrigin
  = ORule   -- ^ ordinary or 'internal' rule
  | ORules  -- ^ 'rules' pragma
  | OList   -- ^ 'separator' or 'terminator' pragma
  | OToken  -- ^ 'token' definition (exclusive)
  deriving (Eq, Ord, Show)

type PDCatKind = WithPosition (WithDefinition CatKind)


data CatInfo = CatInfo
  { _catParsable :: Parseable
      -- ^ Does this category have at least one parseable rule?
  , _catOrigins  :: [PCatOrigin]
      -- ^ Where is this category defined?
      --   For ordinary categories, list of definitions that populate the category.
  } deriving Show

makeLenses ''CatInfo