{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Check whether generated AST will have empty types.
--
-- Internal rules are included.
--
-- We compute by a saturation algorithm which token types are used in which non-terminal.
-- A non-terminal does not use any token types, we flag an empty type.

module BNFC.Check.EmptyTypes (emptyData) where

import Data.Maybe
import Data.Map (Map)

import qualified Data.List as List
import qualified Data.Map as Map

import BNFC.CF

-- | Compute the categories that have empty data type declarations in the abstract syntax.
--   Disregards list types.
emptyData :: forall f. (IsFun f) => [Rul f] -> [RCat]
emptyData :: forall f. IsFun f => [Rul f] -> [RCat]
emptyData [Rul f]
rs =
  [ RCat
pc
  | Rule f
_ RCat
pc SentForm
_ InternalRule
_ <- [Rul f]
rs
  , let c :: Cat
c = forall a. WithPosition a -> a
wpThing RCat
pc
  , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isList Cat
c
  , Left BaseCat
x <- [Cat -> Either BaseCat BaseCat
baseCat Cat
c]
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BaseCat
x Map BaseCat [f]
ruleMap
  ]
  where
  ruleMap :: Map BaseCat [f]
  ruleMap :: Map BaseCat [f]
ruleMap = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [Rul f]
rs) forall a b. (a -> b) -> a -> b
$ \case
    Rule f
f RCat
pc SentForm
_ InternalRule
_
      | Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion f
f), Left BaseCat
x <- Cat -> Either BaseCat BaseCat
baseCat (forall a. WithPosition a -> a
wpThing RCat
pc)
          -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton BaseCat
x [f
f]
      | Bool
otherwise
          -> forall a. Maybe a
Nothing


-- -- STILLBORN CODE:

-- type UsedTokenTypes = Map BaseCat (Set TokenCat)

-- -- | Not sure what emptyCats computes:
-- emptyCats :: [Rul f] -> [RCat]
-- emptyCats rs =
--   [ pc
--   | Rule _ pc _ _ <- rs
--   , let c = wpThing pc
--   , not $ isList c
--   , Left x <- [baseCat c]
--   , maybe False Set.null $ Map.lookup x usedTokenMap
--   ]
--   where
--   -- The computation of the UsedTokenTypes is likely correct (but untested).
--   usedTokenMap = saturate Map.empty
--   -- standard least fixed-point iteration from below
--   saturate m = if m' == m then m' else saturate m'
--     where m' = step m
--   -- step is monotone!
--   step :: UsedTokenTypes -> UsedTokenTypes
--   step m = Map.unionsWith Set.union $ map stepRule rs
--     where
--     -- Compute the used tokens for a NT based on a single rule,
--     -- using the information we have already for the NTs on the rhs.
--     stepRule (Rule _ (WithPosition _ c0) rhs _) =
--       case baseCat c0 of
--         Left x -> Map.singleton x $ Set.unions $ map typesFor rhsCats
--         -- The TokenCat case is actually impossible, but this is consistent:
--         Right x -> Map.singleton x $ Set.singleton x
--       where
--       rhsCats = mapMaybe (either (Just . baseCat) (const Nothing)) rhs
--     typesFor = \case
--       -- Not token cat:
--       Left c  -> Map.findWithDefault Set.empty c m
--       -- TokenCat:
--       Right c -> Set.singleton c