A questionable apporach to adding types

rtree-c/.hspec

 --failure-report .hspec-failures
+--fail-fast
 --rerun
---rerun-all-on-success

rtree-c/rtree-c.cabal

@@ -10,6 +10,7 @@ build-type:     Simple
 
 library
   exposed-modules:
+      CType
       ReduceC
   other-modules:
       Paths_rtree_c

rtree-c/src/CType.hs

+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | A module for typing of c expressions.
+module CType where
+
+import Control.Monad
+import qualified Data.List as List
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe
+import GHC.Stack
+import qualified Language.C as C
+
+data Params
+  = VoidParams
+  | Params ![Maybe Type] !Bool
+  deriving (Show, Eq)
+
+data FunType = FunType
+  { funTypeReturn :: !Voidable
+  , funTypeParams :: !Params
+  }
+  deriving (Show, Eq)
+
+data StructType = StructType
+  { structTypeTag :: !C.CStructTag
+  , structTypeName :: !(Maybe C.Ident)
+  , structTypeFields :: ![(C.Ident, Maybe Type)]
+  }
+  deriving (Show, Eq)
+
+data Type
+  = TNum
+  | TStruct !StructType
+  | TPointer !Voidable
+  | TFun !FunType
+  deriving (Show, Eq)
+
+isNum, isStruct, isPointer, isFun :: Type -> Bool
+isNum = \case TNum -> True; _ow -> False
+isStruct = \case TStruct _ -> True; _ow -> False
+isPointer = \case TPointer _ -> True; _ow -> False
+isFun = \case TFun _ -> True; _ow -> False
+
+data Voidable
+  = Void
+  | NonVoid !Type
+  deriving (Show, Eq)
+
+fromVoid :: a -> (Type -> a) -> Voidable -> a
+fromVoid a fn = \case
+  Void -> a
+  NonVoid t -> fn t
+{-# INLINE fromVoid #-}
+
+nonVoid :: (HasCallStack) => Voidable -> Type
+nonVoid = fromVoid (error "expected non void type") id
+{-# INLINE nonVoid #-}
+
+type TypeDefLookup = (C.Ident -> Maybe Type)
+type StructLookup = (C.Ident -> Maybe StructType)
+
+typeOf
+  :: (HasCallStack)
+  => StructLookup
+  -> TypeDefLookup
+  -> [C.CDeclarationSpecifier C.NodeInfo]
+  -> C.CDeclarator C.NodeInfo
+  -> Voidable
+typeOf structLookup typeDefLookup spec (C.CDeclr _ dd _ _ _) =
+  foldr applyDD (baseTypeOf structLookup typeDefLookup spec) dd
+ where
+  applyDD :: C.CDerivedDeclarator C.NodeInfo -> Voidable -> Voidable
+  applyDD = \case
+    C.CPtrDeclr _ _ -> NonVoid . TPointer
+    C.CArrDeclr{} -> NonVoid . TPointer
+    C.CFunDeclr params _ ni -> \c ->
+      case params of
+        C.CFunParamsNew params' varadic -> do
+          NonVoid $ TFun (FunType c (findParams varadic params'))
+        b -> notSupportedYet b ni
+
+  findParams :: Bool -> [C.CDeclaration C.NodeInfo] -> Params
+  findParams varadic = \case
+    [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
+    rst -> flip Params varadic $ flip map rst \case
+      C.CDecl spec' [] _ ->
+        Just . nonVoid $ baseTypeOf structLookup typeDefLookup spec'
+      C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
+        Just . nonVoid $ typeOf structLookup typeDefLookup spec' decl
+      a -> notSupportedYet' a
+
+typeSpecs :: [C.CDeclarationSpecifier a] -> [C.CTypeSpecifier a]
+typeSpecs = mapMaybe \case
+  C.CTypeSpec ts -> Just ts
+  _ow -> Nothing
+
+baseTypeOf
+  :: (HasCallStack)
+  => StructLookup
+  -> TypeDefLookup
+  -> [C.CDeclarationSpecifier C.NodeInfo]
+  -> Voidable
+baseTypeOf structLookup typeDefLookup =
+  maybe
+    (error "no type in type-specs")
+    ( \case
+        (t, []) -> NonEmpty.head t
+        (t, rs) -> error ("more than one type in type-specs: " <> show (t : rs))
+    )
+    . List.uncons
+    . NonEmpty.group
+    . map \case
+      C.CVoidType _ -> Void
+      C.CCharType _ -> NonVoid TNum
+      C.CShortType _ -> NonVoid TNum
+      C.CIntType _ -> NonVoid TNum
+      C.CFloatType _ -> NonVoid TNum
+      C.CDoubleType _ -> NonVoid TNum
+      C.CSignedType _ -> NonVoid TNum
+      C.CUnsigType _ -> NonVoid TNum
+      C.CBoolType _ -> NonVoid TNum
+      C.CLongType _ -> NonVoid TNum
+      C.CInt128Type _ -> NonVoid TNum
+      C.CFloatNType{} -> NonVoid TNum
+      C.CSUType c _ -> NonVoid (TStruct $ structTypeOf structLookup typeDefLookup c)
+      C.CEnumType _ _ -> NonVoid TNum
+      C.CTypeDef idx _ ->
+        case typeDefLookup idx of
+          Just t -> NonVoid t
+          Nothing -> error ("could not find typedef: " <> show (C.identToString idx))
+      a -> notSupportedYet (void a) a
+    . typeSpecs
+
+structTypeOf
+  :: (HasCallStack)
+  => StructLookup
+  -> TypeDefLookup
+  -> C.CStructureUnion C.NodeInfo
+  -> StructType
+structTypeOf structLookup typeDefLookup (C.CStruct t mi md _ _) =
+  case mi of
+    Just ix ->
+      case md of
+        Just p -> do
+          let p' = concatMap (namesAndTypeOf structLookup typeDefLookup) p
+          case structLookup ix of
+            Just s
+              | structTypeFields s == p' -> s
+              | otherwise -> error "what?"
+            Nothing ->
+              StructType
+                { structTypeTag = t
+                , structTypeName = mi
+                , structTypeFields = p'
+                }
+        Nothing ->
+          case structLookup ix of
+            Just s -> s
+            Nothing -> error "what!?"
+    Nothing -> do
+      let p' = maybe (error "what??") (concatMap (namesAndTypeOf structLookup typeDefLookup)) md
+      StructType
+        { structTypeTag = t
+        , structTypeName = mi
+        , structTypeFields = p'
+        }
+
+namesAndTypeOf
+  :: (HasCallStack)
+  => StructLookup
+  -> TypeDefLookup
+  -> C.CDeclaration C.NodeInfo
+  -> [(C.Ident, Maybe Type)]
+namesAndTypeOf structLookup typeDefLookup = \case
+  C.CDecl spec items ni ->
+    flip map items \case
+      C.CDeclarationItem decl@(C.CDeclr (Just ix) _ _ _ _) _ _ ->
+        (ix, Just . nonVoid $ typeOf structLookup typeDefLookup spec decl)
+      a -> notSupportedYet (void a) ni
+  a -> notSupportedYet' a
+
+notSupportedYet :: (HasCallStack, Show a, C.Pos n) => a -> n -> b
+notSupportedYet a ni = error (show a <> " at " <> show (C.posOf ni))
+
+notSupportedYet' :: (HasCallStack, Show (a ()), Functor a, C.Pos (a C.NodeInfo)) => a C.NodeInfo -> b
+notSupportedYet' a = notSupportedYet (void a) a

rtree-c/test/cases/small/add.c

 int add(int a, int b) { 
-  return a + b;
 }
 
 int main() { 

rtree-c/test/cases/small/declaration.c

-int printf(const char *, ...), add(int a, int b);
+int printf(const char *, ...), add(int a);
 int *test();
 
 int main () {
-  printf("Hello, World!");
 }

rtree-c/test/cases/small/functions.c

-int f(int a) { 
-  a;
-}
+int f(int a) { }
 
-int g(int a) { 
-}
+int g(int a) { }
 
 int main() { 
     return f(g(42));

rtree-c/test/cases/small/legacy.c

 float fabs(float);
-float testx(float);
-float testy(float a);
 
-int main() {
-  return 0;
-}
+int main() { }

rtree-c/test/cases/small/pointer.c

+int a = 0;
+int *b = &a;
+int **c = &b;
+
+int main (){}

rtree-c/test/cases/small/printf.c

 void printf(const char* fmt,...);
 
 int main(void) {
-  printf("Hello, %s %s", "World", "!");
-  return 0;
+  printf("Hello, %s %s", "World");
 }

rtree-c/test/expected/add/main.c

 int add(int a, int b)
 {
-    return a + b;
 }
 int main()
 {

rtree-c/test/expected/add/main.hs

@@ -40,13 +40,8 @@ CTranslUnit
                 [ CBlockStmt
                     ( CReturn
                         ( Just
-                            ( CBinary CAddOp
-                                ( CVar
-                                    ( Ident "a" 97 () ) ()
-                                )
-                                ( CVar
-                                    ( Ident "b" 98 () ) ()
-                                ) ()
+                            ( CConst
+                                ( CIntConst 0 () )
                             )
                         ) ()
                     )

rtree-c/test/expected/add/reduction/r000000.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove return statement at ("test/cases/small/add.c": line 5)
+// 0 reduce to expression at ("test/cases/small/add.c": line 5)
+// 0 reduce to expression at ("test/cases/small/add.c": line 5)
+
+int add(int a, int b)
+{
+}
+int main()
+{
+    return add(10, 23);
+}

rtree-c/test/expected/add/reduction/r000001.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove return statement at ("test/cases/small/add.c": line 5)
+// 0 reduce to expression at ("test/cases/small/add.c": line 5)
+// 1 reduce to expression at ("test/cases/small/add.c": line 5)
+
+int add(int a, int b)
+{
+}
+int main()
+{
+    return 10;
+}

rtree-c/test/expected/add/reduction/r00001.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove return statement at ("test/cases/small/add.c": line 5)
+// 1 reduce to expression at ("test/cases/small/add.c": line 5)
+
+int add(int a, int b)
+{
+}
+int main()
+{
+    return 23;
+}

rtree-c/test/expected/add/reduction/r0001.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 1 remove return statement at ("test/cases/small/add.c": line 5)
+
+int add(int a, int b)
+{
+}
+int main()
+{
+}

rtree-c/test/expected/add/reduction/r001000.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove return statement at ("test/cases/small/add.c": line 5)
+// 0 reduce to expression at ("test/cases/small/add.c": line 5)
+// 0 reduce to expression at ("test/cases/small/add.c": line 5)
+
+int add(int a)
+{
+}
+int main()
+{
+    return add(10);
+}

rtree-c/test/expected/add/reduction/r001001.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove return statement at ("test/cases/small/add.c": line 5)
+// 0 reduce to expression at ("test/cases/small/add.c": line 5)
+// 1 reduce to expression at ("test/cases/small/add.c": line 5)
+
+int add(int a)
+{
+}
+int main()
+{
+    return 10;
+}

rtree-c/test/expected/add/reduction/r00101.c

+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove return statement at ("test/cases/small/add.c": line 5)
+// 1 reduce to expression at ("test/cases/small/add.c": line 5)
+
+int add(int a)
+{
+}
+int main()
+{
+    return 23;
+}

rtree-c/test/expected/add/reduction/r0011011.c → rtree-c/test/expected/add/reduction/r0011.c

-// 0 remove function add 41 at ("test/cases/small/add.c": line 1)
-// 0 remove function add 41 at ("test/cases/small/add.c": line 1)
+// 0 remove function add (25) at ("test/cases/small/add.c": line 1)
+// 0 remove parameter at ("test/cases/small/add.c": line 1)
 // 1 remove parameter at ("test/cases/small/add.c": line 1)
-// 1 remove parameter at ("test/cases/small/add.c": line 1)
-// 0 Remove compound at ("test/cases/small/add.c": line 1)
-// 1 remove return statement at ("test/cases/small/add.c": line 6)
-// 1 Remove compound at ("test/cases/small/add.c": line 5)
+// 1 remove return statement at ("test/cases/small/add.c": line 5)
 
-int add()
+int add(int a)
 {
 }
 int main()