packages feed

c-struct (empty) → 0.1.0.0

raw patch · 8 files changed

+819/−0 lines, 8 filesdep +arraydep +basedep +c-structsetup-changed

Dependencies added: array, base, c-struct, primitive, template-haskell

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for c-struct++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yoshikuni Jujo nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,208 @@+# c-struct++## C definition++foo.h++```+#ifndef _FOO_H+#define _FOO_H++typedef struct { int x; int y; } Foo;++#endif+```++foo.c++```+#include <stdlib.h>+#include <stdio.h>+#include "foo.h"++Foo *+foo_copy(Foo *src)+{+	Foo *p = malloc(sizeof(Foo));+	p -> x = src -> x;+	p -> y = src -> y;+	return p;+}++void+foo_free(Foo *p)+{+	free(p);+}++void+foo_print(Foo *f)+{+	printf("Foo: x = %d, y = %d\n", f -> x, f -> y);+}++void+foo_scale(Foo *f, int s)+{+	f -> x = f -> x * s;+	f -> y = f -> y * s;+}+```++## Immutable++### Foo++Foo.hsc++```+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foo where++import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Storable (peekByteOff, pokeByteOff)+import Foreign.C.Types (CInt(..))+import Foreign.C.Struct (struct)++#include "foo.h"++struct "Foo" #{size Foo}+	[	("x", ''CInt, [| #{peek Foo, x} |], [| #{poke Foo, x} |]),+		("y", ''CInt, [| #{peek Foo, y} |], [| #{poke Foo, y} |]) ]+	[''Show, ''Read, ''Eq, ''Ord, ''Bounded]++fooPrint :: Foo -> IO ()+fooPrint (Foo_ f) = withForeignPtr f c_foo_print++foreign import ccall "foo_print" c_foo_print :: Ptr Foo -> IO ()+```++You get newtype Foo.++```+> Foo 123 456+Foo {fooX = 123, fooY = 456}+> it { fooY = 654}+Foo {fooX = 123, fooY = 654}+> f = it+> fooPrint f+Foo: x = 123, y = 654+> g = read "Foo {fooX = 456, fooY = 123}" :: Foo+> g+Foo {fooX = 456, fooY = 123}+> f < g+True+> minBound :: Foo+Foo {fooX = -2147483648, fooY = -2147483648}+```++### FooIx++FooIx.hsc++```+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module FooIx where++import Foreign.Storable (Storable, peekByteOff, pokeByteOff)+import Foreign.C.Types (CInt(..))+import Foreign.C.Struct (struct)+import Data.Array (Ix(..))++#include "foo.h"++newtype CIntIx = CIntIx CInt+	deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Storable)++struct "FooIx" #{size Foo}+	[	("x", ''CIntIx, [| #{peek Foo, x} |], [| #{poke Foo, x} |]),+		("y", ''CIntIx, [| #{peek Foo, y} |], [| #{poke Foo, y} |]) ]+	[''Show, ''Eq, ''Ord, ''Ix]++instance Ix CIntIx where+	range (l, u) = [l .. u]+	index (l, _) i = fromIntegral $ i - l+	inRange (l, u) i = l <= i && i <= u+```++You get newtype FooIx.++```+> :module + Data.Array+> listArray (FooIx 3 5, FooIx 4 7) [5 ..]+array (FooIx {fooIxX = CIntIx 3, fooIxY = CIntIx 5},FooIx {fooIxX = CIntIx 4, fooIxY = CIntIx 7}) [(FooIx {...+> a = it+> a ! FooIx 4 6+9+```++## Mutable++If you want to change values of a struct, you should use `structPrim`.++FooPrim.hsc++```+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module FooPrim where++import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Storable (peekByteOff, pokeByteOff)+import Foreign.C.Types (CInt(..))+import Foreign.C.Struct (struct, structPrim)+import Control.Monad.Primitive (PrimMonad(..), unsafeIOToPrim)++#include "foo.h"++struct "Foo" #{size Foo}+	[	("x", ''CInt, [| #{peek Foo, x} |], [| #{poke Foo, x} |]),+		("y", ''CInt, [| #{peek Foo, y} |], [| #{poke Foo, y} |]) ]+	[''Show, ''Read, ''Eq, ''Ord, ''Bounded]++foreign import ccall "foo_copy" c_foo_copy :: Ptr Foo -> IO (Ptr Foo)+foreign import ccall "foo_free" c_foo_free :: Ptr Foo -> IO ()++structPrim "Foo" 'c_foo_copy 'c_foo_free [''Show]++fooScale :: PtimMonad m => FooPrim (PrimState m) -> CInt -> m ()+fooScale (FooPrim f) s = unsafeIOToPrim $ withForeignPtr f (`c_foo_scale` s)++foreign import ccall "foo_scale" c_foo_scale :: Ptr Foo -> CInt -> IO ()+```++You get `FooPrim`, `FooST`, `FooIO`, `fooFreeze`, `fooThaw` and `fooCopy`.++```+> :modu	+ Control.Monad.Primitive+> :type fooFreeze+fooFreeze :: PrimMonad m => FooPrim (PrimState m) -> m Foo+> :type fooThaw+fooThaw :: PrimMonad m => Foo -> m (FooPrim (PrimState m))+> :type FooCopy+fooCopy+  :: PrimMonad m =>+     FooPrim (PrimState m) -> m (FooPrim (PrimState m))+> Foo 123 456+Foo {fooX = 123, fooY = 456}+> fooThaw it+FooPrim 0x00000000002354a60+> fp = it+> fooScale fp 3+> fooFreeze fp+Foo {fooX = 369, fooY = 1368}+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ c-struct.cabal view
@@ -0,0 +1,57 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           c-struct+version:        0.1.0.0+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+homepage:       https://github.com/YoshikuniJujo/c-struct#readme+bug-reports:    https://github.com/YoshikuniJujo/c-struct/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo.pc@gmail.com+copyright:      2021 Yoshikuni Jujo+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/c-struct++library+  exposed-modules:+      Foreign.C.Struct+  other-modules:+      Foreign.C.Struct.Parts+      Paths_c_struct+  hs-source-dirs:+      src+  build-depends:+      array+    , base >=4.7 && <5+    , primitive+    , template-haskell+  default-language: Haskell2010++test-suite c-struct-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_c_struct+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      array+    , base >=4.7 && <5+    , c-struct+    , primitive+    , template-haskell+  default-language: Haskell2010
+ src/Foreign/C/Struct.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.C.Struct (+	-- * STRUCT+	struct, StrName, StrSize,+	MemName, MemType, MemPeek, MemPoke, DerivClass,+	-- * STRUCT WITH PRIMITIVE MONAD+	structPrim, FunCopy, FunFree ) where++import Language.Haskell.TH (+	DecsQ, DecQ, Dec(PragmaD), Pragma(CompleteP), sigD, valD, funD, tySynD,+	newtypeD, plainTV, normalC, derivClause,+		bangType, bang, noSourceUnpackedness, noSourceStrictness,+	instanceD, cxt,+	patSynSigD, patSynD, recordPatSyn, explBidir,+	ExpQ, varE, conE, appE, lamE, tupE, listE,+	forallT, varT, conT, appT, varP, wildP, conP, tupP, viewP,+	Name, mkName, newName,+	ClauseQ, clause, normalB, StmtQ, doE, compE, bindS, noBindS )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Concurrent (newForeignPtr)+import Foreign.Marshal (mallocBytes, free)+import Control.Arrow ((&&&))+import Control.Monad (replicateM)+import Control.Monad.Primitive (PrimMonad(..), RealWorld, unsafeIOToPrim)+import Data.Bool (bool)+import Data.Maybe (mapMaybe)+import Data.List (unzip4, intersperse, intercalate)+import Data.Array (Ix(..))+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (Lexeme(..), readPrec, step, lexP, parens, prec)++import Foreign.C.Struct.Parts (+	(.->), (.$), (...), (.<$>), (.<*>), (.>>=),+	(.&&), (.||), (.==), (.<), (.+), (.*),+	tupleE, tupT, tupP', intE, strP, pt, zp, ss, (..+), toLabel, lcfirst )++---------------------------------------------------------------------------++-- * STRUCT+--	+ FUNCTION STRUCT+--	+ NEWTYPE+--	+ PATTERN+--		- Function Mk Pattern+--		- Function Mk Pattern Fun+--	+ DERIVING+--		- Function Mk Deriving+--		- Show+--		- Read+--		- Eq+--		- Ord+--		- Bounded+--		- Ix+-- * STRUCT WITH PRIMITIVE MONAD+-- 	+ FUNCTION STRUCT PRIM+-- 	+ NEWTYPE+-- 	+ FREEZE+-- 	+ THAW+-- 	+ COPY++---------------------------------------------------------------------------+-- STRUCT+---------------------------------------------------------------------------++-- FUNCTION STRUCT++struct :: StrName -> StrSize ->+	[(MemName, MemType, MemPeek, MemPoke)] -> [DerivClass] -> DecsQ+struct sn sz (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 mns dcs+	where dcs = case toDerivCollection dcs_ of+		(d, []) -> d; (_, os) -> error $ "Can't derive: " ++ show os++-- ^+-- Example+--+-- @+-- struct "Foo" ${size Foo}+--	[	("x", ''CInt, [| #{peek Foo, x} |], [| #{poke Foo, x} |]),+--		("y", ''CInt, [| #{peek Foo, y} |], [| #{poke Foo, y} |]) ]+--	[''Show, ''Read, ''Eq, ''Ord, ''Bounded]+-- @++type StrName = String; type StrSize = Integer+type MemName = String; type MemType = Name+type MemPeek = ExpQ; type MemPoke = ExpQ+type DerivClass = Name++-- NEWTYPE++mkNewtype :: StrName -> DecQ+mkNewtype sn =+	newtypeD (cxt []) (mkName sn) [] Nothing (normalC (mkName $ sn ++ "_") [+		bangType+			(bang noSourceUnpackedness noSourceStrictness)+			(conT ''ForeignPtr `appT` conT (mkName sn)) ]) []++-- PATTERN++-- Function Mk Pattern++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)+	(explBidir [mkPatternBodyClause sn sz pos])+	(viewP (varE . mkName $ lcfirst sn) (tupP' $ varP <$> ms))+	where ms = mkName . toLabel sn <$> ms_++mkPatternBodyClause :: StrName -> StrSize -> [MemPoke] -> ClauseQ+mkPatternBodyClause (mkName . (++ "_") -> sn) sz pos = do+	(vs, p) <- (,) <$> length pos `replicateM` newName "v" <*> newName "p"+	let	vps = varP <$> vs; pe = varE p; fr = varE 'free `appE` pe+	clause vps (normalB $ varE 'unsafePerformIO .$ conE sn .<$> doE (+		(varP p `bindS` (varE 'mallocBytes `appE` intE sz)) :+		((<$> zip pos vs) \(po, v) ->+			noBindS $ po `appE` pe `appE` varE v) +++		[noBindS $ varE 'newForeignPtr `appE` pe `appE` fr] )) []++-- Function Mk Pattern Fun++mkPatternFunSig :: StrName -> [MemType] -> DecQ+mkPatternFunSig (mkName . lcfirst &&& conT . mkName -> (fn, st)) =+	sigD fn . (st .->) . tupT . (conT <$>)++mkPatternFunBody :: StrName -> [MemPeek] -> DecQ+mkPatternFunBody (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 :: Name -> [MemPeek] -> ExpQ+mkPatternFunPeeks (varE -> p) (length &&& id -> (n, pes)) =+	foldl (.<*>) (varE 'pure .$ tupleE n) $ (`appE` p) <$> pes++-- DERIVING++-- Function Mk Deriving++mkInstances :: StrName -> [MemName] -> DerivCollection -> DecsQ+mkInstances sn ms dc =+	sequence $ (\(t, b) -> bool Nothing (Just t) b) `mapMaybe` zip [+		mkInstanceShow sn ms, mkInstanceRead sn ms, mkInstanceEq sn ms,+		mkInstanceOrd sn ms, mkInstanceBounded sn ms, mkInstanceIx sn ms+		] [	derivingShow dc, derivingRead dc, derivingEq dc,+			derivingOrd dc, derivingBounded dc, derivingIx dc ]++data DerivCollection = DerivCollection {+	derivingShow :: Bool, derivingRead :: Bool,+	derivingEq :: Bool, derivingOrd :: Bool,+	derivingBounded :: Bool, derivingIx :: Bool } deriving Show++toDerivCollection :: [DerivClass] -> (DerivCollection, [DerivClass])+toDerivCollection [] = (DerivCollection False False False False False False, [])+toDerivCollection (d : ds) = case d of+	NameShow -> (dc { derivingShow = True }, ds')+	NameRead -> (dc { derivingRead = True }, ds')+	NameEq -> (dc { derivingEq = True }, ds')+	NameOrd -> (dc { derivingOrd = True }, ds')+	NameBounded -> (dc { derivingBounded = True }, ds')+	NameIx -> (dc {derivingIx = True }, ds')+	_ -> (dc, d : ds')+	where (dc, ds') = toDerivCollection ds++pattern NameShow, NameRead, NameEq, NameOrd, NameBounded, NameIx :: Name+pattern NameShow <- ((== ''Show) -> True)+pattern NameRead <- ((== ''Read) -> True)+pattern NameEq <- ((== ''Eq) -> True)+pattern NameOrd <- ((== ''Ord) -> True)+pattern NameBounded <- ((== ''Bounded) -> True)+pattern NameIx <- ((== ''Ix) -> True)++-- Show++mkInstanceShow :: StrName -> [MemName] -> DecQ+mkInstanceShow (mkName &&& id -> (sn, ssn)) ms = do+	(s, vs) <- (,) <$> newName "s" <*> length ms `replicateM` newName "v"+	instanceD (cxt []) (conT ''Show `appT` conT sn) . (: [])+		$ funD 'showsPrec [clause [wildP, varP s]+			(normalB $ ss (ssn ++ " {") ...+				mkShowMems ssn ms vs ... ss "}")+			[valD (conP sn $ varP <$> vs) (normalB $ varE s) []]]++mkShowMems :: StrName -> [MemName] -> [Name] -> ExpQ+mkShowMems (toLabel -> l) ms vs = foldr (...) (varE 'id) . intersperse (ss ", ")+	$ (<$> zip ms vs) \(m, v) ->+		l m ..+ " = " ... varE 'showsPrec `appE` intE 0 `appE` varE v++-- Read++mkInstanceRead :: StrName -> [MemName] -> DecQ+mkInstanceRead sn ms = length ms `replicateM` newName "v" >>= \vs ->+	instanceD (cxt []) (conT ''Read `appT` t) . (: [])+		$ valD (varP 'readPrec) (normalB $ varE 'parens+			.$ varE 'prec `appE` intE 10 `appE` doE ([+				conP 'Ident [strP sn] `bindS` varE 'lexP,+				conP 'Punc [strP "{"] `bindS` varE 'lexP ] +++				mkReadMems sn ms vs ++ [+				conP 'Punc [strP "}"] `bindS` varE 'lexP,+				noBindS $ varE 'pure+					.$ foldl appE c (varE <$> vs) ])) []+	where t = conT $ mkName sn; c = conE $ mkName sn++mkReadMems :: StrName -> [MemName] -> [Name] -> [StmtQ]+mkReadMems sn ms vs =+	intercalate [conP 'Punc [strP ","] `bindS` varE 'lexP]+		$ (<$> zip ms vs) \(m, v) -> [+			conP 'Ident [strP $ toLabel sn m] `bindS` varE 'lexP,+			conP 'Punc [strP "="] `bindS` varE 'lexP,+			varP v `bindS` (varE 'step `appE` varE 'readPrec) ]++-- Eq++mkInstanceEq :: StrName -> [MemName] -> DecQ+mkInstanceEq sn ms = (,) <$> newName "s" <*> newName "t" >>= \(s, t) ->+	instanceD (cxt []) (conT ''Eq `appT` conT (mkName sn)) . (: [])+		. funD '(==) . (: []) $ clause [varP s, varP t] (normalB+			$ foldl (.&&) (conE 'True) $ mkMemEq sn s t <$> ms) []++mkMemEq :: StrName -> Name -> Name -> MemName -> ExpQ+mkMemEq sn (varE -> s) (varE -> t) m = let l = varE . mkName $ toLabel sn m in+	l `appE` s .== l `appE` t++-- Ord++mkInstanceOrd :: StrName -> [MemName] -> DecQ+mkInstanceOrd sn ms = (,) <$> newName "s" <*> newName "t" >>= \(s, t) ->+	instanceD (cxt []) (conT ''Ord `appT` conT (mkName sn)) . (: [])+		. funD '(<=) . (: []) $ clause [varP s, varP t] (+			normalB $ varE 'foldr `appE` lamOrd s t `appE`+				conE 'True `appE` listE ln ) []+	where ln = varE . mkName . toLabel sn <$> ms++lamOrd :: Name -> Name -> ExpQ+lamOrd (varE -> s) (varE -> t) =+	(,) <$> newName "x" <*> newName "v" >>= \(x, v) -> let xe = varE x in+		lamE [varP x, varP v] $ xe `appE` s .< xe `appE` t .||+			xe `appE` s .== xe `appE` t .&& varE v++-- Bounded++mkInstanceBounded :: StrName -> [MemName] -> DecQ+mkInstanceBounded (mkName -> sn) (length -> n) =+	instanceD (cxt []) (conT ''Bounded `appT` conT sn) [+		valD (varP 'minBound) (normalB $ foldl appE (conE sn)+			(replicate n $ varE 'minBound)) [],+		valD (varP 'maxBound) (normalB $ foldl appE (conE sn)+			(replicate n $ varE 'maxBound)) [] ]++-- Ix++mkInstanceIx :: StrName -> [MemName] -> DecQ+mkInstanceIx (mkName -> sn) ms = instanceD (cxt []) (conT ''Ix `appT` conT sn) [+	mkRange 'range sn ms, mkIndex 'index sn ms, mkInRange 'inRange sn ms ]++mkRange :: Name -> Name -> [MemName] -> DecQ+mkRange fn sn (length -> n) = do+	(vs, ws, is) <- unzip3 <$> n `replicateM`+		((,,) <$> newName "v" <*> newName "w" <*> newName "i")+	funD fn . (: []) $ clause+		[tupP [conP sn $ varP <$> vs, conP sn $ varP <$> ws]]+		(normalB . compE . (++ [noBindS . foldl appE sne $ varE <$> is])+			$ (<$> is `zip` (vs `zip` ws)) \(i, (v, w)) ->+				bindS (varP i) $ rg `appE` tupE [varE v, varE w]+			) []+	where rg = varE 'range; sne = conE sn++mkIndex :: Name -> Name -> [MemName] -> DecQ+mkIndex fn (conP -> sn) (length -> n) = do+	(vs, ws, is) <- unzip3 <$> n `replicateM`+		((,,) <$> newName "v" <*> newName "w" <*> newName "i")+	funD fn . (: []) $ clause+		[tupP [sn $ varP <$> vs, sn $ varP <$> ws], sn $ varP <$> is]+		(normalB $ varE 'foldl `appE` mkIndexLam `appE` intE 0+			.$ listE (varE <$> vs) `zp` listE (varE <$> ws) `zp`+				listE (varE <$> is)) []++mkIndexLam :: ExpQ+mkIndexLam =+	(,,) <$> newName "v" <*> newName "z" <*> newName "k" >>= \(v, z, k) ->+		lamE [varP v, tupP [varP z, varP k]]+			$ (varE 'index `appE` varE z `appE` varE k) .++				(varE 'rangeSize `appE` varE z .* varE v)++mkInRange :: Name -> Name -> [MemName] -> DecQ+mkInRange fn (conP -> sn) (length -> n) = do+	(vs, ws, is) <- unzip3 <$> n `replicateM`+		((,,) <$> newName "v" <*> newName "w" <*> newName "i")+	funD fn . (: []) $ clause+		[tupP [sn $ varP <$> vs, sn $ varP <$> ws], sn $ varP <$> is]+		(normalB . foldr (.&&) (conE 'True) $+			(<$> vs `zip` ws `zip` is) \((v, w), i) ->+				ir `appE` tupE [varE v, varE w] `appE` varE i+			) []+	where ir = varE 'inRange++---------------------------------------------------------------------------+-- STRUCT WITH PRIMITIVE MONAD+---------------------------------------------------------------------------++-- FUNCTION STRUCT PRIM++structPrim :: StrName -> FunCopy -> FunFree -> [DerivClass] -> DecsQ+structPrim nt cp fr ds = sequence [+	mkNewtypePrim nt ds, mkTypeST nt, mkTypeIO nt,+	mkFreezeSig nt, mkFreezeFun nt cp fr, mkThawSig nt, mkThawFun nt cp fr,+	mkCopySig nt, mkCopyFun nt cp fr ]++-- ^+-- Example+--+-- @+-- foreign import ccall "foo_copy" c_foo_copy :: Ptr Foo -> IO (Ptr Foo)+-- foreign import ccall "foo_free" c_foo_free :: Ptr Foo -> IO ()+--+-- structPrim "Foo" 'c_foo_copy 'c_foo_free [''Show]+-- @++type FunCopy = Name; type FunFree = Name++-- NEWTYPE AND TYPE SYNONYM++mkNewtypePrim :: StrName -> [DerivClass] -> DecQ+mkNewtypePrim sn ds = newName "s" >>= \s ->+	newtypeD (cxt []) snp [plainTV s] Nothing+		(normalC snp . (: []) $ bangType+			(bang noSourceUnpackedness noSourceStrictness)+			(conT ''ForeignPtr `appT` conT (mkName sn)))+		[derivClause Nothing $ conT <$> ds]+	where snp = mkName $ sn ++ "Prim"++mkTypeIO :: StrName -> DecQ+mkTypeIO sn = tySynD (mkName $ sn ++ "IO") []+	$ conT (mkName $ sn ++ "Prim") `appT` conT ''RealWorld++mkTypeST :: StrName -> DecQ+mkTypeST sn = tySynD (mkName $ sn ++ "ST") [] . conT . mkName $ sn ++ "Prim"++-- FREEZE++mkFreezeSig :: StrName -> DecQ+mkFreezeSig sn = newName "m" >>= \m ->+	sigD fn . forallT [] (cxt [conT ''PrimMonad `appT` varT m])+		$ conT snp `appT` (conT ''PrimState `appT` varT m) .->+			varT m `appT` conT (mkName sn)+	where fn = mkName $ lcfirst sn ++ "Freeze"; snp = mkName $ sn ++ "Prim"++mkFreezeFun :: StrName -> FunCopy -> FunFree -> DecQ+mkFreezeFun sn cp fr = newName "fp" >>= \fp ->+	funD (mkName $ lcfirst sn ++ "Freeze") . (: []) $+		clause [conP (mkName $ sn ++ "Prim") [varP fp]] (normalB+			$ mkFreezeBody sn cp fr fp) []++mkFreezeBody :: StrName -> FunCopy -> FunFree -> Name -> ExpQ+mkFreezeBody sn cp fr fp =+	varE 'unsafeIOToPrim ... conE (mkName $ sn ++ "_") `pt` varE '(<$>)+		.$ varE 'withForeignPtr `appE` varE fp `appE` varE cp+			.>>= varE 'newForeignPtr .<$> varE 'id .<*> varE fr++-- THAW++mkThawSig :: StrName -> DecQ+mkThawSig sn = newName "m" >>= \m ->+	sigD fn . forallT [] (cxt [conT ''PrimMonad `appT` varT m])+		$ conT (mkName sn) .-> varT m `appT`+			(conT snp `appT` (conT ''PrimState `appT` varT m))+	where fn = mkName $ lcfirst sn ++ "Thaw"; snp = mkName $ sn ++ "Prim"++mkThawFun :: StrName -> FunCopy -> FunFree -> DecQ+mkThawFun sn cp fr = newName "fp" >>= \fp ->+	funD (mkName $ lcfirst sn ++ "Thaw") . (: [])+		$ clause [conP (mkName $ sn ++ "_") [varP fp]] (+			normalB $ mkThawBody sn cp fr fp) []++mkThawBody :: StrName -> FunCopy -> FunFree -> Name -> ExpQ+mkThawBody sn cp fr fp =+	varE 'unsafeIOToPrim ... conE (mkName $ sn ++ "Prim") `pt` varE '(<$>)+		.$ varE 'withForeignPtr `appE` varE fp `appE` varE cp+			.>>= varE 'newForeignPtr .<$> varE 'id .<*> varE fr++-- COPY++mkCopySig :: StrName -> DecQ+mkCopySig sn = newName "m" >>= \m ->+	sigD fn . forallT [] (cxt [conT ''PrimMonad `appT` varT m])+		$ conT snp `appT` (conT ''PrimState `appT` varT m) .->+			varT m `appT` (conT snp `appT`+				(conT ''PrimState `appT` varT m))+	where fn = mkName $ lcfirst sn ++ "Copy"; snp = mkName $ sn ++ "Prim"++mkCopyFun :: StrName -> FunCopy -> FunFree -> DecQ+mkCopyFun sn cp fr = newName "fp" >>= \fp ->+	funD (mkName $ lcfirst sn ++ "Copy") . (: [])+		$ clause [conP (mkName $ sn ++ "Prim") [varP fp]] (normalB+			$ mkCopyBody sn cp fr fp) []++mkCopyBody :: StrName -> FunCopy -> FunFree -> Name -> ExpQ+mkCopyBody sn cp fr fp =+	varE 'unsafeIOToPrim ... conE (mkName $ sn ++ "Prim") `pt` varE '(<$>)+		.$ varE 'withForeignPtr `appE` varE fp `appE` varE cp+			.>>= varE 'newForeignPtr .<$> varE 'id .<*> varE fr
+ src/Foreign/C/Struct/Parts.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.C.Struct.Parts (+	tupleE, tupT, tupP', intE, strP,+	(.->), pt, (.$), (...), (.<$>), (.<*>), (.>>=),+	(.&&), (.||), (.==), (.<), (.+), (.*), zp, ss, (..+),+	toLabel, lcfirst ) where++import Language.Haskell.TH (+	ExpQ, Exp(TupE), varE, litE, infixE, TypeQ, appT, arrowT, tupleT,+	PatQ, litP, tupP, Name, integerL, stringL )+import Data.Char (toLower, toUpper)++---------------------------------------------------------------------------++-- * TEMPLATE+--	+ TUPLE AND LITERAL+--	+ OPERATOR+--		- Make Operator+--		- TYPE ARROW+--		- FUNCTION APPLICATION+--		- NORMAL OPERATOR+--		- PARTIAL AND ZIP+--	+ SHOW S+-- * CHARACTER++---------------------------------------------------------------------------+-- TEMPLATE+---------------------------------------------------------------------------++-- TUPLE AND LITERAL++tupleE :: Int -> ExpQ+tupleE = \case 1 -> varE 'id; n -> pure . TupE $ n `replicate` Nothing++tupT :: [TypeQ] -> TypeQ+tupT = \case [t] -> t; ts -> foldl appT (tupleT $ length ts) ts++tupP' :: [PatQ] -> PatQ+tupP' = \case [p] -> p; ps -> tupP ps++intE :: Integer -> ExpQ+intE = litE . integerL++strP :: String -> PatQ+strP = litP . stringL++-- OPERATOR++-- Make Operator++mkop :: Name -> ExpQ -> ExpQ -> ExpQ+mkop op e f = infixE (Just e) (varE op) (Just f)++-- Type Arrow And Partial++infixr 0 .->++(.->) :: TypeQ -> TypeQ -> TypeQ+t .-> u = arrowT `appT` t `appT` u++pt :: ExpQ -> ExpQ -> ExpQ+e `pt` op = infixE (Just e) op Nothing++-- Function Application++infixr 0 .$+infixl 1 .>>=+infixl 4 .<$>, .<*>+infixr 8 ...++(.$), (...), (.<$>), (.<*>), (.>>=) :: ExpQ -> ExpQ -> ExpQ+[(.$), (...), (.<$>), (.<*>), (.>>=)] =+	mkop <$> ['($), '(.), '(<$>), '(<*>), '(>>=)]++-- Normal Operator++infixr 2 .||+infixr 3 .&&+infix 4 .==, .<++(.&&), (.||), (.==), (.<), (.+), (.*), zp :: ExpQ -> ExpQ -> ExpQ+[(.&&), (.||), (.==), (.<), (.+), (.*), zp] =+	mkop <$> ['(&&), '(||), '(==), '(<), '(+), '(*), 'zip]++-- SHOW S++ss :: String -> ExpQ+ss s = litE (stringL s) `pt` varE '(++)++(..+) :: String -> String -> ExpQ+s1 ..+ s2 = ss $ s1 ++ s2++---------------------------------------------------------------------------+-- CHARACTER+---------------------------------------------------------------------------++toLabel :: String -> String -> String+toLabel sn = (lcfirst sn ++) . ucfirst++lcfirst, ucfirst :: String -> String+lcfirst = \case "" -> ""; c : cs -> toLower c : cs+ucfirst = \case "" -> ""; c : cs -> toUpper c : cs
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"