{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.SemFmt.StructPack (descr) where

import           Data.Fix                     (Fix (..))
import           Data.Text                    (Text)
import qualified Data.Text                    as Text
import           Language.Cimple              (BinaryOp (..), Lexeme (..),
                                               LexemeClass (..),
                                               LiteralType (..), Node,
                                               NodeF (..), UnaryOp (..))
import           Language.Cimple.Diagnostics  (CimplePos, Diagnostic)
import           Tokstyle.Common.StructLinter (MkFunBody, analyseStructs, mkLAt)
import           Tokstyle.Common.TypeSystem   (StdType (..), TypeDescr (..),
                                               TypeInfo (..), TypeRef (..))


funSuffix :: Text
funSuffix :: Text
funSuffix = Text
"_pack"

{-
return bin_pack_array(bp, 5)
           && bin_pack_u08(bp, foo->some_byte)
           && bin_pack_u16(bp, foo->some_short)
           && some_enum_pack(bp, foo->type)
           && bin_pack_bin(bp, foo->message, foo->message_length)
           && bin_pack_bin(bp, foo->key, 32);
-}
mkFunBody :: MkFunBody
mkFunBody :: MkFunBody
mkFunBody TypeSystem
_ Lexeme Text
varName (StructDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)
mem]) = do
    Node (Lexeme Text)
packMems <- Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName (Lexeme Text, TypeInfo)
mem
    Either Text (Node (Lexeme Text))
-> Maybe (Either Text (Node (Lexeme Text)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Node (Lexeme Text))
 -> Maybe (Either Text (Node (Lexeme Text))))
-> Either Text (Node (Lexeme Text))
-> Maybe (Either Text (Node (Lexeme Text)))
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> Either Text (Node (Lexeme Text))
forall a b. b -> Either a b
Right (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ([Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. [a] -> NodeF lexeme a
CompoundStmt [NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Maybe (Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. Maybe a -> NodeF lexeme a
Return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just Node (Lexeme Text)
packMems))]))
mkFunBody TypeSystem
_ Lexeme Text
varName (StructDescr Lexeme Text
sname [(Lexeme Text, TypeInfo)]
mems) = do
    let packArray :: Node (Lexeme Text)
packArray = Lexeme Text -> Int -> Node (Lexeme Text)
mkPackArray Lexeme Text
sname ([(Lexeme Text, TypeInfo)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Lexeme Text, TypeInfo)]
mems)
    Node (Lexeme Text)
packMems <- (Node (Lexeme Text) -> Node (Lexeme Text) -> Node (Lexeme Text))
-> Node (Lexeme Text) -> [Node (Lexeme Text)] -> Node (Lexeme Text)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
x Node (Lexeme Text)
y -> NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> BinaryOp
-> Node (Lexeme Text)
-> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> BinaryOp -> a -> NodeF lexeme a
BinaryExpr Node (Lexeme Text)
y BinaryOp
BopAnd Node (Lexeme Text)
x)) Node (Lexeme Text)
packArray ([Node (Lexeme Text)] -> Node (Lexeme Text))
-> ([Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)]
-> Node (Lexeme Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a]
reverse ([Node (Lexeme Text)] -> Node (Lexeme Text))
-> Maybe [Node (Lexeme Text)] -> Maybe (Node (Lexeme Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text)))
-> [(Lexeme Text, TypeInfo)] -> Maybe [Node (Lexeme Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName) [(Lexeme Text, TypeInfo)]
mems
    Either Text (Node (Lexeme Text))
-> Maybe (Either Text (Node (Lexeme Text)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Node (Lexeme Text))
 -> Maybe (Either Text (Node (Lexeme Text))))
-> Either Text (Node (Lexeme Text))
-> Maybe (Either Text (Node (Lexeme Text)))
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> Either Text (Node (Lexeme Text))
forall a b. b -> Either a b
Right (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ([Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. [a] -> NodeF lexeme a
CompoundStmt [NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Maybe (Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. Maybe a -> NodeF lexeme a
Return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just Node (Lexeme Text)
packMems))]))
mkFunBody TypeSystem
_ Lexeme Text
_ TypeDescr
ty = [Char] -> Maybe (Either Text (Node (Lexeme Text)))
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe (Either Text (Node (Lexeme Text))))
-> [Char] -> Maybe (Either Text (Node (Lexeme Text)))
forall a b. (a -> b) -> a -> b
$ TypeDescr -> [Char]
forall a. Show a => a -> [Char]
show TypeDescr
ty

mkPackArray :: Lexeme Text -> Int -> Node (Lexeme Text)
mkPackArray :: Lexeme Text -> Int -> Node (Lexeme Text)
mkPackArray Lexeme Text
sname Int
size =
    NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> [Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> [a] -> NodeF lexeme a
FunctionCall (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
sname LexemeClass
IdVar Text
"bin_pack_array")))
        [ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
sname LexemeClass
IdVar Text
"bp"))
        , NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (LiteralType
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. LiteralType -> lexeme -> NodeF lexeme a
LiteralExpr LiteralType
Int (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
sname LexemeClass
LitInteger ([Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
size)))
        ])

