ReduceC.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module ReduceC (
  defaultReduceC,
  reduceCTranslUnit,

  -- * Context
  Context (..),
  defaultContext,

  -- * Helpers
  prettyIdent,
) where

import Control.Monad.Reduce
import Data.Data
import Data.Foldable
import Data.Function
import Data.Functor
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
import qualified Language.C as C
import qualified Language.C.Data.Ident as C

data Context = Context
  { keywords :: !(Set.Set Keyword)
  , typeDefs :: !(Map.Map C.Ident [C.CDeclarationSpecifier C.NodeInfo])
  , inlineExprs :: !(Map.Map C.Ident C.CExpr)
  }

data Keyword
  = KeepMain
  | DoNoops
  | NoSemantics
  | AllowEmptyDeclarations
  | DisallowVariableInlining
  deriving (Show, Read, Enum, Eq, Ord)

type Lab = (String, C.Position)

defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit
defaultReduceC a = reduceCTranslUnit a defaultContext

addTypeDefs :: [C.Ident] -> [C.CDeclarationSpecifier C.NodeInfo] -> Context -> Context
addTypeDefs ids cs Context{..} =
  Context
    { typeDefs =
        foldl' (\a i -> Map.insert i cs a) typeDefs ids
    , ..
    }

addInlineExpr :: C.Ident -> C.CExpr -> Context -> Context
addInlineExpr i e Context{..} =
  Context
    { inlineExprs = Map.insert i e inlineExprs
    , ..
    }

addKeyword :: Keyword -> Context -> Context
addKeyword k Context{..} =
  Context
    { keywords = Set.insert k keywords
    , ..
    }

-- deleteKeyword :: Keyword -> Context -> Context
-- deleteKeyword k Context{..} =
--   Context
--     { keywords = Set.delete k keywords
--     , ..
--     }

defaultContext :: Context
defaultContext =
  Context
    { keywords = Set.fromList [KeepMain]
    , typeDefs = Map.empty
    , inlineExprs = Map.empty
    }

isIn :: Keyword -> Context -> Bool
isIn k = Set.member k . keywords

prettyIdent :: C.Identifier C.NodeInfo -> [Char]
prettyIdent (C.Ident s _ a) = s ++ " at " ++ show (C.posOfNode a)

reduceCTranslUnit
  :: (MonadReduce Lab m)
  => C.CTranslationUnit C.NodeInfo
  -> Context
  -> m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
  es' <- foldr reduceCExternalDeclaration (\_ -> pure []) es ctx
  pure $ C.CTranslUnit es' ni

reduceCExternalDeclaration
  :: (MonadReduce Lab m)
  => C.CExternalDeclaration C.NodeInfo
  -> (Context -> m [C.CExternalDeclaration C.NodeInfo])
  -> Context
  -> m [C.CExternalDeclaration C.NodeInfo]
