{-# 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 Data.Set (Set)

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

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 = RCat -> Cat
forall a. WithPosition a -> a
wpThing RCat
pc
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isList Cat
c
  , Left BaseCat
x <- [Cat -> Either BaseCat BaseCat
baseCat Cat
c]
  , Bool -> ([f] -> Bool) -> Maybe [f] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True [f] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null (Maybe [f] -> Bool) -> Maybe [f] -> Bool
forall a b. (a -> b) -> a -> b
$ BaseCat -> Map BaseCat [f] -> Maybe [f]
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 = ([f] -> [f] -> [f]) -> [Map BaseCat [f]] -> Map BaseCat [f]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [f] -> [f] -> [f]
forall a. [a] -> [a] -> [a]
(++) ([Map BaseCat [f]] -> Map BaseCat [f])
-> [Map BaseCat [f]] -> Map BaseCat [f]
forall a b. (a -> b) -> a -> b
$ ((Rul f -> Maybe (Map BaseCat [f])) -> [Rul f] -> [Map BaseCat [f]]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [Rul f]
rs) ((Rul f -> Maybe (Map BaseCat [f])) -> [Map BaseCat [f]])
-> (Rul f -> Maybe (Map BaseCat [f])) -> [Map BaseCat [f]]
forall a b. (a -> b) -> a -> b
$ \case
    Rule f
f RCat
pc SentForm
_ InternalRule
_
      | Bool -> Bool
not (f -> Bool
forall a. IsFun a => a -> Bool
isCoercion f
f), Left BaseCat
x <- Cat -> Either BaseCat BaseCat
baseCat (RCat -> Cat
forall a. WithPosition a -> a
wpThing RCat
pc)
          -> Map BaseCat [f] -> Maybe (Map BaseCat [f])
forall a. a -> Maybe a
Just (Map BaseCat [f] -> Maybe (Map BaseCat [f]))
-> Map BaseCat [f] -> Maybe (Map BaseCat [f])
forall a b. (a -> b) -> a -> b
$ BaseCat -> [f] -> Map BaseCat [f]
forall k a. k -> a -> Map k a
Map.singleton BaseCat
x [f
f]
      | Bool
otherwise
          -> Maybe (Map BaseCat [f])
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