LCQLens.hs

{-# LANGUAGE OverloadedStrings, TypeOperators #-}
import Control.Monad (mapM)
import Data.String

import Language.C.Syntax
import Control.Category
import Prelude hiding ((.), id)

import Language.C.Parser
import qualified Language.C.Syntax as C
import Data.Loc
import Control.Applicative hiding (Const)

-- LENS
import Data.Label.Partial as P
import qualified Data.Label.Poly as O
import qualified Data.Label.Base as L

ctes = head $ c_code "int4" "" []

fu1 :: Monad m => (BlockItem -> m a) -> m [a]
fu1 f = maybe (return []) (mapM f) $ P.get fundef ctes

fu2 :: Monad m => (Init -> m a) -> m [[a]]
fu2 f = fu1 ((\x -> maybe (return []) (mapM f) $ P.get blockdef x))

fu3 :: Monad m => (Initializer -> m ()) -> m [[()]]
fu3 f = fu2 (\y -> maybe (return ()) f $ P.get initdef y)

fundef :: (C.Definition -> C.Definition) :~> ([C.BlockItem] -> [C.BlockItem])
fundef = lens get undefined
  where
    get :: C.Definition -> Maybe [C.BlockItem]
    get (C.FuncDef (C.Func _ _ _ _ x _) _) = Just x
    get _ = Nothing

blockdef :: (C.BlockItem -> C.BlockItem) :~> ([C.Init] -> [C.Init])
blockdef = lens get undefined
  where
    get :: C.BlockItem -> Maybe [C.Init]
    get (C.BlockDecl (C.InitGroup _ _ x _)) = Just x
    get _ = Nothing

initdef :: (C.Init -> C.Init) :~> (C.Initializer -> C.Initializer)
initdef = lens get undefined
  where
    get (C.Init _ _ _ (Just x) _ _) = Just x
    get _ = Nothing

-- BOILERPLATE

l = fromPos $ startPos "tests"

instance IsString Id where
  fromString = flip Id l

c_code :: String -> String -> [Id] -> [Definition]
c_code quoter expression vars = [
  FuncDef (
  Func (DeclSpec [] [] (Tint Nothing l) l) (Id "main" l) (DeclRoot l)
  (Params [Param Nothing (DeclSpec [] [] (Tvoid l) l) (DeclRoot l) l] False l) [
  
    -- int x = 2;
    BlockDecl (InitGroup (DeclSpec [] [] (Tint Nothing l) l) []
      [Init (Id "x" l) (DeclRoot l) Nothing
      (Just (ExpInitializer (Const (IntConst "2" Signed 2 l) l) l)) [] l] l),
    
    -- int y = 4;
    BlockDecl (InitGroup (DeclSpec [] [] (Tint Nothing l) l) []
      [Init (Id "y" l) (DeclRoot l) Nothing
      (Just (ExpInitializer (Const (IntConst "4" Signed 4 l) l) l)) [] l] l),

    --  printf("%d %f", z);
    BlockStm (Exp (Just (FnCall (Var (Id "printf" l) l)
      [Const (StringConst ["\"%d\""] "%d" l) l,Var (Id "z" l) l] l)) l),
    
    -- return 0;
    BlockStm (Return (Just (Const (IntConst "0" Signed 0 l) l)) l)] l)
    
  l]