Skip to content
Snippets Groups Projects
Main.hs 2.83 KiB
Newer Older
  • Learn to ignore specific revisions
  • chrg's avatar
    chrg committed
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE DerivingVia #-}
    {-# LANGUAGE ImportQualifiedPost #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE PackageImports #-}
    
    import Control.RTree
    
    import Data.Maybe (catMaybes, fromMaybe)
    import Language.C qualified as C
    import "pretty" Text.PrettyPrint qualified as P
    import "transformers" Control.Monad.Trans.Maybe
    import "typed-process" System.Process.Typed
    
    main :: IO ()
    main = do
      C.parseCFilePre "test/data/file2.c" >>= \case
        Right file -> do
          l <- runMaybeT (reduce' check (reduceC file))
          case l of
            Just l' -> output l'
            Nothing ->
              putStrLn "Failure"
        Left err ->
          print err
     where
      output l = do
        writeFile "test.c" (P.render (C.pretty l))
    
      check l = MaybeT do
        putStrLn "Outputting test"
        output l
        putStrLn "Running test"
        err <- runProcess (proc "clang" ["-O0", "test.c"])
        putStrLn $ "Done test" <> show err
        pure $ if err == ExitSuccess then Just () else Nothing
    
    type Lab = C.Ident
    
    reduceC :: C.CTranslUnit -> RTree' Lab C.CTranslUnit
    reduceC (C.CTranslUnit es _) = do
      es' <- traverse rCExternalDeclaration es
      pure $ C.CTranslUnit (catMaybes es') C.undefNode
    
    rCExternalDeclaration
      :: C.CExternalDeclaration C.NodeInfo
      -> RTree' Lab (Maybe (C.CExternalDeclaration C.NodeInfo))
    rCExternalDeclaration e = case e of
      C.CFDefExt fun ->
        split
          (funName fun)
          (pure Nothing)
          (Just . C.CFDefExt <$> rCFunctionDef fun)
      _ -> pure Nothing <| pure (Just e)
     where
      funName (C.CFunDef _ (C.CDeclr x _ _ _ _) _ _ _) =
        x
    
    rCFunctionDef :: C.CFunctionDef C.NodeInfo -> RTree' Lab (C.CFunctionDef C.NodeInfo)
    rCFunctionDef (C.CFunDef spc dec cdecls smt _) = do
      smt' <- rCStatement smt
      pure $ C.CFunDef spc dec cdecls smt' C.undefNode
    
    rCStatement :: C.CStatement C.NodeInfo -> RTree' Lab (C.CStatement C.NodeInfo)
    rCStatement = \case
      C.CCompound is cbi _ -> do
        cbi' <- traverse rCCompoundBlockItem cbi
        pure $ C.CCompound is (catMaybes cbi') C.undefNode
      C.CExpr (Just e) _ -> do
        e' <- rCExpression e
        pure $ C.CExpr e' C.undefNode
      a -> pure a
    
    rCExpression :: C.CExpression C.NodeInfo -> RTree' Lab (Maybe (C.CExpression C.NodeInfo))
    rCExpression = \case
      C.CVar i _ ->
        splitOn
          i
          (pure Nothing)
          (pure . Just $ C.CVar i C.undefNode)
      C.CCall e es _ -> do
        me' <- rCExpression e
        case me' of
          Nothing -> pure Nothing
          Just e' -> do
            es' <-
              traverse
                ( fmap
                    ( fromMaybe (C.CConst (C.CIntConst (C.cInteger 0) C.undefNode))
                    )
                    . rCExpression
                )
                es
            pure . Just $ C.CCall e' es' C.undefNode
      e -> pure Nothing <| pure (Just e)
    
    rCCompoundBlockItem :: C.CCompoundBlockItem C.NodeInfo -> RTree' Lab (Maybe (C.CCompoundBlockItem C.NodeInfo))
    rCCompoundBlockItem a = pure Nothing <| pure (Just a)