ReduceC.hs

{-# LANGUAGE BangPatterns #-}
{-# 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.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)

-- import Debug.Trace
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 InlineType)
  }
  deriving (Show)

data InlineType
  = ITDelete
  | ITInline !C.CExpr
  | ITKeep
  deriving (Show, Eq)

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 -> InlineType -> 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
  -- TODO This is slow
  case r 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 ->
          case functionName fun of
            Just fid -> do
              split
                ("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r)
                (cont (addInlineExpr fid ITDelete ctx))
                do
                  r' <- C.CFDefExt <$> reduceCFunDef fun ctx
                  (r' :) <$> cont (addInlineExpr fid ITKeep ctx)
            Nothing -> do
              split
                ("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r)
                (cont ctx)
                do
                  r' <- C.CFDefExt <$> reduceCFunDef fun ctx
                  (r' :) <$> cont ctx
    C.CDeclExt result ->
      case inlineTypeDefs result ctx 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, HasCallStack)
  => 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
      (inlineTypeDefs spc ctx)
      (inlineTypeDefs dec ctx)
      (inlineTypeDefs cdecls ctx)
      smt'
      ni
 where
  !ctx' = foldr (`addInlineExpr` ITKeep) ctx (identifiers dec)

reduceCCompoundBlockItem
  :: (MonadReduce Lab m, HasCallStack)
  => 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 (inlineTypeDefs (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
              | otherwise -> cont ctx'
            _ow -> (C.CBlockDecl (inlineTypeDefs (C.CDecl rec decl' ni') ctx) :) <$> 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 (ITInline c') ctx))
        ( pure
            ( C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing : ds
            , addInlineExpr i ITKeep ctx
            )
        )
  C.CDeclarationItem (C.CDeclr (Just i) _ Nothing _ ni) _ Nothing -> do
    (ds, ctx) <- ma
    split
      ("remove variable " <> C.identToString i, C.posOf ni)
      (pure (ds, addInlineExpr i ITDelete ctx))
      (pure (d : ds, addInlineExpr i ITKeep ctx))
  a@(C.CDeclarationItem (C.CDeclr _ _ _ _ ni) _ _) -> do
    don'tHandleWithNodeInfo a ni
  a -> don'tHandle a

reduceCStatementOrEmptyBlock
  :: (MonadReduce Lab m, HasCallStack)
  => 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, HasCallStack)
  => 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.CCont ni -> Just do
    pure (C.CCont 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'tHandleWithPos 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.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, HasCallStack) => 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, HasCallStack) => 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
        ITKeep -> Just (pure expr)
        ITInline mx'
          | DisallowVariableInlining `isIn` ctx -> Nothing
          | otherwise -> Just (pure mx')
        ITDelete ->
          Nothing
      Nothing -> error ("Could not find " <> show i <> " at " <> show (C.posOf expr) <> "\n" <> show (inlineExprs ctx))
  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
  C.CCond ec et ef ni -> do
    -- TODO: More fine grained reduction is possible here.
    Just $ do
      ec' <- reduceCExprOrZero ec ctx
      ef' <- reduceCExprOrZero ef ctx
      et' <- case et of
        Just et' -> Just <$> reduceCExprOrZero et' ctx
        Nothing -> pure Nothing
      pure $ C.CCond ec' et' ef' ni
  C.CCast decl e ni -> do
    re <- reduceCExpr e ctx
    Just do
      split ("don't cast", C.posOf ni) re do
        e' <- re
        pure (C.CCast decl e' ni)
  C.CIndex e1 e2 ni -> do
    -- TODO: Better reduction is posisble here.
    re1 <- reduceCExpr e1 ctx
    Just do
      e1' <- re1
      e2' <- reduceCExprOrZero e2 ctx
      pure $ C.CIndex e1' e2' ni
  C.CComma items ni -> Just do
    let Just (x, rst) = List.uncons (reverse items)
    rst' <-
      foldr
        ( \e cc -> do
            maybeSplit ("remove expression", C.posOf e) (reduceCExpr e ctx) >>= \case
              Just e' -> (e' :) <$> cc
              Nothing -> cc
        )
        (pure [])
        rst
    x' <- reduceCExprOrZero x ctx
    if List.null rst'
      then pure x'
      else pure $ C.CComma (reverse (x' : rst')) ni
  a -> don'tHandleWithPos a

--       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.CMember e i b ni -> do
--       givenThat (Val.is i)
--       e' <- reduce e
--       pure $ C.CMember e' i b 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 $> ()))

don'tHandleWithPos :: (HasCallStack, Functor f, Show (f ()), C.Pos (f C.NodeInfo)) => f C.NodeInfo -> b
don'tHandleWithPos f = error (show (f $> ()) <> " at " <> show (C.posOf f))

don'tHandleWithNodeInfo :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> C.NodeInfo -> b
don'tHandleWithNodeInfo f ni = error (show (f $> ()) <> " at " <> show (C.posOf 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)

-- 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)