Skip to content
Snippets Groups Projects
ReduceC.hs 9.28 KiB
Newer Older
  • Learn to ignore specific revisions
  • chrg's avatar
    chrg committed
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE NoMonomorphismRestriction #-}
    
    module ReduceC where
    
    import Control.Monad.Reduce
    
    import Control.Applicative
    import Control.Monad.Trans
    import Control.Monad.Trans.Maybe
    
    chrg's avatar
    chrg committed
    import Data.Foldable
    
    chrg's avatar
    chrg committed
    import Data.Functor
    import Data.Maybe
    import qualified Language.C as C
    
    type Lab = C.Ident
    
    reduceC :: (MonadReduce Lab m) => C.CTranslUnit -> m C.CTranslUnit
    reduceC (C.CTranslUnit es ni) = do
      es' <- collect mrCExternalDeclaration es
      pure $ C.CTranslUnit es' ni
    
    mrCExternalDeclaration :: (MonadReduce Lab m) => C.CExternalDeclaration C.NodeInfo -> MaybeT m (C.CExternalDeclaration C.NodeInfo)
    mrCExternalDeclaration = \case
      C.CFDefExt fun -> do
    
    chrg's avatar
    chrg committed
        C.CFDefExt <$> mrCFunctionDef fun
    
    chrg's avatar
    chrg committed
      C.CDeclExt decl ->
        C.CDeclExt <$> mrCDeclaration decl
      a -> error (show a)
    
    chrg's avatar
    chrg committed
    
    mrCDeclaration :: (MonadReduce Lab m) => C.CDeclaration C.NodeInfo -> MaybeT m (C.CDeclaration C.NodeInfo)
    mrCDeclaration = \case
      C.CDecl spc decl ni -> do
        mapM_ cCDeclarationSpecifier spc
        decl' <- lift $ collect mrCDeclarationItem decl
        case decl' of
          [] -> empty
          decl'' -> pure $ C.CDecl spc decl'' ni
      a -> error (show a)
    
    chrg's avatar
    chrg committed
    
    mrCDeclarationItem :: (MonadReduce Lab m) => C.CDeclarationItem C.NodeInfo -> MaybeT m (C.CDeclarationItem C.NodeInfo)
    mrCDeclarationItem = \case
    
    chrg's avatar
    chrg committed
      C.CDeclarationItem d i e -> do
    
    chrg's avatar
    chrg committed
        i' <- mtry $ munder i mrCInitializer
        e' <- mtry $ munder e mrCExpression
    
    chrg's avatar
    chrg committed
        cCDeclr d
    
    chrg's avatar
    chrg committed
        pure (C.CDeclarationItem d i' e')
      a -> error (show a)
    
    
    chrg's avatar
    chrg committed
    cCDeclarationItem :: (MonadReduce Lab m) => C.CDeclarationItem C.NodeInfo -> MaybeT m ()
    cCDeclarationItem = \case
      C.CDeclarationItem d i e -> do
        munder i cCInitializer
        munder e cCExpression
        cCDeclr d
      a -> error (show a)
    
    cCDeclaration :: (MonadReduce Lab m) => C.CDeclaration C.NodeInfo -> MaybeT m ()
    cCDeclaration = \case
      C.CDecl spc decl _ -> do
        forM_ spc cCDeclarationSpecifier
        mapM_ cCDeclarationItem decl
      a -> error (show a)
    
    cCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> MaybeT m ()
    cCExpression e =
      -- TODO not optimal, create version that only checks for identifiers  .
      void $ mrCExpression e
    
    cCDeclarationSpecifier :: (MonadReduce Lab m) => C.CDeclarationSpecifier C.NodeInfo -> MaybeT m ()
    cCDeclarationSpecifier = \case
      C.CTypeSpec t -> cCTypeSpecifier t
      C.CStorageSpec _ -> pure ()
      C.CTypeQual t -> cCTypeQualifier t
      C.CFunSpec _ -> pure ()
      C.CAlignSpec (C.CAlignAsType t _) -> cCDeclaration t
      C.CAlignSpec (C.CAlignAsExpr t _) -> cCExpression t
    
    cCTypeQualifier :: (MonadReduce Lab m) => C.CTypeQualifier C.NodeInfo -> MaybeT m ()
    cCTypeQualifier = \case
      C.CAttrQual a -> cCAttr a
      _ -> pure ()
    
    cCTypeSpecifier :: (MonadReduce Lab m) => C.CTypeSpecifier C.NodeInfo -> MaybeT m ()
    cCTypeSpecifier = \case
      C.CVoidType _ -> pure ()
      C.CCharType _ -> pure ()
      C.CShortType _ -> pure ()
      C.CIntType _ -> pure ()
      C.CLongType _ -> pure ()
      C.CFloatType _ -> pure ()
      C.CDoubleType _ -> pure ()
      C.CSignedType _ -> pure ()
      C.CUnsigType _ -> pure ()
      C.CBoolType _ -> pure ()
      C.CComplexType _ -> pure ()
      C.CInt128Type _ -> pure ()
      -- C.CUInt128Type a -> pure ()
      C.CFloatNType{} -> pure ()
      C.CTypeDef i _ -> do
        givenThat i
        pure ()
      (C.CTypeOfExpr e _) -> cCExpression e
      (C.CTypeOfType t _) -> cCDeclaration t
      (C.CAtomicType t _) -> cCDeclaration t
      a@(C.CSUType _ _) -> error (show a)
      a@(C.CEnumType _ _) -> error (show a)
    
    cCInitializer :: (MonadReduce Lab m) => C.CInitializer C.NodeInfo -> MaybeT m ()
    cCInitializer = void . mrCInitializer
    
    
    chrg's avatar
    chrg committed
    mrCInitializer :: (MonadReduce Lab m) => C.CInitializer C.NodeInfo -> MaybeT m (C.CInitializer C.NodeInfo)
    mrCInitializer = \case
      C.CInitExpr e ni -> mrCExpression 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' <- lift $ collect rmCPartDesignator pds
        is' <- mrCInitializer is
        pure (pds', is')
    
      rmCPartDesignator :: (MonadReduce Lab m) => C.CPartDesignator C.NodeInfo -> m (C.CPartDesignator C.NodeInfo)
      rmCPartDesignator = \case
        a -> error (show a)
    
    
    chrg's avatar
    chrg committed
    mrCFunctionDef :: (MonadReduce Lab m) => C.CFunctionDef C.NodeInfo -> MaybeT m (C.CFunctionDef C.NodeInfo)
    mrCFunctionDef (C.CFunDef spc dec cdecls smt ni) = do
      smt' <- lift $ rCStatement smt
      mapM_ cCDeclaration cdecls
      mapM_ cCDeclarationSpecifier spc
      cCDeclr dec
    
    chrg's avatar
    chrg committed
      pure $ C.CFunDef spc dec cdecls smt' ni
    
    
    chrg's avatar
    chrg committed
    cCDeclr :: (MonadReduce Lab m) => C.CDeclarator C.NodeInfo -> MaybeT m ()
    cCDeclr (C.CDeclr x dd _ _ _) = do
      mapM_ cCDerivedDeclarator dd
      givenWith x
     where
      cCDerivedDeclarator = \case
        C.CPtrDeclr ts _ -> mapM_ cCTypeQualifier ts
        C.CArrDeclr ts as _ -> do
          mapM_ cCTypeQualifier ts
          case as of
            C.CNoArrSize _ -> pure ()
            C.CArrSize _ e -> cCExpression e
        C.CFunDeclr f attr _ -> do
          mapM_ cCAttr attr
          cCFunParams f
      cCFunParams = \case
        C.CFunParamsOld o -> mapM_ givenThat o
        C.CFunParamsNew o _ -> mapM_ cCDeclaration o
    
    cCAttr :: (MonadReduce Lab m) => C.CAttribute C.NodeInfo -> MaybeT m ()
    cCAttr (C.CAttr i e _) = do
      mapM_ cCExpression e
      givenThat i
    
    
    chrg's avatar
    chrg committed
    rCStatement :: (MonadReduce Lab m) => C.CStatement C.NodeInfo -> m (C.CStatement C.NodeInfo)
    rCStatement = \case
      C.CCompound is cbi ni -> do
        cbi' <- collect mrCCompoundBlockItem cbi
        pure $ C.CCompound is cbi' ni
      C.CExpr e ni -> do
        e' <- runMaybeT $ munder e mrCExpression
        pure $ C.CExpr e' ni
      C.CIf e s els ni -> do
        e' <- runMaybeT $ mrCExpression e
        s' <- rCStatement s
        els' <- case els of
          Just els' -> do
            pure Nothing <| Just <$> rCStatement els'
          Nothing -> pure Nothing
        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
        rCStatement s <| do
          e1' <- rCForInit e1
          e2' <- runMaybeT $ munder e2 mrCExpression
          e3' <- runMaybeT $ munder e3 mrCExpression
          s' <- rCStatement s
          pure $ C.CFor e1' e2' e3' s' ni
      C.CReturn e ni -> do
        e' <- case e of
          Nothing -> pure Nothing
          Just e' -> Just <$> zrCExpression 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 ->
        -- todo fix attrs
        splitOn i (rCStatement s) do
          s' <- rCStatement s
          pure $ C.CLabel i s' [] ni
      C.CGoto i ni ->
        -- todo fix attrs
        splitOn i (pure $ C.CExpr Nothing ni) do
          pure $ C.CGoto i ni
    
    chrg's avatar
    chrg committed
      C.CWhile e s dow ni -> do
        e' <- zrCExpression e
        s' <- rCStatement s
        pure $ C.CWhile e' s' dow ni
    
    chrg's avatar
    chrg committed
      a -> error (show a)
     where
      rCForInit = \case
        C.CForDecl decl -> do
          m <- runMaybeT $ mrCDeclaration decl
          pure $ case m of
            Nothing -> C.CForInitializing Nothing
            Just d' -> C.CForDecl d'
        C.CForInitializing n -> do
          C.CForInitializing <$> runMaybeT (munder n mrCExpression)
    
    orZero :: Maybe (C.CExpression C.NodeInfo) -> C.CExpression C.NodeInfo
    orZero = fromMaybe zeroExp
    
    zeroExp :: C.CExpression C.NodeInfo
    zeroExp = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
    
    zrCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> m (C.CExpression C.NodeInfo)
    zrCExpression e = orZero <$> runMaybeT (mrCExpression e)
    
    mrCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> MaybeT m (C.CExpression C.NodeInfo)
    mrCExpression = \case
      C.CVar i ni -> do
        givenThat i
        pure $ C.CVar i ni
      C.CCall e es ni -> do
        e' <- mrCExpression e
        es' <- lift $ traverse zrCExpression es
        pure $ C.CCall e' es' ni
      C.CCond ec et ef ni -> do
        ec' <- mrCExpression ec
        ef' <- mrCExpression ef
        et' <- mtry $ munder et mrCExpression
        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 <- mrCExpression 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' <- mrCDeclaration cd
        e' <- mrCExpression e
        pure $ C.CCast cd' e' ni
      C.CAssign op e1 e2 ni -> onBothExpr e1 e2 \e1' e2' ->
        pure $ C.CAssign op e1' e2' ni
      C.CIndex e1 e2 ni -> onBothExpr e1 e2 \e1' e2' ->
        pure $ C.CIndex e1' e2' ni
      C.CMember e i b ni -> do
        givenThat i
        e' <- mrCExpression e
        pure $ C.CMember e' i b ni
      C.CComma items ni -> do
        C.CComma <$> collectNonEmpty' mrCExpression items <*> pure ni
      e -> error (show e)
     where
      onBothExpr elhs erhs = onBoth (mrCExpression elhs) (mrCExpression erhs)
    
    mrCCompoundBlockItem
      :: (MonadReduce Lab m)
      => C.CCompoundBlockItem C.NodeInfo
      -> MaybeT m (C.CCompoundBlockItem C.NodeInfo)
    mrCCompoundBlockItem = \case
      C.CBlockStmt s -> empty <| lift (C.CBlockStmt <$> rCStatement s)
      C.CBlockDecl d -> C.CBlockDecl <$> mrCDeclaration d
      a -> error (show a)
    
    mtry :: (Functor m) => MaybeT m a -> MaybeT m (Maybe a)
    mtry (MaybeT mt) = MaybeT (Just <$> mt)
    
    mlift :: (Applicative m) => Maybe a -> MaybeT m a
    mlift a = MaybeT (pure a)
    
    munder :: (Monad m) => Maybe a -> (a -> MaybeT m b) -> MaybeT m b
    munder a mf = mlift a >>= mf