builtinPackFunName :: StdType -> Maybe Text
builtinPackFunName :: StdType -> Maybe Text
builtinPackFunName StdType
BoolTy = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_bool"
builtinPackFunName StdType
U08Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_u08"
builtinPackFunName StdType
S08Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_s08"
builtinPackFunName StdType
U16Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_u16"
builtinPackFunName StdType
S16Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_s16"
builtinPackFunName StdType
U32Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_u32"
builtinPackFunName StdType
S32Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_s32"
builtinPackFunName StdType
U64Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_u64"
builtinPackFunName StdType
S64Ty  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bin_pack_s64"
builtinPackFunName StdType
_      = Maybe Text
forall a. Maybe a
Nothing

stripWrappers :: TypeInfo -> TypeInfo
stripWrappers :: TypeInfo -> TypeInfo
stripWrappers (Owner TypeInfo
ty)    = TypeInfo -> TypeInfo
stripWrappers TypeInfo
ty
stripWrappers (Nonnull TypeInfo
ty)  = TypeInfo -> TypeInfo
stripWrappers TypeInfo
ty
stripWrappers (Nullable TypeInfo
ty) = TypeInfo -> TypeInfo
stripWrappers TypeInfo
ty
stripWrappers (Const TypeInfo
ty)    = TypeInfo -> TypeInfo
stripWrappers TypeInfo
ty
stripWrappers TypeInfo
ty            = TypeInfo
ty

packFunName :: TypeInfo -> Maybe (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName :: TypeInfo
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName (BuiltinType StdType
ty) =
    Text
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
forall a b. a -> Either a b
Left (Text
 -> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
-> Maybe Text
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StdType -> Maybe Text
builtinPackFunName StdType
ty
packFunName (TypeRef TypeRef
EnumRef (L AlexPosn
_ LexemeClass
_ Text
name)) =
    Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. a -> Maybe a
Just (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
 -> Maybe
      (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)))
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a b. (a -> b) -> a -> b
$ (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
forall a b. b -> Either a b
Right (Node (Lexeme Text) -> Node (Lexeme Text)
forall a. a -> a
id, Text -> Text
Text.toLower Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_pack")
packFunName (Pointer (TypeRef TypeRef
StructRef (L AlexPosn
_ LexemeClass
_ Text
name))) =
    Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. a -> Maybe a
Just (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
 -> Maybe
      (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)))
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a b. (a -> b) -> a -> b
$ (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
forall a b. b -> Either a b
Right (Node (Lexeme Text) -> Node (Lexeme Text)
forall a. a -> a
id, Text -> Text
Text.toLower Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_pack")
packFunName (TypeRef TypeRef
StructRef (L AlexPosn
_ LexemeClass
_ Text
name)) =
    Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. a -> Maybe a
Just (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
 -> Maybe
      (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)))
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a b. (a -> b) -> a -> b
$ (Node (Lexeme Text) -> Node (Lexeme Text), Text)
-> Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
forall a b. b -> Either a b
Right (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text))
-> (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text)))
-> Node (Lexeme Text)
-> Node (Lexeme Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnaryOp
-> Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. UnaryOp -> a -> NodeF lexeme a
UnaryExpr UnaryOp
UopAddress, Text -> Text
Text.toLower Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_pack")
packFunName (Pointer Const{})    = Maybe
  (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. Maybe a
Nothing
packFunName (Pointer TypeInfo
_)          = Maybe
  (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. Maybe a
Nothing
packFunName (TypeRef TypeRef
UnionRef Lexeme Text
_) = Maybe
  (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. Maybe a
Nothing  -- TODO(iphydf): Union pack.
packFunName (Owner TypeInfo
ty)           = TypeInfo
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName TypeInfo
ty
packFunName (Nonnull TypeInfo
ty)         = TypeInfo
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName TypeInfo
ty
packFunName (Nullable TypeInfo
ty)        = TypeInfo
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName TypeInfo
ty
packFunName (Const TypeInfo
ty)           = TypeInfo
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName TypeInfo
ty
packFunName TypeInfo
x                    = [Char]
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> Maybe
      (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)))
-> [Char]
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
forall a b. (a -> b) -> a -> b
$ TypeInfo -> [Char]
forall a. Show a => a -> [Char]
show TypeInfo
x

-- bin_pack_bin(bp, var->mem, size)
mkPackBinStr :: Text -> Lexeme Text -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
mkPackBinStr :: Text
-> Lexeme Text
-> Lexeme Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
mkPackBinStr Text
fun Lexeme Text
varName Lexeme Text
memName Node (Lexeme Text)
size =
    NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> [Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> [a] -> NodeF lexeme a
FunctionCall (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
memName LexemeClass
IdVar Text
fun)))
        [ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
memName LexemeClass
IdVar Text
"bp"))
        , NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> lexeme -> NodeF lexeme a
PointerAccess (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
varName)) Lexeme Text
memName)
        , Node (Lexeme Text)
size
        ])