reduceCExternalDeclaration r cont ctx = do
  case inlineTypeDefs r ctx of
    C.CFDefExt fun
      | KeepMain `isIn` ctx && maybe False (("main" ==) . C.identToString) (functionName fun) -> do
          r' <- C.CFDefExt <$> reduceCFunDef fun ctx
          (r' :) <$> cont ctx
      | otherwise ->
          split ("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r) (cont ctx) do
            r' <- C.CFDefExt <$> reduceCFunDef fun ctx
            (r' :) <$> case functionName fun of
              Just fid -> cont (addInlineExpr fid (C.CVar fid C.undefNode) ctx)
              Nothing -> cont ctx
    C.CDeclExt result ->
      case result of
        -- A typedef
        C.CDecl (C.CStorageSpec (C.CTypedef n) : rst) decl _ -> do
          let [ids] = identifiers decl
          split
            ("inline typedef " <> C.identToString ids, C.posOf r)
            (cont (addTypeDefs [ids] rst ctx))
            ((r :) <$> cont (addTypeDefs [ids] [C.CTypeSpec (C.CTypeDef ids n)] ctx))
        -- A const
        C.CDecl rec decl ni' -> do
          (decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl
          case decl' of
            []
              | AllowEmptyDeclarations `isIn` ctx' ->
                  split ("remove empty declaration", C.posOf r) (cont ctx') do
                    (C.CDeclExt (C.CDecl rec decl' ni') :) <$> cont ctx'
              | otherwise -> cont ctx'
            _ow -> (C.CDeclExt (C.CDecl rec decl' ni') :) <$> cont ctx'
        a -> don'tHandle a
    _r -> don'tHandle r

reduceCFunDef
  :: (MonadReduce Lab m)
  => C.CFunctionDef C.NodeInfo
  -> Context
  -> m (C.CFunctionDef C.NodeInfo)
reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do
  smt' <- reduceCStatementOrEmptyBlock smt ctx
  pure $ C.CFunDef spc dec cdecls smt' ni

reduceCCompoundBlockItem
  :: (MonadReduce Lab m)
  => C.CCompoundBlockItem C.NodeInfo
  -> (Context -> m [C.CCompoundBlockItem C.NodeInfo])
  -> Context
  -> m [C.CCompoundBlockItem C.NodeInfo]
reduceCCompoundBlockItem r cont ctx = do
  case r of
    C.CBlockStmt smt -> do
      case reduceCStatement smt ctx of
        Just rsmt -> split ("remove statement", C.posOf r) (cont ctx) do
          smt' <- rsmt
          case smt' of
            C.CCompound [] ss _ -> do
              split ("expand compound statment", C.posOf r) ((ss <>) <$> cont ctx) do
                (C.CBlockStmt smt' :) <$> cont ctx
            _ow -> do
              (C.CBlockStmt smt' :) <$> cont ctx
        Nothing -> cont ctx
    C.CBlockDecl declr -> do
      case declr of
        C.CDecl rec decl ni' -> do
          (decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl
          case decl' of
            []
              | AllowEmptyDeclarations `isIn` ctx' ->
                  split ("remove empty declaration", C.posOf r) (cont ctx') do
                    (C.CBlockDecl (C.CDecl rec decl' ni') :) <$> cont ctx'
              | otherwise -> cont ctx'
            _ow -> (C.CBlockDecl (C.CDecl rec decl' ni') :) <$> cont ctx'
        d -> don'tHandle d
    a -> don'tHandle a

reduceCDeclarationItem
  :: (MonadReduce Lab m)
  => C.CDeclarationItem C.NodeInfo
  -> m ([C.CDeclarationItem C.NodeInfo], Context)
  -> m ([C.CDeclarationItem C.NodeInfo], Context)
reduceCDeclarationItem d ma = case d of
  C.CDeclarationItem
    dr@(C.CDeclr (Just i) [] Nothing [] ni)
    (Just (C.CInitExpr c ni'))
    Nothing -> do
      (ds, ctx) <- ma
      c' <- fromMaybe (pure zeroExpr) (reduceCExpr c ctx)
      split
        ("inline variable " <> C.identToString i, C.posOf ni)
        (pure (ds, addInlineExpr i c' ctx))
        ( pure
            ( C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing : ds
            , addInlineExpr i (C.CVar i ni) ctx
            )
        )
  C.CDeclarationItem (C.CDeclr (Just i) _ Nothing [] ni) Nothing Nothing -> do
    (ds, ctx) <- ma
    split
      ("remove variable " <> C.identToString i, C.posOf ni)
      (pure (ds, ctx))
      (pure (d : ds, addInlineExpr i (C.CVar i ni) ctx))
  a -> don'tHandle a

reduceCStatementOrEmptyBlock
  :: (MonadReduce Lab m)
  => C.CStatement C.NodeInfo
  -> Context
  -> m (C.CStatement C.NodeInfo)
reduceCStatementOrEmptyBlock stmt ctx = do
  case reduceCStatement stmt ctx of
    Just ex -> do
      ex
    Nothing -> do
      pure emptyBlock
 where
  emptyBlock = C.CCompound [] [] C.undefNode

reduceCStatement
  :: (MonadReduce Lab m)
  => C.CStatement C.NodeInfo
  -> Context
  -> Maybe (m (C.CStatement C.NodeInfo))
reduceCStatement smt ctx = case smt of
  C.CCompound is cbi ni -> Just do
    cbi' <- foldr reduceCCompoundBlockItem (\_ -> pure []) cbi ctx
    pure $ C.CCompound is cbi' ni
  C.CWhile e s dow ni -> do
    rs <- reduceCStatement s ctx
    Just do
      e' <- reduceCExprOrZero e ctx
      s' <- rs
      pure $ C.CWhile e' s' dow ni
  C.CExpr me ni -> do
    case me of
      Just e -> do
        if DoNoops `isIn` ctx
          then Just do
            e' <- maybeSplit ("change to noop", C.posOf smt) $ reduceCExpr e ctx
            pure $ C.CExpr e' ni
          else do
            re <- reduceCExpr e ctx
            Just do
              e' <- re
              pure $ C.CExpr (Just e') ni
      Nothing ->
        Just $ pure $ C.CExpr Nothing ni
  C.CReturn me ni -> Just do
    case me of
      Just e -> do
        e' <- reduceCExprOrZero e ctx
        pure $ C.CReturn (Just e') ni
      Nothing ->
        pure $ C.CReturn Nothing ni
  C.CIf e s els ni -> Just do
    e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e ctx
    els' <- case els of
      Just els' -> do
        maybeSplit ("remove else branch", C.posOf els') do
          reduceCStatement els' ctx
      Nothing -> pure Nothing
    s' <- reduceCStatementOrEmptyBlock s ctx
    case (e', els') of
      (Nothing, Nothing) -> pure s'
      (Just e'', Nothing) -> pure $ C.CIf e'' s' Nothing ni
      (Nothing, Just x) -> pure $ C.CIf zeroExpr s' (Just x) ni
      (Just e'', Just x) -> pure $ C.CIf e'' s' (Just x) ni
  C.CFor e1 e2 e3 s ni -> Just $ do
    (me1', ctx') <- case e1 of
      C.CForDecl (C.CDecl rec decl ni') -> do
        (decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl
        res <-
          if null decl'
            then
              whenSplit
                (AllowEmptyDeclarations `isIn` ctx')
                ("remove empty declaration", C.posOf ni')
                (pure Nothing)
                (pure $ Just $ C.CForDecl (C.CDecl rec decl' ni'))
            else pure $ Just $ C.CForDecl (C.CDecl rec decl' ni')
        pure (res, ctx')
      C.CForInitializing e ->
        whenSplit
          (AllowEmptyDeclarations `isIn` ctx)
          ("remove empty declaration", C.posOf ni)
          (pure (Nothing, ctx))
          (pure (Just $ C.CForInitializing e, ctx))
      d -> don'tHandle d

    s' <- reduceCStatementOrEmptyBlock s ctx'
    case me1' of
      Nothing -> do
        split ("remove the for loop", C.posOf smt) (pure s') do
          e2' <- case e2 of
            Just e2' -> maybeSplit ("remove check", C.posOf e2') (reduceCExpr e2' ctx')
            Nothing -> pure Nothing
          e3' <- case e3 of
            Just e3' -> maybeSplit ("remove iterator", C.posOf e3') (reduceCExpr e3' ctx')
            Nothing -> pure Nothing
          pure $ C.CFor (C.CForInitializing Nothing) e2' e3' s' ni
      Just e1' -> do
        e2' <- case e2 of
          Just e2' -> maybeSplit ("remove check", C.posOf e2') (reduceCExpr e2' ctx')
          Nothing -> pure Nothing
        e3' <- case e3 of
          Just e3' -> maybeSplit ("remove iterator", C.posOf e3') (reduceCExpr e3' ctx')
          Nothing -> pure Nothing
        pure $ C.CFor e1' e2' e3' s' ni
  C.CBreak ni -> Just do
    pure (C.CBreak ni)
  C.CLabel i s [] ni -> Just do
    s' <- reduceCStatementOrEmptyBlock s ctx
    pure $ C.CLabel i s' [] ni
  C.CGoto i ni -> Just do
    pure $ C.CGoto i ni
  a -> don'tHandle a

--     C.CCompound is cbi ni -> do
--       cbi' <- collect (reduce @C.CCompoundBlockItem) cbi
--       pure $ C.CCompound is cbi' ni
--     C.CExpr e ni -> do
--       e' <- optional do
--         e' <- liftMaybe e
--         reduce @C.CExpression e'
--       pure $ C.CExpr e' ni
--     C.CReturn e ni -> do
--       e' <- traverse (fmap orZero reduce) e
--       pure $ C.CReturn e' ni
--     C.CCont ni -> pure (C.CCont ni)
--     C.CLabel i s [] ni -> do
--       -- todo fix attrs
--       s' <- reduce s
--       withFallback s' do
--         givenThat (Val.is i)
--         pure $ C.CLabel i s' [] ni
--     C.CWhile e s dow ni -> do
--       e' <- orZero (reduce @C.CExpression e)
--       s' <- reduce s
--       pure $ C.CWhile e' s' dow ni

-- | If the condition is statisfied try to reduce to the a.
whenSplit :: (MonadReduce Lab m) => Bool -> Lab -> m a -> m a -> m a
whenSplit cn lab a b
  | cn = split lab a b
  | otherwise = b

maybeSplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> m (Maybe a)
maybeSplit lab = \case
  Just r -> do
    split lab (pure Nothing) (Just <$> r)
  Nothing -> do
    pure Nothing

zeroExpr :: C.CExpression C.NodeInfo
zeroExpr = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)

reduceCExprOrZero :: (MonadReduce Lab m) => C.CExpr -> Context -> m C.CExpr
reduceCExprOrZero expr ctx = do
  case reduceCExpr expr ctx of
    Just ex -> do
      split ("replace by zero", C.posOf expr) (pure zeroExpr) ex
    Nothing -> do
      pure zeroExpr

reduceCExpr :: (MonadReduce Lab m) => C.CExpr -> Context -> Maybe (m C.CExpr)
reduceCExpr expr ctx = case expr of
  C.CBinary o elhs erhs ni -> do
    case reduceCExpr elhs ctx of
      Just elhs' -> case reduceCExpr erhs ctx of
        Just erhs' -> pure do
          split ("reduce to left", C.posOf elhs) elhs' do
            split ("reduce to right", C.posOf erhs) erhs' do
              l' <- elhs'
              r' <- erhs'
              pure $ C.CBinary o l' r' ni
        Nothing ->
          fail "could not reduce right hand side"
      Nothing
        | otherwise -> fail "could not reduce left hand side"
  C.CAssign o elhs erhs ni ->
    case reduceCExpr elhs (addKeyword DisallowVariableInlining ctx) of
      Just elhs' -> case reduceCExpr erhs ctx of
        Just erhs' -> pure do
          split ("reduce to left", C.posOf elhs) elhs' do
            split ("reduce to right", C.posOf erhs) erhs' do
              l' <- elhs'
              r' <- erhs'
              pure $ C.CAssign o l' r' ni
        Nothing ->
          fail "could not reduce right hand side"
      Nothing
        | otherwise -> fail "could not reduce left hand side"
  C.CVar i _ ->
    case Map.lookup i . inlineExprs $ ctx of
      Just mx -> case mx of
        C.CVar _ _ -> pure (pure mx)
        _
          | DisallowVariableInlining `isIn` ctx -> Nothing
          | otherwise -> pure (pure mx)
      Nothing -> fail ("Could not find " <> show i)
  C.CConst x -> Just do
    pure $ C.CConst x
  C.CUnary o elhs ni -> do
    elhs' <- reduceCExpr elhs (addKeyword DisallowVariableInlining ctx)
    Just $ split ("reduce to operant", C.posOf expr) elhs' do
      e <- elhs'
      pure $ C.CUnary o e ni
  C.CCall e es ni -> do
    re <- reduceCExpr e (addKeyword DisallowVariableInlining ctx)
    Just $ do
      e' <- re
      es' <- traverse (`reduceCExprOrZero` ctx) es
      pure $ C.CCall e' es' ni
  a -> error (show a)

--     C.CCond ec et ef ni -> do
--       ec' <- reduce ec
--       ef' <- reduce ef
--       et' <- optional do
--         et' <- liftMaybe et
--         reduce et'
--       pure $ C.CCond ec' et' ef' ni
--     C.CBinary o elhs erhs ni -> onBothExpr elhs erhs \lhs rhs ->
--       pure $ C.CBinary o lhs rhs ni
--     C.CUnary o elhs ni -> do
--       lhs <- reduce elhs
--       pure $ C.CUnary o lhs ni
--     C.CConst c -> do
--       -- TODO fix
--       pure $ C.CConst c
--     C.CCast cd e ni -> do
--       -- TODO fix
--       cd' <- reduce @C.CDeclaration cd
--       e' <- reduce e
--       pure $ C.CCast cd' e' ni
--     C.CIndex e1 e2 ni -> do
--       e1' <- reduce e1
--       e2' <- orZero (reduce e2)
--       pure $ C.CIndex e1' e2' ni
--     C.CMember e i b ni -> do
--       givenThat (Val.is i)
--       e' <- reduce e
--       pure $ C.CMember e' i b ni
--     C.CComma items ni -> do
--       C.CComma <$> collectNonEmpty' reduce items <*> pure ni
--     e -> error (show e)
--    where
--     onBothExpr elhs erhs = onBoth (reduce elhs) (reduce erhs)

-- splitIf :: (MonadReduce l m) => Bool -> l -> m a -> m a -> m a
-- splitIf True s a b = split s a b
-- splitIf False _ _ b = b
--
-- splitOn :: (MonadReduce l m, MonadReader Context m) => Keyword -> l -> m a -> m a -> m a
-- splitOn k s a b = do
--   con <- keyword k
--   splitIf con s a b
--
-- maybeSplit
--   :: (MonadReduce l m)
--   => l
--   -> Maybe (m a)
--   -> Maybe (m a)
--   -> Maybe (m a)
-- maybeSplit s a b = case a of
--   Just a' -> case b of
--     Just b' -> Just do
--       split s a' b'
--     Nothing -> Just a'
--   Nothing -> b
--
-- maybeSplitOn
--   :: (MonadReduce l m)
--   => Keyword
--   -> l
--   -> ReaderT Context Maybe (m a)
--   -> ReaderT Context Maybe (m a)
--   -> ReaderT Context Maybe (m a)
-- maybeSplitOn k s a b = do
--   con <- keyword k
--   if con
--     then b
--     else ReaderT \ctx ->
--       case runReaderT a ctx of
--         Just a' -> case runReaderT b ctx of
--           Just b' -> Just $ split s a' b'
--           Nothing -> Just a'
--         Nothing -> runReaderT b ctx

inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
inlineTypeDefs r ctx = do
  case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
    Just Refl ->
      r & concatMap \case
        C.CTypeSpec (C.CTypeDef idx _) -> do
          case Map.lookup idx . typeDefs $ ctx of
            Just args -> args
            Nothing -> error ("could not find typedef:" <> show idx)
        a -> [a]
    Nothing ->
      gmapT (`inlineTypeDefs` ctx) r

-- instance CReducible C.CExtDecl where
--  reduceC (C.CFunDef spc dec cdecls smt ni) = do
--    pure $ C.CFunDef spc dec cdecls smt ni

identifiers :: forall a. (Data a) => a -> [C.Ident]
identifiers d = case cast d of
  Just l -> [l]
  Nothing -> concat $ gmapQ identifiers d

functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
functionName = \case
  C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix

-- isMain :: C.CFunctionDef C.NodeInfo -> Bool
-- isMain (C.CFunDef _ (C.CDeclr (Just i) _ _ _ _) _ _ _) =
--   C.identToString i == "main"
-- isMain _ow = False

don'tHandle :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> b
don'tHandle f = error (show (f $> ()))

-- instance CReducible C.CDeclaration where
--   reduce = \case
--     C.CDecl spc@(C.CStorageSpec (C.CTypedef _) : rst) decl ni -> do
--       decl' <-
--         decl & collectNonEmpty' \case
--           C.CDeclarationItem d Nothing Nothing -> do
--             let (x, _) = cDeclaratorIdentifiers d
--             case x of
--               Just x' ->
--                 splitOn
--                   (Val.is x')
--                   ( do
--                       modify (Map.insert x' (Type rst))
--                       mzero
--                   )
--                   (pure $ C.CDeclarationItem d Nothing Nothing)
--               Nothing ->
--                 pure $ C.CDeclarationItem d Nothing Nothing
--           a -> error (show a)
--       pure (C.CDecl spc decl' ni)
--     C.CDecl spc@[C.CTypeSpec (C.CTypeDef i ni')] decl ni -> do
--       x <- gets (Map.lookup i)
--       case x of
--         Just (Type rst) -> do
--           decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers rst) decl
--           pure $ C.CDecl rst decl' ni
--         Nothing -> do
--           decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--           pure $ C.CDecl spc decl' ni
--     C.CDecl spc decl ni -> do
--       decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--       pure $ C.CDecl spc decl' ni
--     a -> error (show a)
--    where
--     reduceCDeclarationItem rq' = \case
--       C.CDeclarationItem d i e -> do
--         let (fn, reqs) = cDeclaratorIdentifiers d
--         case fn of
--           Just fn' ->
--             conditionalGivenThat (rq' <> reqs) (Val.is fn')
--           Nothing ->
--             mapM_ (givenThat . Val.is) (rq' <> reqs)
--
--         i' <- optional do
--           liftMaybe i >>= reduce @C.CInitializer
--         e' <- optional do
--           liftMaybe e >>= reduce @C.CExpression
--
--         pure (C.CDeclarationItem d i' e')
--       a -> error (show a)

-- import Control.Monad.Reduce
--
-- import qualified Data.Valuation as Val
--
-- import Control.Applicative
-- import Control.Monad.State
-- import Control.Monad.Trans.Maybe
-- import Data.Data
-- import Data.Function
-- import Data.Functor
-- import qualified Data.Map.Strict as Map
-- import Data.Maybe (catMaybes)
-- import qualified Language.C as C

-- type Lab = C.Ident
--
-- data LabInfo
--   = Type [C.CDeclarationSpecifier C.NodeInfo]
--
-- type CState = Map.Map Lab LabInfo
--
-- reduceC :: (MonadReduce Lab m, MonadState CState m) => C.CTranslUnit -> m C.CTranslUnit
-- reduceC (C.CTranslUnit es ni) = do
--   es' <- collect reduceCExternalDeclaration es
--   pure $ C.CTranslUnit es' ni
--  where
--   reduceCExternalDeclaration = \case
--     C.CFDefExt fun -> do
--       C.CFDefExt <$> reduce @C.CFunctionDef fun
--     C.CDeclExt decl ->
--       C.CDeclExt <$> reduce @C.CDeclaration decl
--     a -> error (show a)
--
-- identifiers :: forall a. (Data a) => a -> [Lab]
-- identifiers d = case cast d of
--   Just l -> [l]
--   Nothing -> concat $ gmapQ identifiers d
--
-- type Reducer m a = a -> m a
--
-- class CReducible c where
--   reduce :: (MonadReducePlus Lab m, MonadState CState m) => Reducer m (c C.NodeInfo)
--
-- cDeclaratorIdentifiers :: C.CDeclarator C.NodeInfo -> (Maybe Lab, [Lab])
-- cDeclaratorIdentifiers (C.CDeclr mi dd _ la _) =
--   (mi, identifiers dd <> identifiers la)
--
-- instance CReducible C.CFunctionDef where
--   reduce (C.CFunDef spc dec cdecls smt ni) = do
--     let (fn, ids) = cDeclaratorIdentifiers dec
--     let requirements = identifiers spc <> identifiers cdecls <> ids
--     case fn of
--       Just fn' ->
--         conditionalGivenThat requirements (Val.is fn')
--       Nothing ->
--         mapM_ (givenThat . Val.is) requirements
--     smt' <- reduce @C.CStatement smt
--     pure $ C.CFunDef spc dec cdecls smt' ni
--
-- instance CReducible C.CDeclaration where
--   reduce = \case
--     C.CDecl spc@(C.CStorageSpec (C.CTypedef _) : rst) decl ni -> do
--       decl' <-
--         decl & collectNonEmpty' \case
--           C.CDeclarationItem d Nothing Nothing -> do
--             let (x, _) = cDeclaratorIdentifiers d
--             case x of
--               Just x' ->
--                 splitOn
--                   (Val.is x')
--                   ( do
--                       modify (Map.insert x' (Type rst))
--                       mzero
--                   )
--                   (pure $ C.CDeclarationItem d Nothing Nothing)
--               Nothing ->
--                 pure $ C.CDeclarationItem d Nothing Nothing
--           a -> error (show a)
--       pure (C.CDecl spc decl' ni)
--     C.CDecl spc@[C.CTypeSpec (C.CTypeDef i ni')] decl ni -> do
--       x <- gets (Map.lookup i)
--       case x of
--         Just (Type rst) -> do
--           decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers rst) decl
--           pure $ C.CDecl rst decl' ni
--         Nothing -> do
--           decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--           pure $ C.CDecl spc decl' ni
--     C.CDecl spc decl ni -> do
--       decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--       pure $ C.CDecl spc decl' ni
--     a -> error (show a)
--    where
--     reduceCDeclarationItem rq' = \case
--       C.CDeclarationItem d i e -> do
--         let (fn, reqs) = cDeclaratorIdentifiers d
--         case fn of
--           Just fn' ->
--             conditionalGivenThat (rq' <> reqs) (Val.is fn')
--           Nothing ->
--             mapM_ (givenThat . Val.is) (rq' <> reqs)
--
--         i' <- optional do
--           liftMaybe i >>= reduce @C.CInitializer
--         e' <- optional do
--           liftMaybe e >>= reduce @C.CExpression
--
--         pure (C.CDeclarationItem d i' e')
--       a -> error (show a)
--
-- instance CReducible C.CInitializer where
--   reduce = \case
--     C.CInitExpr e ni -> reduce @C.CExpression e <&> \e' -> C.CInitExpr e' ni
--     C.CInitList (C.CInitializerList items) ni -> do
--       collectNonEmpty' rmCInitializerListItem items <&> \items' ->
--         C.CInitList (C.CInitializerList items') ni
--    where
--     rmCInitializerListItem (pds, is) = do
--       pds' <- collect rmCPartDesignator pds
--       is' <- reduce is
--       pure (pds', is')
--
--     rmCPartDesignator = \case
--       a -> error (show a)
--
-- instance CReducible C.CStatement where
--   reduce = \case
--     C.CCompound is cbi ni -> do
--       cbi' <- collect (reduce @C.CCompoundBlockItem) cbi
--       pure $ C.CCompound is cbi' ni
--     C.CExpr e ni -> do
--       e' <- optional do
--         e' <- liftMaybe e
--         reduce @C.CExpression e'
--       pure $ C.CExpr e' ni
--     C.CIf e s els ni -> do
--       s' <- reduce s
--       e' <- optional do
--         reduce @C.CExpression e
--       els' <- optional do
--         els' <- liftMaybe els
--         given >> reduce els'
--       case (e', els') of
--         (Nothing, Nothing) -> pure s'
--         (Just e'', Nothing) -> pure $ C.CIf e'' s' Nothing ni
--         (Nothing, Just x) -> pure $ C.CIf zeroExp s' (Just x) ni
--         (Just e'', Just x) -> pure $ C.CIf e'' s' (Just x) ni
--     C.CFor e1 e2 e3 s ni -> do
--       reduce s <| do
--
--         e1' <- reduce @C.CForInit e1
--         e2' <- optional $ liftMaybe e2 >>= reduce @C.CExpression
--         e3' <- optional $ liftMaybe e3 >>= reduce @C.CExpression
--         s' <- reduce s
--         pure $ C.CFor e1' e2' e3' s' ni
--     C.CReturn e ni -> do
--       e' <- traverse (fmap orZero reduce) e
--       pure $ C.CReturn e' ni
--     C.CBreak ni -> pure (C.CBreak ni)
--     C.CCont ni -> pure (C.CCont ni)
--     C.CLabel i s [] ni -> do
--       -- todo fix attrs
--       s' <- reduce s
--       withFallback s' do
--         givenThat (Val.is i)
--         pure $ C.CLabel i s' [] ni
--     C.CGoto i ni ->
--       withFallback (C.CExpr Nothing ni) do
--         givenThat (Val.is i)
--         pure $ C.CGoto i ni
--     C.CWhile e s dow ni -> do
--       e' <- orZero (reduce @C.CExpression e)
--       s' <- reduce s
--       pure $ C.CWhile e' s' dow ni
--     a -> error (show a)
--
-- instance CReducible C.CForInit where
--   reduce = \case
--     C.CForDecl decl -> withFallback (C.CForInitializing Nothing) do
--       C.CForDecl <$> reduce @C.CDeclaration decl
--     C.CForInitializing n -> do
--       C.CForInitializing <$> optional do
--         n' <- liftMaybe n
--         reduce @C.CExpression n'
--
--
-- zeroExp :: C.CExpression C.NodeInfo
-- zeroExp = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
--
-- withFallback :: (Alternative m) => a -> m a -> m a
-- withFallback a ma = ma <|> pure a
--
-- orZero :: (Alternative m) => m (C.CExpression C.NodeInfo) -> m (C.CExpression C.NodeInfo)
-- orZero = withFallback zeroExp
--
-- instance CReducible C.CCompoundBlockItem where
--   reduce = \case
--     C.CBlockStmt s ->
--       C.CBlockStmt <$> do
--         given >> reduce @C.CStatement s
--     C.CBlockDecl d ->
--       C.CBlockDecl <$> do
--         reduce @C.CDeclaration d
--     a -> error (show a)