haskades 0.1 → 0.1.1
raw patch · 3 files changed
+43/−37 lines, 3 files
Files
- MustacheTemplates.hs +34/−26
- haskades.cabal +1/−1
- haskades.hs +8/−10
MustacheTemplates.hs view
@@ -33,23 +33,23 @@ {-# LINE 37 "HaskadesBinding.hs.mustache" #-} build "\n-- Function pointer wrappers\n", {-# LINE 39 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (slots5 escapeFunction) slots,+ mconcat $ map (slots6 escapeFunction) slots, {-# LINE 42 "HaskadesBinding.hs.mustache" #-} build "\nhaskadesRun :: (MonadIO m) => String -> Slots -> m ()\nhaskadesRun qmlPath (Slots ", {-# LINE 44 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (slots8 escapeFunction) slots,+ mconcat $ map (slots9 escapeFunction) slots, {-# LINE 44 "HaskadesBinding.hs.mustache" #-} build ") = liftIO $ do\n", {-# LINE 45 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (slots9 escapeFunction) slots,+ mconcat $ map (slots10 escapeFunction) slots, {-# LINE 48 "HaskadesBinding.hs.mustache" #-} build "\n\tcode <- ByteString.useAsCString (Text.encodeUtf8 $ Text.pack qmlPath) (\\qmlPath ->\n\t\t\tc_haskades_run qmlPath ", {-# LINE 50 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (slots14 escapeFunction) slots,+ mconcat $ map (slots15 escapeFunction) slots, {-# LINE 51 "HaskadesBinding.hs.mustache" #-} build "\t\t)\n\n", {-# LINE 53 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (slots15 escapeFunction) slots,+ mconcat $ map (slots16 escapeFunction) slots, {-# LINE 56 "HaskadesBinding.hs.mustache" #-} build "\n\twhen (code /= 0) (exitWith $ ExitFailure $ fromIntegral code)\n\treturn ()\n" ]@@ -89,12 +89,12 @@ {-# LINE 32 "HaskadesBinding.hs.mustache" #-} mconcat $ map (sigargs4 escapeFunction) sigargs, {-# LINE 32 "HaskadesBinding.hs.mustache" #-}- build ") = liftIO (\n\t\t(",- {-# LINE 33 "HaskadesBinding.hs.mustache" #-}- build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigcwrap,+ build ") = liftIO (\n\t\t", {-# LINE 33 "HaskadesBinding.hs.mustache" #-}- build ")\n\t\t(c_emit_CustomSignalEvent ",+ if mempty /= sigcwrap then sigcwrap5 escapeFunction ctx else mempty, {-# LINE 34 "HaskadesBinding.hs.mustache" #-}+ build "\t\t(c_emit_CustomSignalEvent ",+ {-# LINE 34 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigevent, {-# LINE 34 "HaskadesBinding.hs.mustache" #-} build ")\n\t)\n"@@ -106,7 +106,15 @@ {-# LINE 32 "HaskadesBinding.hs.mustache" #-} build " " ]- slots5 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ sigcwrap5 escapeFunction ctx@(Signal {signame=signame, sigargs=sigargs, sigevent=sigevent, sigcwrap=sigcwrap}) = mconcat [+ {-# LINE 33 "HaskadesBinding.hs.mustache" #-}+ build "(",+ {-# LINE 33 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigcwrap,+ {-# LINE 33 "HaskadesBinding.hs.mustache" #-}+ build ")"+ ]+ slots6 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build "foreign import ccall \"wrapper\" wrap_", {-# LINE 40 "HaskadesBinding.hs.mustache" #-}@@ -114,7 +122,7 @@ {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build " :: (", {-# LINE 40 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (args6 escapeFunction) args,+ mconcat $ map (args7 escapeFunction) args, {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build " ", {-# LINE 40 "HaskadesBinding.hs.mustache" #-}@@ -122,7 +130,7 @@ {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build ") -> IO (FunPtr (", {-# LINE 40 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (args7 escapeFunction) args,+ mconcat $ map (args8 escapeFunction) args, {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build " ", {-# LINE 40 "HaskadesBinding.hs.mustache" #-}@@ -131,25 +139,25 @@ build "))\n" ] where- args6 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ args7 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [ {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build ctype, {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build " -> " ]- args7 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ args8 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [ {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build ctype, {-# LINE 40 "HaskadesBinding.hs.mustache" #-} build " -> " ]- slots8 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ slots9 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 44 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name, {-# LINE 44 "HaskadesBinding.hs.mustache" #-} build " " ]- slots9 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ slots10 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build "\t", {-# LINE 46 "HaskadesBinding.hs.mustache" #-}@@ -161,11 +169,11 @@ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build " (", {-# LINE 46 "HaskadesBinding.hs.mustache" #-}- if mempty /= (Any hasArgs) then hasArgs10 escapeFunction ctx else mempty,+ if mempty /= (Any hasArgs) then hasArgs11 escapeFunction ctx else mempty, {-# LINE 46 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (args11 escapeFunction) args,+ mconcat $ map (args12 escapeFunction) args, {-# LINE 46 "HaskadesBinding.hs.mustache" #-}- if mempty /= (Any hasArgs) then hasArgs12 escapeFunction ctx else mempty,+ if mempty /= (Any hasArgs) then hasArgs13 escapeFunction ctx else mempty, {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build "(join ((return ", {-# LINE 46 "HaskadesBinding.hs.mustache" #-}@@ -173,7 +181,7 @@ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build ") ", {-# LINE 46 "HaskadesBinding.hs.mustache" #-}- mconcat $ map (args13 escapeFunction) args,+ mconcat $ map (args14 escapeFunction) args, {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build ")) >>= ", {-# LINE 46 "HaskadesBinding.hs.mustache" #-}@@ -182,33 +190,33 @@ build ")\n" ] where- hasArgs10 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ hasArgs11 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build "\\" ]- args11 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ args12 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build aname, {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build " " ]- hasArgs12 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ hasArgs13 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build "-> " ]- args13 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ args14 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [ {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build " `ap` ", {-# LINE 46 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build cwrap ]- slots14 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ slots15 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 50 "HaskadesBinding.hs.mustache" #-} build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name, {-# LINE 50 "HaskadesBinding.hs.mustache" #-} build "Ptr " ]- slots15 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ slots16 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [ {-# LINE 54 "HaskadesBinding.hs.mustache" #-} build "\tfreeHaskellFunPtr ", {-# LINE 54 "HaskadesBinding.hs.mustache" #-}
haskades.cabal view
@@ -1,5 +1,5 @@ name: haskades-version: 0.1+version: 0.1.1 cabal-version: >= 1.8 license: OtherLicense license-file: COPYING
haskades.hs view
@@ -14,8 +14,8 @@ import Records import MustacheTemplates -data Type = TInt | TUTCTime | TDouble | TString | TText | TLText | TUnit deriving (Show, Ord, Eq)-data RType = RPure Type | RIO Type deriving (Show, Eq)+data Type = TInt | TUTCTime | TDouble | TString | TText | TLText deriving (Show, Ord, Eq)+data RType = RPure Type | RIOUnit | RIO Type deriving (Show, Eq) importPrefix :: HsImportDecl -> String importPrefix (HsImportDecl {importQualified = True, importAs = Just (Module m)}) = m@@ -61,7 +61,6 @@ ] resolveType :: [(String, Module)] -> HsType -> Either String Type-resolveType _ (HsTyCon (Special HsUnitCon)) = Right TUnit resolveType _ (HsTyCon (UnQual (HsIdent "Int"))) = Right TInt resolveType _ (HsTyCon (UnQual (HsIdent "Double"))) = Right TDouble resolveType _ (HsTyCon (UnQual (HsIdent "String"))) = Right TString@@ -72,6 +71,8 @@ resolveType _ t = Left $ "Type not yet supported: " ++ show t resolveRType :: [(String, Module)] -> HsType -> Either String RType+resolveRType _ (HsTyCon (Special HsUnitCon)) = Left "A pure function that returns () ?"+resolveRType _ (HsTyApp (HsTyCon (UnQual (HsIdent "IO"))) (HsTyCon (Special HsUnitCon))) = return RIOUnit resolveRType i (HsTyApp (HsTyCon (UnQual (HsIdent "IO"))) t) = RIO <$> resolveType i t resolveRType i t = RPure <$> resolveType i t @@ -106,7 +107,6 @@ mapQtType TInt = "int" mapQtType TUTCTime = "QDateTime" mapQtType TDouble = "double"-mapQtType TUnit = "const void *" mapQtType TString = "QString" mapQtType TText = "QString" mapQtType TLText = "QString"@@ -115,7 +115,6 @@ mapLowCType TInt = "int" mapLowCType TUTCTime = "uint" -- Not time_t because of Qt mapLowCType TDouble = "double"-mapLowCType TUnit = "const void *" mapLowCType TString = "const char *" mapLowCType TText = "const char *" mapLowCType TLText = "const char *"@@ -124,13 +123,13 @@ mapCType TInt = "CInt" mapCType TUTCTime = "CUInt" -- Not CTime because of Qt mapCType TDouble = "CDouble"-mapCType TUnit = "()" mapCType TString = "CString" mapCType TText = "CString" mapCType TLText = "CString" -- We always live in IO on the C side mapCRType :: RType -> String+mapCRType RIOUnit = "IO ()" mapCRType (RPure t) = "IO " ++ mapCType t mapCRType (RIO t) = "IO " ++ mapCType t @@ -141,7 +140,7 @@ wrapTypeFromC TString arg = "(fmap (Text.unpack . Text.decodeUtf8) (ByteString.packCString " ++ arg ++ "))" wrapTypeFromC TText arg = "(fmap Text.decodeUtf8 (ByteString.packCString " ++ arg ++ "))" wrapTypeFromC TLText arg = "(fmap (LText.fromStrict . Text.decodeUtf8) (ByteString.packCString " ++ arg ++ "))"-wrapTypeFromC _ arg = "(return " ++ arg ++ ")"+--wrapTypeFromC _ arg = "(return " ++ arg ++ ")" wrapTypeToC :: Type -> String -> String wrapTypeToC TInt arg = "(flip ($) (fromIntegral " ++ arg ++ "))"@@ -150,7 +149,6 @@ wrapTypeToC TString arg = "(ByteString.useAsCString (Text.encodeUtf8 $ Text.pack " ++ arg ++ "))" wrapTypeToC TText arg = "(ByteString.useAsCString (Text.encodeUtf8 " ++ arg ++ "))" wrapTypeToC TLText arg = "(ByteString.useAsCString (Text.encodeUtf8 $ LText.toStrict " ++ arg ++ "))"-wrapTypeToC TUnit arg = "(flip ($) (" ++ arg ++ "))" wrapTypeFromQt :: Type -> String -> String wrapTypeFromQt TUTCTime arg = "(" ++ arg ++ ").toTime_t()"@@ -173,14 +171,14 @@ defTypeToC TString = "(flip ($) nullPtr)" defTypeToC TText = "(flip ($) nullPtr)" defTypeToC TLText = "(flip ($) nullPtr)"-defTypeToC TUnit = "(flip ($) nullPtr)" templateSlot :: (String, [Type], RType) -> Slot templateSlot (fname, args, rtype) = Slot { name = fname, monadic = case rtype of RPure _ -> "(return " ++ fname ++ ")"- RIO _ -> "(" ++ fname ++ ")",+ RIOUnit -> "(" ++ fname ++ ")"+ RIO _ -> "(" ++ fname ++ ")", hasArgs = not (null args), args = zipWith (\i a -> SlotArg { firstarg = i == 0,