c-struct 0.1.1.1 → 0.1.1.2
raw patch · 3 files changed
+82/−26 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- c-struct.cabal +1/−1
- src/Foreign/C/Struct.hs +43/−23
- src/Foreign/C/Struct/Parts.hs +38/−2
c-struct.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: c-struct-version: 0.1.1.1+version: 0.1.1.2 synopsis: To make a wrapper for struct of C language description: Please see the README on GitHub at <https://github.com/YoshikuniJujo/c-struct#readme> category: Foreign
src/Foreign/C/Struct.hs view
@@ -19,7 +19,8 @@ ExpQ, varE, conE, appE, infixE, lamE, tupE, listE, litE, integerL, forallT, varT, conT, appT, varP, wildP, conP, tupP, viewP, Name, mkName, newName,- ClauseQ, clause, normalB, StmtQ, doE, compE, bindS, noBindS )+ ClauseQ, clause, normalB, StmtQ, doE, compE, bindS, noBindS,+ lookupTypeName, lookupValueName ) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Concurrent (newForeignPtr) import Foreign.Marshal (malloc, mallocBytes, free, copyBytes)@@ -28,7 +29,7 @@ import Control.Monad (replicateM) import Control.Monad.Primitive (PrimMonad(..), RealWorld, unsafeIOToPrim) import Data.Bool (bool)-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, isJust, fromJust) import Data.List (unzip4, intersperse, intercalate) import Data.Array (Ix(..)) import System.IO.Unsafe (unsafePerformIO)@@ -37,7 +38,8 @@ import Foreign.C.Struct.Parts ( (.->), (.$), (...), (.<$>), (.<*>), (.>>=), (.&&), (.||), (.==), (.<), (.+), (.*),- tupleE, tupT, tupP', intE, strP, pt, zp, ss, (..+), toLabel, lcfirst )+ intE, strP, pt, zp, ss, (..+), toLabel, lcfirst,+ bigTupleData, sbTupP, sbTupT, sbTupleE ) --------------------------------------------------------------------------- @@ -70,15 +72,33 @@ struct :: StrName -> StrSize -> StrAlgn -> [(MemName, MemType, MemPeek, MemPoke)] -> [DerivClass] -> DecsQ-struct sn sz algn (unzip4 -> (mns, mts, mpes, mpos)) dcs_ = (++)- <$> sequence [- mkNewtype sn,- pure . PragmaD $ CompleteP [mkName sn] Nothing,- mkPatternSig sn mts, mkPatternBody sn sz mns mpos,- mkPatternFunSig sn mts, mkPatternFunBody sn mpes ]- <*> mkInstances sn sz algn mns dcs- where dcs = case toDerivCollection dcs_ of+struct sn sz algn (unzip4 -> (mns, mts, mpes, mpos)) dcs_ = do+ mtpl <- if ln > 62+ then do nm <- lookupTypeName tplnm+ nm' <- lookupValueName tplnm+ if isJust nm && isJust nm'+ then pure $ Just (fromJust nm, fromJust nm')+ else Just <$> ((,) <$> newName tplnm <*> newName tplnm)+ else pure Nothing+ (\mtd dt ist -> maybe id (:) mtd $ dt ++ ist)+ <$> do b <- isJust <$> lookupTypeName tplnm+ if b+ then pure Nothing+ else maybe (pure Nothing)+ (\(tpl, tpl') -> Just <$> bigTupleData tpl tpl' ln) mtpl+ <*> sequence [+ mkNewtype sn,+ pure . PragmaD $ CompleteP [mkName sn] Nothing,+ mkPatternSig sn mts,+ mkPatternBody mtpl sn sz mns mpos,+ mkPatternFunSig mtpl sn mts,+ mkPatternFunBody mtpl sn mpes ]+ <*> mkInstances sn sz algn mns dcs+ where+ dcs = case toDerivCollection dcs_ of (d, []) -> d; (_, os) -> error $ "Can't derive: " ++ show os+ ln = length mns+ tplnm = "Tuple" ++ show ln -- ^ -- Example@@ -111,10 +131,10 @@ mkPatternSig :: StrName -> [MemType] -> DecQ mkPatternSig (mkName -> sn) = patSynSigD sn . foldr (.->) (conT sn) . (conT <$>) -mkPatternBody :: StrName -> StrSize -> [MemName] -> [MemPoke] -> DecQ-mkPatternBody sn sz ms_ pos = patSynD (mkName sn) (recordPatSyn ms)+mkPatternBody :: Maybe (Name, Name) -> StrName -> StrSize -> [MemName] -> [MemPoke] -> DecQ+mkPatternBody mtpl sn sz ms_ pos = patSynD (mkName sn) (recordPatSyn ms) (explBidir [mkPatternBodyClause sn sz pos])- (viewP (varE . mkName $ lcfirst sn) (tupP' $ varP <$> ms))+ (viewP (varE . mkName $ lcfirst sn) (sbTupP mtpl $ varP <$> ms)) where ms = mkName . toLabel sn <$> ms_ mkPatternBodyClause :: StrName -> StrSize -> [MemPoke] -> ClauseQ@@ -129,21 +149,21 @@ -- Function Mk Pattern Fun -mkPatternFunSig :: StrName -> [MemType] -> DecQ-mkPatternFunSig (mkName . lcfirst &&& conT . mkName -> (fn, st)) =- sigD fn . (st .->) . tupT . (conT <$>)+mkPatternFunSig :: Maybe (Name, Name) -> StrName -> [MemType] -> DecQ+mkPatternFunSig mtpl (mkName . lcfirst &&& conT . mkName -> (fn, st)) =+ sigD fn . (st .->) . sbTupT mtpl . (conT <$>) -mkPatternFunBody :: StrName -> [MemPeek] -> DecQ-mkPatternFunBody (mkName . lcfirst &&& mkName . (++ "_") -> (fn, cn)) pes =+mkPatternFunBody :: Maybe (Name, Name) -> StrName -> [MemPeek] -> DecQ+mkPatternFunBody mtpl (mkName . lcfirst &&& mkName . (++ "_") -> (fn, cn)) pes = funD fn . (: []) $ (,) <$> newName "f" <*> newName "p" >>= \(f, p) -> clause [conP cn [varP f]] (normalB $ varE 'unsafePerformIO .$ varE 'withForeignPtr `appE` varE f `appE` lamE [bool (varP p) wildP $ null pes]- (mkPatternFunPeeks p pes)) []+ (mkPatternFunPeeks mtpl p pes)) [] -mkPatternFunPeeks :: Name -> [MemPeek] -> ExpQ-mkPatternFunPeeks (varE -> p) (length &&& id -> (n, pes)) =- foldl (.<*>) (varE 'pure .$ tupleE n) $ (`appE` p) <$> pes+mkPatternFunPeeks :: Maybe (Name, Name) -> Name -> [MemPeek] -> ExpQ+mkPatternFunPeeks mtpl (varE -> p) (length &&& id -> (n, pes)) =+ foldl (.<*>) (varE 'pure .$ sbTupleE mtpl n) $ (`appE` p) <$> pes -- DERIVING
src/Foreign/C/Struct/Parts.hs view
@@ -6,11 +6,17 @@ tupleE, tupT, tupP', intE, strP, (.->), pt, (.$), (...), (.<$>), (.<*>), (.>>=), (.&&), (.||), (.==), (.<), (.+), (.*), zp, ss, (..+),- toLabel, lcfirst ) where+ toLabel, lcfirst, + bigTupleData, bigTupleE, bigTupT, bigTupP,+ sbTupleE, sbTupT, sbTupP ) where+ import Language.Haskell.TH ( ExpQ, Exp(TupE), varE, litE, infixE, TypeQ, appT, arrowT, tupleT,- PatQ, litP, tupP, Name, integerL, stringL )+ PatQ, litP, tupP, Name, integerL, stringL,+ varT, mkName,+ dataD, cxt, bangType, bang, noSourceUnpackedness, noSourceStrictness,+ plainTV, normalC, DecQ, conE, conT, conP ) import Data.Char (toLower, toUpper) ---------------------------------------------------------------------------@@ -46,6 +52,36 @@ strP :: String -> PatQ strP = litP . stringL++sbTupleE :: Maybe (Name, Name) -> Int -> ExpQ+sbTupleE mnm nb = maybe (tupleE nb) (\(_, tpl') -> bigTupleE tpl') mnm++sbTupT :: Maybe (Name, Name) -> [TypeQ] -> TypeQ+sbTupT = maybe tupT (\(tpl, _) ->bigTupT tpl)++sbTupP :: Maybe (Name, Name) -> [PatQ] -> PatQ+sbTupP = maybe tupP' (\(_, tpl') -> bigTupP tpl')++bigTupleData :: Name -> Name -> Int -> DecQ+bigTupleData nm nm' nb = dataD (cxt []) nm+ (plainTV . mkName <$> as)+ Nothing+ [normalC nm'+ $ bangType (bang noSourceUnpackedness noSourceStrictness)+ . varT . mkName <$> as] []+ where as = take nb abc++abc :: [String]+abc = ((: []) <$> ['a' .. 'z']) ++ [ as ++ [a] | as <- abc, a <- ['a' .. 'z'] ]++bigTupleE :: Name -> ExpQ+bigTupleE = conE++bigTupT :: Name -> [TypeQ] -> TypeQ+bigTupT nm = foldl appT (conT nm)++bigTupP :: Name -> [PatQ] -> PatQ+bigTupP = conP -- OPERATOR