getPackFn :: StdType -> Maybe (Lexeme Text -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
getPackFn :: StdType
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
getPackFn StdType
U08Ty  = (Lexeme Text
 -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
forall a. a -> Maybe a
Just (Text
-> Lexeme Text
-> Lexeme Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
mkPackBinStr Text
"bin_pack_bin")
getPackFn StdType
CharTy = (Lexeme Text
 -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
forall a. a -> Maybe a
Just (Text
-> Lexeme Text
-> Lexeme Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
mkPackBinStr Text
"bin_pack_str")
getPackFn StdType
_      = Maybe
  (Lexeme Text
   -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
forall a. Maybe a
Nothing

mkPackMember :: Lexeme Text -> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember :: Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName (Lexeme Text
memName, TypeInfo
ty) = case TypeInfo
ty of
    Owner TypeInfo
t    -> Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName (Lexeme Text
memName, TypeInfo
t)
    Nonnull TypeInfo
t  -> Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName (Lexeme Text
memName, TypeInfo
t)
    Nullable TypeInfo
t -> Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName (Lexeme Text
memName, TypeInfo
t)
    Const TypeInfo
t    -> Lexeme Text
-> (Lexeme Text, TypeInfo) -> Maybe (Node (Lexeme Text))
mkPackMember Lexeme Text
varName (Lexeme Text
memName, TypeInfo
t)

    Sized TypeInfo
t Lexeme Text
arrSize -> do
        Lexeme Text
-> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
packFn <- case TypeInfo -> TypeInfo
stripWrappers TypeInfo
t of
            Pointer (BuiltinType StdType
std)        -> StdType
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
getPackFn StdType
std
            Array (Just (BuiltinType StdType
std)) [TypeInfo]
_ -> StdType
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
getPackFn StdType
std
            TypeInfo
_                                -> Maybe
  (Lexeme Text
   -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
forall a. Maybe a
Nothing
        Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$ Lexeme Text
-> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
packFn Lexeme Text
varName Lexeme Text
memName (Node (Lexeme Text) -> Node (Lexeme Text))
-> Node (Lexeme Text) -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> lexeme -> NodeF lexeme a
PointerAccess (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
varName)) Lexeme Text
arrSize)

    Array (Just (BuiltinType StdType
std)) [NameLit Lexeme Text
arrSize] -> do
        Lexeme Text
-> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
packFn <- StdType
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
getPackFn StdType
std
        Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$ Lexeme Text
-> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
packFn Lexeme Text
varName Lexeme Text
memName (Node (Lexeme Text) -> Node (Lexeme Text))
-> Node (Lexeme Text) -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (LiteralType
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. LiteralType -> lexeme -> NodeF lexeme a
LiteralExpr LiteralType
ConstId Lexeme Text
arrSize)

    Array (Just (BuiltinType StdType
std)) [IntLit Lexeme Text
arrSize] -> do
        Lexeme Text
-> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
packFn <- StdType
-> Maybe
     (Lexeme Text
      -> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text))
getPackFn StdType
std
        Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$ Lexeme Text
-> Lexeme Text -> Node (Lexeme Text) -> Node (Lexeme Text)
packFn Lexeme Text
varName Lexeme Text
memName (Node (Lexeme Text) -> Node (Lexeme Text))
-> Node (Lexeme Text) -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (LiteralType
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. LiteralType -> lexeme -> NodeF lexeme a
LiteralExpr LiteralType
Int Lexeme Text
arrSize)

    TypeInfo
_ -> do
        Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
funName <- TypeInfo
-> Maybe
     (Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text))
packFunName TypeInfo
ty
        Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$ case Either Text (Node (Lexeme Text) -> Node (Lexeme Text), Text)
funName of
            Left Text
fun ->
                NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> [Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> [a] -> NodeF lexeme a
FunctionCall (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
memName LexemeClass
IdVar Text
fun)))
                    [ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
memName LexemeClass
IdVar Text
"bp"))
                    , NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> lexeme -> NodeF lexeme a
PointerAccess (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
varName)) Lexeme Text
memName)
                    ])
            Right (Node (Lexeme Text) -> Node (Lexeme Text)
prefix, Text
fun) ->
                NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> [Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> [a] -> NodeF lexeme a
FunctionCall (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
memName LexemeClass
IdVar Text
fun)))
                    [ Node (Lexeme Text) -> Node (Lexeme Text)
prefix (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> lexeme -> NodeF lexeme a
PointerAccess (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
varName)) Lexeme Text
memName))
                    , NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
memName LexemeClass
IdVar Text
"bp"))
                    ])

analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse :: [([Char], [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse = Text
-> MkFunBody
-> [([Char], [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
analyseStructs Text
funSuffix MkFunBody
mkFunBody

descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos], (Text, Text))
descr :: ([([Char], [Node (Lexeme Text)])] -> [Diagnostic CimplePos],
 (Text, Text))
descr = ([([Char], [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse, (Text
"struct-pack", [Text] -> Text
Text.unlines
    [ Text
"Checks that `_pack` functions for `struct`s are complete and correct."
    , Text
""
    , Text
"**Reason:** we provide `pack` functions for `struct` but don't want to"
    , Text
"manually maintain them. This linter checks that the function is exactly what"
    , Text
"we want it to be, and the error message will say what the function should look"
    , Text
"like."
    ]))