├── .gitignore ├── hs-uikit ├── src │ ├── UIKit.hs │ ├── Foundation.hs │ ├── CoreAnimation.hs │ ├── UIKit │ │ ├── UIColor.hs │ │ ├── UIViewController.hs │ │ ├── UIAccessibility.hs │ │ ├── UIFont.hs │ │ ├── UIWindow.hs │ │ ├── UIGestureRecognizer.hs │ │ ├── UILabel.hs │ │ ├── UIPanGestureRecognizer.hs │ │ ├── Generic │ │ │ ├── GestureRecognizerTarget.hs │ │ │ ├── View.hs │ │ │ ├── ViewController.hs │ │ │ └── AppDelegate.hs │ │ ├── UIView.hs │ │ └── Types.hs │ ├── Foundation │ │ ├── NSString.hs │ │ ├── NSMutableArray.hs │ │ └── Types.hs │ ├── CoreGraphics.hs │ └── ObjC.hs ├── cbits │ ├── UIViewControllerMethods.m │ ├── GenericAppDelegate.h │ ├── UIAccessibilityMethods.m │ ├── ObjCMethods.m │ ├── GenericView.h │ ├── UIColorMethods.m │ ├── GenericViewController.h │ ├── GenericGestureRecognizerTarget.h │ ├── NSMutableArrayMethods.m │ ├── NSStringMethods.m │ ├── UILabelMethods.m │ ├── MainThread.m │ ├── UIWindowMethods.m │ ├── GenericView.m │ ├── UIGestureRecognizerMethods.m │ ├── UIPanGestureRecognizerMethods.m │ ├── UIFontMethods.m │ ├── UIViewMethods.m │ ├── GenericViewController.m │ ├── GenericGestureRecognizerTarget.m │ └── GenericAppDelegate.m ├── default.nix ├── LICENSE └── hs-uikit.cabal ├── examples └── draggy │ ├── src-bin │ └── uikit.hs │ ├── default.nix │ ├── LICENSE │ ├── reflex-native-draggy.cabal │ └── src │ └── Reflex │ └── Native │ └── Examples │ └── Draggy.hs ├── reflex-platform-version.json ├── host.project ├── ios.project ├── reflex-native-test ├── src │ └── Reflex │ │ └── Native │ │ ├── Test.hs │ │ └── Test │ │ ├── Optics.hs │ │ ├── Runner.hs │ │ └── Evaluation.hs ├── LICENSE └── reflex-native-test.cabal ├── reflex-native ├── src │ └── Reflex │ │ ├── Native │ │ ├── ViewLayout.hs │ │ ├── Font.hs │ │ ├── ViewStyle.hs │ │ ├── TextConfig.hs │ │ ├── TextStyle.hs │ │ ├── Color.hs │ │ ├── Geometry.hs │ │ ├── Gesture.hs │ │ ├── ViewConfig.hs │ │ ├── Widget │ │ │ ├── Basic.hs │ │ │ └── Customization.hs │ │ └── ViewBuilder │ │ │ └── Class.hs │ │ └── Native.hs ├── LICENSE └── reflex-native.cabal ├── reflex-native-uikit ├── src │ └── Reflex │ │ └── UIKit │ │ ├── Layout.hs │ │ ├── Conversions.hs │ │ ├── Style.hs │ │ ├── Config.hs │ │ ├── Specializations.hs │ │ └── Main.hs ├── LICENSE ├── reflex-native-uikit.cabal └── cbits │ └── UIKitViewBuilder.m ├── LICENSE ├── CONTRIBUTING.md ├── Makefile ├── default.nix └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | result 3 | .ghc.environment.* 4 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit.hs: -------------------------------------------------------------------------------- 1 | module UIKit (module Export) where 2 | 3 | import UIKit.Types as Export 4 | 5 | -------------------------------------------------------------------------------- /hs-uikit/src/Foundation.hs: -------------------------------------------------------------------------------- 1 | module Foundation (module Export) where 2 | 3 | import Foundation.Types as Export 4 | 5 | 6 | -------------------------------------------------------------------------------- /hs-uikit/src/CoreAnimation.hs: -------------------------------------------------------------------------------- 1 | module CoreAnimation where 2 | 3 | 4 | type CFTimeInterval = Double 5 | 6 | foreign import ccall unsafe "CACurrentMediaTime" currentMediaTime :: IO CFTimeInterval 7 | -------------------------------------------------------------------------------- /examples/draggy/src-bin/uikit.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Reflex.Native.Examples.Draggy as Draggy 4 | import Reflex.UIKit.Main (run) 5 | 6 | 7 | main :: IO () 8 | main = run Draggy.main 9 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIViewControllerMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | 5 | void uiViewController_setView(UIViewController* viewController, UIView* view) { 6 | viewController.view = view; 7 | } 8 | 9 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericAppDelegate.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #import 3 | 4 | @interface GenericAppDelegate : UIResponder 5 | 6 | @property (nonatomic, strong) UIWindow *window; 7 | 8 | @end 9 | -------------------------------------------------------------------------------- /reflex-platform-version.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "reflex-frp", 3 | "repo": "reflex-platform", 4 | "rev": "3d232e2d1d8e8d10fbafc928972c901c764ae324", 5 | "sha256": "15ysjn0aknbl06spn4qls7xapm0d3qw2awx6k8jl28zwkaid45yg" 6 | } 7 | 8 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIAccessibilityMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | 5 | void uiAccessibility_setAccessibilityLabel(NSObject* target, NSString* label) { 6 | target.accessibilityLabel = label; 7 | } 8 | -------------------------------------------------------------------------------- /hs-uikit/cbits/ObjCMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | 3 | 4 | void hsobjc_retain(id obj) { 5 | (void)CFBridgingRetain(obj); 6 | } 7 | 8 | void hsobjc_release(const void* obj) { 9 | (void)CFBridgingRelease(obj); 10 | } 11 | 12 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericView.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #import 3 | 4 | @interface GenericView : UIView 5 | 6 | @property (nonatomic, assign) HsStablePtr config; 7 | 8 | - (instancetype)initWithCallback:(HsStablePtr) callback; 9 | 10 | @end 11 | 12 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIColorMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | UIColor* uiColor_colorWithRedGreenBlueAlpha(CGFloat red, CGFloat green, CGFloat blue, CGFloat alpha) { 5 | return [UIColor colorWithRed:red green:green blue:blue alpha:alpha]; 6 | } 7 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericViewController.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #import 3 | 4 | @interface GenericViewController : UIViewController 5 | 6 | @property (nonatomic, assign) HsStablePtr config; 7 | 8 | - (instancetype)initWithCallback:(HsStablePtr)callback; 9 | 10 | @end 11 | -------------------------------------------------------------------------------- /host.project: -------------------------------------------------------------------------------- 1 | packages: 2 | examples/draggy/ 3 | hs-uikit/ 4 | reflex-native/ 5 | reflex-native-test/ 6 | package hs-uikit 7 | ghc-options: -Werror 8 | package reflex-native 9 | ghc-options: -Werror 10 | package reflex-native-draggy 11 | ghc-options: -Werror 12 | package reflex-native-test 13 | ghc-options: -Werror 14 | 15 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericGestureRecognizerTarget.h: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | @interface GenericGestureRecognizerTarget : NSObject 5 | 6 | @property (nonatomic, assign) HsStablePtr callback; 7 | @property (nonatomic, strong) UIGestureRecognizer* recognizer; 8 | 9 | - (instancetype)initWithCallback:(HsStablePtr)callback; 10 | 11 | @end 12 | 13 | -------------------------------------------------------------------------------- /hs-uikit/cbits/NSMutableArrayMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | NSMutableArray* nsMutableArray_new() { 5 | return [NSMutableArray new]; 6 | } 7 | 8 | void nsMutableArray_addObject(NSMutableArray* ma, id obj) { 9 | [ma addObject:obj]; 10 | } 11 | 12 | void nsMutableArray_addObjectsFromArray(NSMutableArray* ma, NSArray* a) { 13 | [ma addObjectsFromArray:a]; 14 | } 15 | 16 | -------------------------------------------------------------------------------- /ios.project: -------------------------------------------------------------------------------- 1 | packages: 2 | examples/draggy/ 3 | hs-uikit/ 4 | reflex-native/ 5 | reflex-native-uikit/ 6 | package hs-uikit 7 | ghc-options: -Werror 8 | package reflex-native 9 | ghc-options: -Werror 10 | package reflex-native-draggy 11 | ghc-options: -Werror 12 | package reflex-native-uikit 13 | ghc-options: -Werror 14 | with-compiler: aarch64-apple-ios-ghc 15 | with-hc-pkg: aarch64-apple-ios-ghc-pkg 16 | 17 | -------------------------------------------------------------------------------- /hs-uikit/cbits/NSStringMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | NSString* nsString_stringWithCharactersLength(const unichar* chars, unsigned long len) { 5 | return [NSString stringWithCharacters:chars length:len]; 6 | } 7 | 8 | unsigned long nsString_length(NSString* nss) { 9 | return nss.length; 10 | } 11 | 12 | void nsString_getCharacters(NSString* nss, unichar* chars) { 13 | [nss getCharacters:chars range:NSMakeRange(0, nss.length)]; 14 | } 15 | 16 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UILabelMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | UILabel* uiLabel_new() { 5 | return [UILabel new]; 6 | } 7 | 8 | void uiLabel_setFont(UILabel*__nonnull label, UIFont*__nullable font) { 9 | label.font = font; 10 | } 11 | 12 | void uiLabel_setText(UILabel*__nonnull label, NSString*__nullable text) { 13 | label.text = text; 14 | } 15 | 16 | void uiLabel_setTextColor(UILabel*__nonnull label, UIColor*__nullable color) { 17 | label.textColor = color; 18 | } 19 | 20 | -------------------------------------------------------------------------------- /examples/draggy/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, stdenv 2 | , base, reflex, reflex-native, reflex-native-uikit ? null, vector-space }: 3 | mkDerivation { 4 | pname = "reflex-native"; 5 | version = "0.1.0.0"; 6 | src = ./.; 7 | libraryHaskellDepends = [ base reflex reflex-native reflex-native-uikit vector-space ]; 8 | homepage = "https://github.com/reflex-frp/reflex-native"; 9 | description = "Cross platform layer for developing native Reflex apps"; 10 | license = stdenv.lib.licenses.bsd3; 11 | } 12 | 13 | -------------------------------------------------------------------------------- /hs-uikit/cbits/MainThread.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import 3 | #import "UIKit/Types_stub.h" 4 | 5 | void mainThread_checkMainThread() { 6 | if (![NSThread isMainThread]) { 7 | os_log_error(OS_LOG_DEFAULT, "expected to be on main thread for builder actions :'("); 8 | } 9 | } 10 | 11 | BOOL mainThread_isMainThread() { 12 | return [NSThread isMainThread]; 13 | } 14 | 15 | void mainThread_dispatchAsyncMain(HsStablePtr callbackPtr) { 16 | dispatch_async(dispatch_get_main_queue(), ^{ 17 | mainThread_inMainThread(callbackPtr); 18 | }); 19 | } 20 | -------------------------------------------------------------------------------- /reflex-native-test/src/Reflex/Native/Test.hs: -------------------------------------------------------------------------------- 1 | -- |Consolidation of the @Reflex.Native.Test@ modules into a single namespace and with internals hidden for convenience. 2 | module Reflex.Native.Test (module Export) where 3 | 4 | import Reflex.Native.Test.Evaluation as Export 5 | import Reflex.Native.Test.Optics as Export 6 | import Reflex.Native.Test.Runner as Export 7 | import Reflex.Native.Test.Types as Export 8 | ( TestEvaluation, TestIdentity, tshowTestIdentity, TestViewCommon(..), TestContainerView(..), TestTextView(..), TestView(..) 9 | , _testView_common, _testView_identity 10 | ) 11 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIWindowMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | UIViewController* uiWindow_getRootViewController(UIWindow* window) { 5 | return window.rootViewController; 6 | } 7 | 8 | void uiWindow_setRootViewController(UIWindow* window, UIViewController* vc) { 9 | window.rootViewController = vc; 10 | } 11 | 12 | BOOL uiWindow_isKeyWindow(UIWindow* window) { 13 | return window.keyWindow; 14 | } 15 | 16 | void uiWindow_makeKeyAndVisible(UIWindow* window) { 17 | [window makeKeyAndVisible]; 18 | } 19 | 20 | void uiWindow_makeKeyWindow(UIWindow* window) { 21 | [window makeKeyWindow]; 22 | } 23 | 24 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericView.m: -------------------------------------------------------------------------------- 1 | #import "GenericView.h" 2 | #include "UIKit/Generic/View_stub.h" 3 | 4 | @implementation GenericView 5 | 6 | - (id)initWithCallback:(HsStablePtr)callback { 7 | if (!(self = [super init])) { 8 | return self; 9 | } 10 | 11 | _config = genericViewImpl_initialize((__bridge HsPtr)self, callback); 12 | 13 | return self; 14 | } 15 | 16 | - (void)dealloc { 17 | genericViewImpl_release(_config); 18 | } 19 | 20 | - (void)drawRect:(CGRect)rect { 21 | genericViewImpl_drawRect(_config, &rect); 22 | } 23 | 24 | @end 25 | 26 | UIView* genericView_new(HsStablePtr callback) { 27 | return [[GenericView alloc] initWithCallback:callback]; 28 | } 29 | 30 | -------------------------------------------------------------------------------- /hs-uikit/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, stdenv, buildPackages, hostPlatform 2 | , base, monad-control, text, transformers-base }: 3 | mkDerivation { 4 | pname = "hs-uikit"; 5 | version = "0.1.0.0"; 6 | src = ./.; 7 | libraryHaskellDepends = [ base monad-control text transformers-base ]; 8 | libraryFrameworkDepends = 9 | stdenv.lib.optional (hostPlatform.useiOSPrebuilt) 10 | "${buildPackages.darwin.xcode}/Contents/Developer/Platforms/${hostPlatform.xcodePlatform}.platform/Developer/SDKs/${hostPlatform.xcodePlatform}.sdk/System"; 11 | homepage = "https://github.com/reflex-frp/reflex-native"; 12 | description = "Bindings to UIKit"; 13 | license = stdenv.lib.licenses.bsd3; 14 | } 15 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIGestureRecognizerMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | 5 | static int uiGestureRecognizer_stateToHs(UIGestureRecognizerState state) { 6 | switch (state) { 7 | case UIGestureRecognizerStatePossible: return 0; 8 | case UIGestureRecognizerStateBegan: return 1; 9 | case UIGestureRecognizerStateChanged: return 2; 10 | case UIGestureRecognizerStateEnded: return 3; 11 | case UIGestureRecognizerStateCancelled: return 4; 12 | default: return 5; /* Failed */ 13 | } 14 | } 15 | 16 | int uiGestureRecognizer_getState(UIGestureRecognizer* recognizer) { 17 | return uiGestureRecognizer_stateToHs(recognizer.state); 18 | } 19 | 20 | 21 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/ViewLayout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | -- |Cross platform notion of view layout. FIXME totally lame right now. 4 | module Reflex.Native.ViewLayout 5 | ( ViewLayout(..) 6 | ) where 7 | 8 | import GHC.Generics (Generic) 9 | import Reflex.Native.Geometry (Rect) 10 | 11 | 12 | -- |Layout parameters to apply to a view. 13 | data ViewLayout 14 | = ViewLayout_Fixed !Rect 15 | -- ^Position the view at an exact location and with an exact size. 16 | -- The view does not affect the layout of other views, as if it were not there from a layout perspective. 17 | deriving (Eq, Generic) 18 | 19 | -- |Show a 'ViewLayout' compactly for diagnostics. 20 | instance Show ViewLayout where 21 | showsPrec _ = \ case 22 | ViewLayout_Fixed r -> showString "fixed " . shows r 23 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIPanGestureRecognizerMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | UIPanGestureRecognizer* uiPanGestureRecognizer_new(id target) { 5 | return [[UIPanGestureRecognizer alloc] initWithTarget:target action:@selector(handler:)]; 6 | } 7 | 8 | void uiPanGestureRecognizer_getTranslationInSuperview(UIPanGestureRecognizer* recognizer, CGPoint* out) { 9 | if (recognizer.view == nil || recognizer.view.superview == nil) { 10 | *out = CGPointZero; 11 | } else { 12 | *out = [recognizer translationInView:recognizer.view.superview]; 13 | } 14 | } 15 | 16 | void uiPanGestureRecognizer_getVelocityInSuperview(UIPanGestureRecognizer* recognizer, CGPoint* out) { 17 | if (recognizer.view == nil || recognizer.view.superview == nil) { 18 | *out = CGPointZero; 19 | } else { 20 | *out = [recognizer velocityInView:recognizer.view.superview]; 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIFontMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | 5 | CGFloat uiFont_fontWeightFromInt(int weight) { 6 | switch (weight) { 7 | case 0: return UIFontWeightUltraLight; 8 | case 1: return UIFontWeightThin; 9 | case 2: return UIFontWeightLight; 10 | case 3: return UIFontWeightRegular; 11 | case 4: return UIFontWeightMedium; 12 | case 5: return UIFontWeightSemibold; 13 | case 6: return UIFontWeightBold; 14 | case 7: return UIFontWeightHeavy; 15 | case 8: return UIFontWeightBlack; 16 | 17 | default: return UIFontWeightRegular; 18 | } 19 | } 20 | 21 | UIFont* uiFont_systemFontOfSizeWeight(CGFloat size, int weight) { 22 | return [UIFont systemFontOfSize:size weight:uiFont_fontWeightFromInt(weight)]; 23 | } 24 | 25 | UIFont* uiFont_fontWithNameSize(NSString* name, CGFloat size) { 26 | return [UIFont fontWithName:name size:size]; 27 | } 28 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIColor.hs: -------------------------------------------------------------------------------- 1 | -- |Class and instance methods of @UIColor@. 2 | module UIKit.UIColor 3 | ( 4 | -- * Class methods 5 | colorWithRedGreenBlueAlpha 6 | -- * Raw FFI bindings 7 | , uiColor_colorWithRedGreenBlueAlpha 8 | ) where 9 | 10 | import Control.Monad ((=<<)) 11 | import CoreGraphics (CGFloat) 12 | import Foreign.Ptr (Ptr) 13 | import ObjC (retainObj) 14 | import UIKit.Types (UIColor, UIColorType) 15 | 16 | 17 | -- |Raw FFI binding to @UIColor + colorWithRed:green:blue:alpha:@ 18 | foreign import ccall unsafe uiColor_colorWithRedGreenBlueAlpha :: CGFloat -> CGFloat -> CGFloat -> CGFloat -> IO (Ptr UIColorType) 19 | -- |@UIColor + colorWithRed:green:blue:alpha:@ - create a 'UIColor' with the given red, green, blue, and alpha components. 20 | colorWithRedGreenBlueAlpha :: CGFloat -> CGFloat -> CGFloat -> CGFloat -> IO UIColor 21 | colorWithRedGreenBlueAlpha r g b a = retainObj =<< uiColor_colorWithRedGreenBlueAlpha r g b a 22 | -------------------------------------------------------------------------------- /reflex-native-uikit/src/Reflex/UIKit/Layout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | -- |Functionality for applying "Reflex.Native" layouts to UIKit views. 5 | module Reflex.UIKit.Layout 6 | ( applyLayout 7 | ) where 8 | 9 | import CoreGraphics (CGPoint(..), CGRect(..), CGSize(..)) 10 | import ObjC (ObjPtr, SafeObjCoerce) 11 | import Reflex.Native (Point(..), Rect(..), Size(..), ViewLayout(..)) 12 | import UIKit.Types (MainThread, UIViewType) 13 | import qualified UIKit.UIView as UIView 14 | 15 | 16 | -- |Apply a 'ViewLayout' to the given view. Used for both initial layout and later updates. 17 | {-# INLINABLE applyLayout #-} 18 | applyLayout :: SafeObjCoerce v UIViewType => ObjPtr v -> ViewLayout -> MainThread () 19 | applyLayout view = \ case 20 | ViewLayout_Fixed (Rect (Point {..}) (Size {..})) -> do 21 | UIView.setFrame view (CGRect (CGPoint _point_x _point_y) (CGSize _size_width _size_height)) 22 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/Font.hs: -------------------------------------------------------------------------------- 1 | -- |Cross-platform notion of fonts. 2 | module Reflex.Native.Font 3 | ( Font(..), Weight(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | 8 | 9 | -- ^Identifies a font, either a system font of a particular size and weight or a custom font by name and size. 10 | data Font 11 | = Font_System Int Weight 12 | -- ^Whatever the system considers to be the default system font in the chosen size and weight. 13 | | Font_Custom Text Int 14 | -- ^A particular font by its name and size. 15 | deriving (Eq, Show) 16 | 17 | -- |A font's weight from lightest to heaviest, corresponding to 100 through 900 of CSS's @font-weight@ property. 18 | data Weight -- FIXME! Order matters to the ObjC code! 19 | = Weight_UltraLight 20 | | Weight_Thin 21 | | Weight_Light 22 | | Weight_Regular 23 | | Weight_Medium 24 | | Weight_Semibold 25 | | Weight_Bold 26 | | Weight_Heavy 27 | | Weight_Black 28 | deriving (Bounded, Enum, Eq, Ord, Show) 29 | -------------------------------------------------------------------------------- /hs-uikit/cbits/UIViewMethods.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | 5 | void uiView_addGestureRecognizer(UIView* view, UIGestureRecognizer* recognizer) { 6 | [view addGestureRecognizer:recognizer]; 7 | } 8 | 9 | void uiView_addSubview(UIView* view, UIView* subview) { 10 | [view addSubview:subview]; 11 | } 12 | 13 | void uiView_removeFromSuperview(UIView* view) { 14 | [view removeFromSuperview]; 15 | } 16 | 17 | void uiView_setAutoresizesSubviews(UIView* view, BOOL does) { 18 | view.autoresizesSubviews = does; 19 | } 20 | 21 | void uiView_setAutoresizingMask(UIView* view, UIViewAutoresizing mask) { 22 | view.autoresizingMask = mask; 23 | } 24 | 25 | void uiView_setBackgroundColor(UIView* view, UIColor* color) { 26 | view.backgroundColor = color; 27 | CGFloat r, g, b, a; 28 | (void)[color getRed:&r green:&g blue:&g alpha:&a]; 29 | view.opaque = a >= 0.999; 30 | } 31 | 32 | void uiView_setFrame(UIView* view, CGRect* rect) { 33 | view.frame = *rect; 34 | } 35 | 36 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIViewController.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- |Class and instance methods of the @UIViewController@ class. 3 | module UIKit.UIViewController 4 | ( 5 | -- * Instance methods 6 | setView 7 | -- * Raw FFI bindings 8 | , uiViewController_setView 9 | ) where 10 | 11 | import Foreign.Ptr (Ptr) 12 | import ObjC (ObjPtr, SafeObjCoerce, withObjPtr) 13 | import UIKit.Types (MainThread(..), UIViewType, UIViewControllerType, asUIView, asUIViewController) 14 | 15 | 16 | -- |Raw FFI binding to @UIViewController - setView:@ 17 | foreign import ccall uiViewController_setView :: Ptr UIViewControllerType -> Ptr UIViewType -> MainThread () 18 | -- |@UIViewController - setView:@ - set the root view of the view controller. 19 | setView :: (SafeObjCoerce viewController UIViewControllerType, SafeObjCoerce view UIViewType) => ObjPtr viewController -> ObjPtr view -> MainThread () 20 | setView vco vo = 21 | withObjPtr (asUIViewController vco) $ \ vc -> 22 | withObjPtr (asUIView vo) $ \ v -> 23 | uiViewController_setView vc v 24 | 25 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericViewController.m: -------------------------------------------------------------------------------- 1 | #import "GenericViewController.h" 2 | #import "UIKit/Generic/ViewController_stub.h" 3 | 4 | @implementation GenericViewController 5 | 6 | - (id)initWithCallback:(HsStablePtr)callback { 7 | if (!(self = [super init])) { 8 | return self; 9 | } 10 | 11 | _config = genericViewController_initialize((__bridge HsPtr)self, callback); 12 | 13 | return self; 14 | } 15 | 16 | - (void)dealloc { 17 | genericViewController_release(_config); 18 | } 19 | 20 | - (void)loadView { 21 | [super loadView]; 22 | self.view = (__bridge_transfer UIView*)genericViewController_loadView(_config); 23 | } 24 | 25 | - (void)viewDidLoad { 26 | [super viewDidLoad]; 27 | genericViewController_viewDidLoad(_config); 28 | } 29 | 30 | - (void)didReceiveMemoryWarning { 31 | [super didReceiveMemoryWarning]; 32 | genericViewController_didReceiveMemoryWarning(_config); 33 | } 34 | 35 | @end 36 | 37 | UIViewController* genericViewController_new(HsStablePtr callback) { 38 | return [[GenericViewController alloc] initWithCallback:callback]; 39 | } 40 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericGestureRecognizerTarget.m: -------------------------------------------------------------------------------- 1 | #import "GenericGestureRecognizerTarget.h" 2 | #import "UIKit/Generic/GestureRecognizerTarget_stub.h" 3 | 4 | @implementation GenericGestureRecognizerTarget 5 | 6 | - (id)initWithCallback:(HsStablePtr)callback { 7 | if (!(self = [super init])) { 8 | return self; 9 | } 10 | 11 | _callback = callback; 12 | 13 | return self; 14 | } 15 | 16 | - (void)dealloc { 17 | if (_recognizer == nil) return; 18 | if (_recognizer.view == nil) return; 19 | [_recognizer.view removeGestureRecognizer:_recognizer]; 20 | } 21 | 22 | - (void)handler:(UIGestureRecognizer*)recognizer { 23 | genericGestureRecognizerTarget_handler(_callback, (__bridge HsPtr)_recognizer); 24 | } 25 | 26 | @end 27 | 28 | GenericGestureRecognizerTarget* genericGestureRecognizerTarget_new(HsStablePtr callback) { 29 | return [[GenericGestureRecognizerTarget alloc] initWithCallback:callback]; 30 | } 31 | 32 | void genericGestureRecognizerTarget_setRecognizer(GenericGestureRecognizerTarget* target, UIGestureRecognizer* recognizer) { 33 | target.recognizer = recognizer; 34 | } 35 | -------------------------------------------------------------------------------- /hs-uikit/src/Foundation/NSString.hs: -------------------------------------------------------------------------------- 1 | module Foundation.NSString where 2 | 3 | import Control.Monad ((=<<)) 4 | import Data.Text (Text) 5 | import qualified Data.Text.Foreign as DTF 6 | import Data.Word (Word16) 7 | import Foreign.C.Types (CULong(..)) 8 | import Foreign.Marshal.Array (allocaArray) 9 | import Foreign.Ptr (Ptr) 10 | import Foundation.Types (NSString, NSStringType) 11 | import ObjC (retainObj, withObjPtr) 12 | 13 | 14 | foreign import ccall unsafe nsString_stringWithCharactersLength :: Ptr Word16 -> CULong -> IO (Ptr NSStringType) 15 | 16 | fromText :: Text -> IO NSString 17 | fromText text = 18 | DTF.useAsPtr text $ \ charsPtr len -> 19 | retainObj =<< nsString_stringWithCharactersLength charsPtr (fromIntegral len) 20 | 21 | foreign import ccall unsafe nsString_length :: Ptr NSStringType -> IO CULong 22 | foreign import ccall unsafe nsString_getCharacters :: Ptr NSStringType -> Ptr Word16 -> IO () 23 | 24 | toText :: NSString -> IO Text 25 | toText so = 26 | withObjPtr so $ \ s -> do 27 | len <- nsString_length s 28 | allocaArray (fromIntegral len) $ \ charsPtr -> do 29 | nsString_getCharacters s charsPtr 30 | DTF.fromPtr charsPtr (fromIntegral len) 31 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIAccessibility.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- |Methods of the @UIAccessibility@ informal protocol. 3 | module UIKit.UIAccessibility 4 | ( 5 | -- * Instance methods 6 | setAccessibilityLabel 7 | -- * Raw FFI bindings 8 | , uiAccessibility_setAccessibilityLabel 9 | ) where 10 | 11 | import Data.Maybe (Maybe(Just, Nothing)) 12 | import Foreign.Ptr (Ptr, nullPtr) 13 | import Foundation.Types (NSString, NSStringType) 14 | import ObjC (ObjPtr, ObjType, SafeObjCoerce, asObj, withObjPtr) 15 | import UIKit.Types (MainThread(..)) 16 | 17 | 18 | -- |Raw FFI binding to @NSObject(UIAccessibility) - setAccessibilityLabel:@ 19 | foreign import ccall unsafe uiAccessibility_setAccessibilityLabel :: Ptr ObjType -> Ptr NSStringType -> MainThread () 20 | -- |@NSObject(UIAccessibility) - setAccessibilityLabel:@ - Set the accessibility label of an accessibility element. 21 | setAccessibilityLabel :: SafeObjCoerce a ObjType => ObjPtr a -> Maybe NSString -> MainThread () 22 | setAccessibilityLabel ao soMay = 23 | withObjPtr (asObj ao) $ \ a -> 24 | case soMay of 25 | Just so -> 26 | withObjPtr so $ \ s -> 27 | uiAccessibility_setAccessibilityLabel a s 28 | Nothing -> 29 | uiAccessibility_setAccessibilityLabel a nullPtr 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Confer Health, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. 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. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | 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 HOLDER 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. 13 | -------------------------------------------------------------------------------- /hs-uikit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Confer Health, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. 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. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | 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 HOLDER 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. 13 | -------------------------------------------------------------------------------- /reflex-native/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Confer Health, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. 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. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | 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 HOLDER 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. 13 | -------------------------------------------------------------------------------- /examples/draggy/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Confer Health, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. 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. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | 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 HOLDER 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. 13 | -------------------------------------------------------------------------------- /reflex-native-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Confer Health, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. 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. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | 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 HOLDER 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. 13 | -------------------------------------------------------------------------------- /reflex-native-uikit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Confer Health, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. 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. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | 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 HOLDER 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. 13 | -------------------------------------------------------------------------------- /reflex-native-uikit/src/Reflex/UIKit/Conversions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | -- |Conversions between "Reflex.Native" and UIKit types. 4 | module Reflex.UIKit.Conversions 5 | ( makeUIFont, makeUIColor, pointFromCGPoint 6 | ) where 7 | 8 | import Control.Monad ((>>=)) 9 | import Control.Monad.IO.Class (MonadIO, liftIO) 10 | import CoreGraphics (CGPoint(..)) 11 | import qualified Foundation.NSString as NSString 12 | import Reflex.Native (Color(..), Font(..), Point(..)) 13 | import UIKit.Types (UIColor, UIFont) 14 | import qualified UIKit.UIColor as UIColor 15 | import qualified UIKit.UIFont as UIFont 16 | 17 | 18 | -- |Make a 'UIFont' from a 'Font' using the class methods of "UIKit.UIFont". 19 | {-# INLINABLE makeUIFont #-} 20 | makeUIFont :: MonadIO m => Font -> m UIFont 21 | makeUIFont = liftIO . \ case 22 | Font_System size weight -> UIFont.systemFontOfSizeWeight (fromIntegral size) (fromIntegral $ fromEnum weight) 23 | Font_Custom name size -> NSString.fromText name >>= \ ns -> UIFont.fontWithNameSize ns (fromIntegral size) 24 | 25 | -- |Make a 'UIColor' from a 'Color' using the class methods of "UIKit.UIColor". 26 | {-# INLINABLE makeUIColor #-} 27 | makeUIColor :: MonadIO m => Color -> m UIColor 28 | makeUIColor (Color {..}) = 29 | liftIO $ UIColor.colorWithRedGreenBlueAlpha _color_red _color_green _color_blue _color_alpha 30 | 31 | -- |Convert a 'CGPoint' into a 'Point'. 32 | {-# INLINABLE pointFromCGPoint #-} 33 | pointFromCGPoint :: CGPoint -> Point 34 | pointFromCGPoint (CGPoint {..}) = Point _cgPoint_x _cgPoint_y 35 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | ## Contributing to Reflex Native 2 | 3 | ### Community 4 | 5 | As with [Reflex FRP](https://github.com/reflex-frp), the primary community areas are: 6 | 7 | * [/r/reflexfrp](https://www.reddit.com/r/reflexfrp) on Reddit 8 | * [#reflex-frp](http://webchat.freenode.net/?channels=%23reflex-frp&uio=d4) on Freenode 9 | 10 | ### Filing Issues 11 | 12 | Please feel free to file issues for bugs or proposed features. As is always good practice when filing bugs, please be clear about in what environment you 13 | experienced the problem (e.g. operating system, versions of Nix, Reflex Native, and so on), what behavior you experienced, what behavior you expected and how 14 | that differed from the experienced behavior, and what you tried to resolve the problem. Please provide reproduction code as much as possible. If your issue 15 | occurs in closed-source code get in contact and we can work out something. 16 | 17 | ### Pull Requests 18 | 19 | Also please feel free to submit pull requests to fix bugs or add functionality. If you're about to work on a large feature, it's probably best to create an 20 | issue first to raise awareness and solicit input. 21 | 22 | ### Licensing and Copyright 23 | 24 | The project is uniformly licensed using the standard [BSD3](https://opensource.org/licenses/BSD-3-Clause) license. By contributing code to the repository, you 25 | affirm that you wish your code to be released under this license and with no intellectual property entanglements that would conflict with the code becoming an 26 | open source and publicly maintained part of the project under the BSD3 license. 27 | 28 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIFont.hs: -------------------------------------------------------------------------------- 1 | -- |Class and instance methods of the @UIFont@ class. 2 | module UIKit.UIFont 3 | ( 4 | -- * Class methods 5 | systemFontOfSizeWeight, fontWithNameSize 6 | -- * Raw FFI bindings 7 | , uiFont_systemFontOfSizeWeight, uiFont_fontWithNameSize 8 | ) where 9 | 10 | import Control.Monad ((=<<)) 11 | import CoreGraphics (CGFloat) 12 | import Foreign.C.Types (CInt(..)) 13 | import Foreign.Ptr (Ptr) 14 | import Foundation (NSString, NSStringType) 15 | import ObjC (retainObj, withObjPtr) 16 | import UIKit.Types (UIFont, UIFontType) 17 | 18 | 19 | -- |Raw FFI binding to @UIFont + systemFontOfSize:weight:@ 20 | foreign import ccall unsafe uiFont_systemFontOfSizeWeight :: CGFloat -> CInt -> IO (Ptr UIFontType) 21 | -- |@UIFont + systemFontOfSize:weight:@ - create or obtain a cached instance of 'UIFont' for the system font of the given size in points and weight. Weights 22 | -- are represented as [0..8] ranging from ultra light to black corresponding to @UIFontWeight@, and should be changed to a proper data type. 23 | systemFontOfSizeWeight :: CGFloat -> CInt -> IO UIFont 24 | systemFontOfSizeWeight s w = retainObj =<< uiFont_systemFontOfSizeWeight s w 25 | 26 | -- |Raw FFI binding to @UIFont + fontWithName:size:@ 27 | foreign import ccall unsafe uiFont_fontWithNameSize :: Ptr NSStringType -> CGFloat -> IO (Ptr UIFontType) 28 | -- |@UIFont + fontWithName:size:@ - create or obtain a cached instance of 'UIFont' for the given font name and size. 29 | fontWithNameSize :: NSString -> CGFloat -> IO UIFont 30 | fontWithNameSize nameo size = 31 | withObjPtr nameo $ \ name -> 32 | retainObj =<< uiFont_fontWithNameSize name size 33 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIWindow.hs: -------------------------------------------------------------------------------- 1 | module UIKit.UIWindow where 2 | 3 | import Control.Monad ((=<<)) 4 | import Foreign.C.Types (CChar(..)) 5 | import Foreign.Ptr (Ptr) 6 | import ObjC (retainObj, withObjPtr, unObjcBool) 7 | import UIKit.Types (MainThread(..), UIViewController, UIViewControllerType, UIWindow, UIWindowType) 8 | 9 | 10 | foreign import ccall unsafe uiWindow_getRootViewController :: Ptr UIWindowType -> MainThread (Ptr UIViewControllerType) 11 | getRootViewController :: UIWindow -> MainThread UIViewController 12 | getRootViewController wo = 13 | withObjPtr wo $ \ w -> 14 | retainObj =<< uiWindow_getRootViewController w 15 | 16 | foreign import ccall uiWindow_setRootViewController :: Ptr UIWindowType -> Ptr UIViewControllerType -> MainThread () 17 | setRootViewController :: UIWindow -> UIViewController -> MainThread () 18 | setRootViewController wo vco = 19 | withObjPtr wo $ \ w -> 20 | withObjPtr vco $ \ vc -> 21 | uiWindow_setRootViewController w vc 22 | 23 | foreign import ccall uiWindow_isKeyWindow :: Ptr UIWindowType -> MainThread CChar 24 | isKeyWindow :: UIWindow -> MainThread Bool 25 | isKeyWindow wo = 26 | withObjPtr wo $ \ w -> 27 | unObjcBool <$> uiWindow_isKeyWindow w 28 | 29 | foreign import ccall uiWindow_makeKeyAndVisible :: Ptr UIWindowType -> MainThread () 30 | makeKeyAndVisible :: UIWindow -> MainThread () 31 | makeKeyAndVisible wo = 32 | withObjPtr wo $ \ w -> 33 | uiWindow_makeKeyAndVisible w 34 | 35 | foreign import ccall uiWindow_makeKeyWindow :: Ptr UIWindowType -> MainThread () 36 | makeKeyWindow :: UIWindow -> MainThread () 37 | makeKeyWindow wo = 38 | withObjPtr wo $ \ w -> 39 | uiWindow_makeKeyWindow w 40 | 41 | -------------------------------------------------------------------------------- /examples/draggy/reflex-native-draggy.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-native-draggy 2 | version: 0.1.0.0 3 | synopsis: Dragging example for Reflex Native 4 | author: Confer Health 5 | maintainer: oss@confer.health 6 | license: BSD3 7 | license-file: LICENSE 8 | build-type: Simple 9 | cabal-version: >= 1.10 10 | homepage: https://github.com/reflex-frp/reflex-native 11 | bug-reports: https://github.com/reflex-frp/reflex-native/issues 12 | 13 | flag uikit 14 | description: Build reflex-native-draggy-uikit 15 | default: True 16 | 17 | library 18 | default-language: Haskell2010 19 | exposed-modules: 20 | Reflex.Native.Examples.Draggy 21 | hs-source-dirs: src 22 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 23 | ghc-prof-options: -fprof-auto 24 | build-depends: 25 | base 26 | , reflex 27 | , reflex-native 28 | , vector-space == 0.13.* 29 | if os(ios) 30 | build-depends: 31 | reflex-native-uikit 32 | ghc-options: -optc-Wno-expansion-to-defined -optc-Wno-nullability-inferred-on-nested-type -optc-Wno-nullability-completeness-on-arrays -optc-Wno-nullability-completeness -optc-Wno-unknown-attributes 33 | 34 | executable reflex-native-draggy-uikit 35 | if !flag(uikit) || !os(ios) || impl(ghcjs) 36 | buildable: False 37 | default-language: Haskell2010 38 | hs-source-dirs: src-bin 39 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -optc-Wno-expansion-to-defined -optc-Wno-nullability-inferred-on-nested-type -optc-Wno-nullability-completeness-on-arrays -optc-Wno-nullability-completeness -optc-Wno-unknown-attributes 40 | main-is: uikit.hs 41 | build-depends: 42 | base 43 | , reflex-native 44 | , reflex-native-draggy 45 | , reflex-native-uikit 46 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/ViewStyle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | -- |Style parameters for all views. 4 | module Reflex.Native.ViewStyle 5 | ( ViewStyle(..), defaultInitialViewStyle, defaultModifyViewStyle 6 | ) where 7 | 8 | import Data.Functor.Identity (Identity(..)) 9 | import GHC.Generics (Generic) 10 | import qualified Rank2 11 | import Rank2 (apply) 12 | import Reflex.Class (Event, Reflex, never) 13 | import Reflex.Native.Color (Color, clear) 14 | 15 | 16 | -- |Style of displayed view parameterized over functor @f@. 17 | -- 18 | -- @f ~ Identity@ is used for initial view style where all parameters must be given, while @f ~ Event t@ is used for dynamic modification of view styles after 19 | data ViewStyle f = ViewStyle 20 | { _viewStyle_backgroundColor :: f Color 21 | -- ^Background color to draw the view with. 22 | } deriving (Generic) 23 | 24 | instance Rank2.Functor ViewStyle where 25 | f <$> ViewStyle a = ViewStyle (f a) 26 | instance Rank2.Apply ViewStyle where 27 | ViewStyle fa <*> ViewStyle a = ViewStyle (apply fa a) 28 | instance Rank2.Applicative ViewStyle where 29 | pure f = ViewStyle f 30 | instance Rank2.Foldable ViewStyle where 31 | foldMap f (ViewStyle a) = f a 32 | instance Rank2.Traversable ViewStyle where 33 | traverse f (ViewStyle a) = ViewStyle <$> f a 34 | 35 | -- |Default 'ViewStyle' for initial display of a view: a transparent background. 36 | defaultInitialViewStyle :: ViewStyle Identity 37 | defaultInitialViewStyle = ViewStyle 38 | { _viewStyle_backgroundColor = Identity clear 39 | } 40 | 41 | -- |Default 'ViewStyle' for dynamic update, where all parameters 'never' update. 42 | defaultModifyViewStyle :: Reflex t => ViewStyle (Event t) 43 | defaultModifyViewStyle = Rank2.pure never 44 | 45 | -------------------------------------------------------------------------------- /reflex-native/reflex-native.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-native 2 | version: 0.1.0.0 3 | synopsis: Cross platform layer for developing native Reflex apps 4 | description: Provides a cross platform API for developing Reflex apps that are true native with no web views or javascript runtimes 5 | author: Confer Health 6 | maintainer: oss@confer.health 7 | license: BSD3 8 | license-file: LICENSE 9 | build-type: Simple 10 | cabal-version: >= 1.10 11 | homepage: https://github.com/reflex-frp/reflex-native 12 | bug-reports: https://github.com/reflex-frp/reflex-native/issues 13 | 14 | library 15 | default-language: Haskell2010 16 | exposed-modules: 17 | Reflex.Native 18 | Reflex.Native.AdjustingBuilder 19 | Reflex.Native.Color 20 | Reflex.Native.Font 21 | Reflex.Native.Geometry 22 | Reflex.Native.Gesture 23 | Reflex.Native.TextConfig 24 | Reflex.Native.TextStyle 25 | Reflex.Native.Widget.Basic 26 | Reflex.Native.Widget.Customization 27 | Reflex.Native.ViewBuilder.Class 28 | Reflex.Native.ViewConfig 29 | Reflex.Native.ViewLayout 30 | Reflex.Native.ViewStyle 31 | hs-source-dirs: src 32 | ghc-options: 33 | -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo 34 | ghc-prof-options: -fprof-auto 35 | build-depends: 36 | base 37 | , containers == 0.5.* 38 | , dependent-map == 0.2.* 39 | , dependent-sum >= 0.3 && < 0.5 40 | , generic-lens == 1.0.* 41 | , lens == 4.16.* 42 | , mtl >= 2.1 && < 2.3 43 | , rank2classes == 1.1.* 44 | , ref-tf == 0.4.* 45 | , reflex 46 | , text == 1.2.* 47 | , transformers >= 0.3 && < 0.6 48 | , vector-space == 0.13.* 49 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/TextConfig.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | -- |Configuration of a text display view. 4 | module Reflex.Native.TextConfig 5 | ( TextConfig(..), defaultTextConfig 6 | ) where 7 | 8 | import Data.Functor.Identity (Identity) 9 | import Data.Maybe (Maybe(Nothing)) 10 | import Data.Text (Text) 11 | import GHC.Generics (Generic) 12 | import Reflex.Class (Event) 13 | import Reflex.Native.TextStyle (TextStyle, defaultInitialTextStyle) 14 | import Reflex.Native.ViewConfig (ViewConfig, defaultViewConfig) 15 | 16 | 17 | -- |Configuration of a text view using Reflex timeline @t@. 18 | data TextConfig t = TextConfig 19 | { _textConfig_initialText :: Text 20 | -- ^The initial text displayed which can be updated dynamically by providing a @_textConfig_setText@ @Event@. 21 | , _textConfig_setText :: Maybe (Event t Text) 22 | -- ^An @Event@ which updates the displayed text each time it fires. 23 | , _textConfig_initialStyle :: TextStyle Identity 24 | -- ^The initial 'TextStyle' to apply to the displayed text. 25 | , _textConfig_modifyStyle :: Maybe (TextStyle (Event t)) 26 | -- ^A 'TextStyle' where each parameter is an @Event@ which dynamically updates the associated style of the displayed text when it fires. 27 | , _textConfig_viewConfig :: ViewConfig t 28 | -- ^The general 'ViewConfig' for the view. 29 | } deriving (Generic) 30 | 31 | -- |Default text configuration which displays no text, has a default style, and never updates. 32 | defaultTextConfig :: TextConfig t 33 | defaultTextConfig = TextConfig 34 | { _textConfig_initialText = "" 35 | , _textConfig_setText = Nothing 36 | , _textConfig_initialStyle = defaultInitialTextStyle 37 | , _textConfig_modifyStyle = Nothing 38 | , _textConfig_viewConfig = defaultViewConfig 39 | } 40 | 41 | -------------------------------------------------------------------------------- /reflex-native-test/src/Reflex/Native/Test/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | -- |Convenient optics for writing tests, built up using @generic-lens@ optics. 4 | module Reflex.Native.Test.Optics 5 | ( 6 | -- * 'TestView' sum 7 | _Container, _Marker, _Text 8 | -- * 'TestContainerView' 9 | , container_contents, subviews 10 | -- * 'TestTextView' 11 | , text_text 12 | ) where 13 | 14 | import Control.Lens (Prism', Lens', Traversal', _Wrapped) 15 | import Data.Functor.Identity (Identity) 16 | import Data.Generics.Product (field) 17 | import Data.Generics.Sum (_Ctor) 18 | import Data.Sequence (Seq) 19 | import Data.Text (Text) 20 | import Reflex.Native.Test.Types (TestMarker, TestView(..), TestContainerView(..), TestTextView(..)) 21 | 22 | 23 | -- |Prism to select a 'TestContainerView' among the constructors of 'TestView' 24 | _Container :: Prism' (TestView v) (TestContainerView v) 25 | _Container = _Ctor @"TestView_Container" 26 | 27 | -- |Prism to select a 'TestMarker' among the constructors of 'TestView' 28 | _Marker :: Prism' (TestView v) TestMarker 29 | _Marker = _Ctor @"TestView_Marker" 30 | 31 | -- |Prism to select a 'TestTextView' among the constructors of 'TestView' 32 | _Text :: Prism' (TestView v) (TestTextView v) 33 | _Text = _Ctor @"TestView_Text" 34 | 35 | -- |Lens to a 'TestContainerView's contained views. 36 | container_contents :: Lens' (TestContainerView Identity) (Seq (TestView Identity)) 37 | container_contents = field @"_testContainerView_contents" . _Wrapped 38 | 39 | -- |Traversal to visit the contents of any targeted view which happens to be a container 40 | subviews :: Traversal' (TestView Identity) (Seq (TestView Identity)) 41 | subviews = _Container . container_contents 42 | 43 | -- |Lens to a 'TestTextView's text value. 44 | text_text :: Lens' (TestTextView Identity) Text 45 | text_text = field @"_testTextView_text" . _Wrapped 46 | -------------------------------------------------------------------------------- /hs-uikit/src/Foundation/NSMutableArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | -- |Class and instance methods of @NSMutableArray@ from @Foundation@. 4 | module Foundation.NSMutableArray 5 | ( 6 | -- * Class methods 7 | new 8 | -- * Instance methods 9 | , addObject 10 | , addObjectsFromArray 11 | -- * Raw bindings 12 | , nsMutableArray_new 13 | , nsMutableArray_addObject 14 | , nsMutableArray_addObjectsFromArray 15 | ) where 16 | 17 | import Control.Monad ((=<<)) 18 | import Foreign.Ptr (Ptr) 19 | import Foundation.Types (NSArrayType, NSMutableArray, NSMutableArrayType, asNSArray) 20 | import ObjC (ObjPtr, ObjType, SafeObjCoerce, retainObj, asObj, withObjPtr) 21 | 22 | 23 | -- |Raw FFI binding to @NSMutableArray + (NSMutableArray*)new@ 24 | foreign import ccall unsafe nsMutableArray_new :: IO (Ptr NSMutableArrayType) 25 | -- |@NSMutableArray + new@ - create a new mutable ObjC array. 26 | new :: IO NSMutableArray 27 | new = retainObj =<< nsMutableArray_new 28 | 29 | -- |Raw FFI binding to @NSMutableArray - addObject:@ 30 | foreign import ccall unsafe nsMutableArray_addObject :: Ptr NSMutableArrayType -> Ptr ObjType -> IO () 31 | -- |@NSMutableArray - addObject:@ - add an object to a mutable array. 32 | addObject :: SafeObjCoerce a ObjType => NSMutableArray -> ObjPtr a -> IO () 33 | addObject ao oo = 34 | withObjPtr ao $ \ a -> 35 | withObjPtr (asObj oo) $ \ o -> 36 | nsMutableArray_addObject a o 37 | 38 | -- |Raw FFI binding to @NSMutableArray - addObjectsFromArray:@ 39 | foreign import ccall unsafe nsMutableArray_addObjectsFromArray :: Ptr NSMutableArrayType -> Ptr NSArrayType -> IO () 40 | -- |@NSMutableArray - addObjectsFromArray 41 | addObjectsFromArray :: SafeObjCoerce array NSArrayType => NSMutableArray -> ObjPtr array -> IO () 42 | addObjectsFromArray mao ao = 43 | withObjPtr mao $ \ ma -> 44 | withObjPtr (asNSArray ao) $ \ a -> 45 | nsMutableArray_addObjectsFromArray ma a 46 | -------------------------------------------------------------------------------- /reflex-native-uikit/src/Reflex/UIKit/Style.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | -- |Functions for applying "Reflex.Native" style structures to UIKit views. 7 | module Reflex.UIKit.Style 8 | ( 9 | -- * Per-view-type functionality 10 | applyLabelStyle, applyViewStyle 11 | -- * Per-phase functionality (initial / modify) 12 | , initialStyle, modifyStyle 13 | ) where 14 | 15 | import Control.Monad (Monad, (<=<)) 16 | import Data.Functor.Identity (Identity(..)) 17 | import ObjC (ObjPtr, SafeObjCoerce) 18 | import Reflex (Event, Requester(type Request), requesting_) 19 | import Reflex.Native (TextStyle(..), ViewStyle(..)) 20 | import Reflex.UIKit.Conversions (makeUIColor, makeUIFont) 21 | import UIKit.Types (MainThread, UILabel, UIViewType) 22 | import qualified UIKit.UILabel as UILabel 23 | import qualified UIKit.UIView as UIView 24 | 25 | 26 | {-# INLINABLE applyLabelStyle #-} 27 | applyLabelStyle :: Monad m => (forall a. (a -> MainThread ()) -> f a -> m ()) -> UILabel -> TextStyle f -> m () 28 | applyLabelStyle f l (TextStyle {..}) = do 29 | f (UILabel.setTextColor l <=< makeUIColor) _textStyle_textColor 30 | f (UILabel.setFont l <=< makeUIFont) _textStyle_font 31 | 32 | {-# INLINABLE applyViewStyle #-} 33 | applyViewStyle :: (SafeObjCoerce v UIViewType, Monad m) => (forall a. (a -> MainThread ()) -> f a -> m ()) -> ObjPtr v -> ViewStyle f -> m () 34 | applyViewStyle f l (ViewStyle {..}) = do 35 | f (UIView.setBackgroundColor l <=< makeUIColor) _viewStyle_backgroundColor 36 | 37 | {-# INLINABLE initialStyle #-} 38 | initialStyle :: (a -> MainThread ()) -> Identity a -> MainThread () 39 | initialStyle action (Identity a) = action a 40 | 41 | {-# INLINABLE modifyStyle #-} 42 | modifyStyle :: (Requester t m, Request m ~ MainThread) => (a -> MainThread ()) -> Event t a -> m () 43 | modifyStyle action = requesting_ . fmap action 44 | -------------------------------------------------------------------------------- /reflex-native-uikit/reflex-native-uikit.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-native-uikit 2 | version: 0.1.0.0 3 | synopsis: Reflex FRP using UIKit directly, via hs-uikit 4 | description: Reflex view building and implementation of Reflex Native cross-platform interface for UIKit, allowing Reflex applications to be developed without use of DOM. 5 | author: Confer Health 6 | maintainer: oss@confer.health 7 | license: BSD3 8 | license-file: LICENSE 9 | build-type: Simple 10 | cabal-version: >= 1.10 11 | homepage: https://github.com/reflex-frp/reflex-native 12 | bug-reports: https://github.com/reflex-frp/reflex-native/issues 13 | 14 | library 15 | default-language: Haskell2010 16 | exposed-modules: 17 | Reflex.UIKit.Config 18 | Reflex.UIKit.Conversions 19 | Reflex.UIKit.Layout 20 | Reflex.UIKit.Main 21 | Reflex.UIKit.Specializations 22 | Reflex.UIKit.Style 23 | Reflex.UIKit.ViewBuilder 24 | hs-source-dirs: src 25 | ghc-options: 26 | -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo 27 | -optc-Wno-expansion-to-defined -optc-Wno-nullability-inferred-on-nested-type -optc-Wno-nullability-completeness-on-arrays 28 | -optc-Wno-nullability-completeness -optc-Wno-unknown-attributes 29 | ghc-prof-options: -fprof-auto 30 | cc-options: 31 | -Wno-expansion-to-defined -Wno-nullability-inferred-on-nested-type -Wno-nullability-completeness-on-arrays -Wno-nullability-completeness 32 | -Wno-unknown-attributes -fobjc-arc 33 | build-depends: 34 | base 35 | , containers == 0.5.* 36 | , dependent-map == 0.2.* 37 | , dependent-sum >= 0.3 && < 0.5 38 | , exception-transformers == 0.4.* 39 | , hs-uikit 40 | , mtl >= 2.1 && < 2.3 41 | , primitive >= 0.5 && < 0.7 42 | , ref-tf == 0.4.* 43 | , reflex 44 | , reflex-native 45 | , transformers >= 0.3 && < 0.6 46 | if os(ios) 47 | c-sources: 48 | cbits/UIKitViewBuilder.m 49 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/TextStyle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | -- |Style of displayed text. 4 | module Reflex.Native.TextStyle 5 | ( TextStyle(..), defaultInitialTextStyle, defaultModifyTextStyle 6 | ) where 7 | 8 | import Data.Functor.Identity (Identity(..)) 9 | import Data.Monoid ((<>)) 10 | import GHC.Generics (Generic) 11 | import qualified Rank2 12 | import Rank2 (apply) 13 | import Reflex.Class (Event, Reflex, never) 14 | import Reflex.Native.Color (Color, black) 15 | import Reflex.Native.Font (Font(..), Weight(..)) 16 | 17 | 18 | -- |Style of displayed text parameterized over functor @f@. 19 | -- 20 | -- @f ~ Identity@ is used for initial text style where all parameters must be given, while @f ~ Event t@ is used for dynamic modification of text styles after 21 | -- initial creation. 22 | data TextStyle v = TextStyle 23 | { _textStyle_textColor :: v Color 24 | -- ^The color to display the text with. 25 | , _textStyle_font :: v Font 26 | -- ^The font to display the text with. 27 | } deriving (Generic) 28 | 29 | instance Rank2.Functor TextStyle where 30 | f <$> TextStyle a b = TextStyle (f a) (f b) 31 | instance Rank2.Apply TextStyle where 32 | TextStyle fa fb <*> TextStyle a b = TextStyle (apply fa a) (apply fb b) 33 | instance Rank2.Applicative TextStyle where 34 | pure f = TextStyle f f 35 | instance Rank2.Foldable TextStyle where 36 | foldMap f (TextStyle a b) = f a <> f b 37 | instance Rank2.Traversable TextStyle where 38 | traverse f (TextStyle a b) = TextStyle <$> f a <*> f b 39 | 40 | -- |Default 'TextStyle' for initial display of some text: system font, 12 point, regular weight, and black color. 41 | defaultInitialTextStyle :: TextStyle Identity 42 | defaultInitialTextStyle = TextStyle 43 | { _textStyle_textColor = Identity black 44 | , _textStyle_font = Identity $ Font_System 12 Weight_Regular 45 | } 46 | 47 | -- |Default 'TextStyle' for dynamic update, where all parameters 'never' update. 48 | defaultModifyTextStyle :: Reflex t => TextStyle (Event t) 49 | defaultModifyTextStyle = Rank2.pure never 50 | 51 | -------------------------------------------------------------------------------- /reflex-native-uikit/src/Reflex/UIKit/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | -- |Functions for applying 'ViewConfig' settings to UIKit views. 6 | module Reflex.UIKit.Config where 7 | 8 | import Control.Monad ((=<<), (<=<)) 9 | import Control.Monad.IO.Class (liftIO) 10 | import Data.Foldable (for_) 11 | import Data.Traversable (traverse) 12 | import qualified Foundation.NSString as NSString 13 | import ObjC (SafeObjCoerce, ObjPtr, ObjType) 14 | import Reflex (Reflex, Requester(type Request), requesting_) 15 | import Reflex.Native (ViewConfig(..)) 16 | import Reflex.UIKit.Layout (applyLayout) 17 | import Reflex.UIKit.Style (applyViewStyle, initialStyle, modifyStyle) 18 | import UIKit.Types (MainThread, UIViewType) 19 | import qualified UIKit.UIAccessibility as UIAccessibility 20 | 21 | 22 | -- |Apply the initial settings of a 'ViewConfig' to the given view. 23 | {-# INLINABLE applyInitialViewConfig #-} 24 | applyInitialViewConfig :: (SafeObjCoerce v ObjType, SafeObjCoerce v UIViewType) => ObjPtr v -> ViewConfig t -> MainThread () 25 | applyInitialViewConfig v (ViewConfig {..}) = do 26 | applyViewStyle initialStyle v _viewConfig_initialStyle 27 | UIAccessibility.setAccessibilityLabel v =<< traverse (liftIO . NSString.fromText) _viewConfig_initialAccessibilityLabel 28 | applyLayout v _viewConfig_initialLayout 29 | 30 | -- |Apply updates from the @set@ settings of a 'ViewConfig' as the @Event@s fire, using a 'Requester'. 31 | {-# INLINABLE applyModifyViewConfig #-} 32 | applyModifyViewConfig 33 | :: (SafeObjCoerce v ObjType, SafeObjCoerce v UIViewType, Reflex t, Monad m, Requester t m, Request m ~ MainThread) 34 | => ObjPtr v -> ViewConfig t -> m () 35 | applyModifyViewConfig v (ViewConfig {..}) = do 36 | for_ _viewConfig_modifyStyle $ 37 | applyViewStyle modifyStyle v 38 | for_ _viewConfig_setAccessibilityLabel $ 39 | requesting_ . fmap (UIAccessibility.setAccessibilityLabel v <=< traverse (liftIO . NSString.fromText)) 40 | for_ _viewConfig_setLayout $ 41 | requesting_ . fmap (applyLayout v) 42 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIGestureRecognizer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- |Instance methods of @UIGestureRecognizer@ and related types. 3 | module UIKit.UIGestureRecognizer 4 | ( 5 | -- * Recognizer state 6 | UIGestureRecognizerState(..) 7 | -- * Instance methods 8 | , getState 9 | -- * Raw FFI bindings 10 | , uiGestureRecognizer_getState 11 | ) where 12 | 13 | import Foreign.C.Types (CInt(..)) 14 | import Foreign.Ptr (Ptr) 15 | import ObjC (ObjPtr, SafeObjCoerce, withObjPtr) 16 | import UIKit.Types (UIGestureRecognizerType, asUIGestureRecognizer) 17 | 18 | 19 | -- |Data type reflecting @UIGestureRecognizerState@ from UIKit which represents the various states of a gesture recognizer's state machine. 20 | data UIGestureRecognizerState -- Order matters to the ObjC code! 21 | = UIGestureRecognizerState_Possible 22 | -- ^The gesture could be recognized and the recognizer is waiting for events to trigger recognition. Idle and waiting, in other words. 23 | | UIGestureRecognizerState_Began 24 | -- ^The beginning of a continuous gesture was recognized. 25 | | UIGestureRecognizerState_Changed 26 | -- ^A continuous gesture previously recognized has continued and its parameters changed. 27 | | UIGestureRecognizerState_Ended 28 | -- ^A continuous gesture previously recognized has ended or a discrete gesture was recognized. 29 | | UIGestureRecognizerState_Cancelled 30 | -- ^A continuous gesture previously recognized has been cancelled. 31 | | UIGestureRecognizerState_Failed 32 | -- ^The recognizer received a touch sequence that it can't recognize. 33 | deriving (Bounded, Enum, Eq, Ord, Show) 34 | 35 | -- |Raw FFI binding to @UIGestureRecognizer - getState@. 36 | foreign import ccall unsafe uiGestureRecognizer_getState :: Ptr UIGestureRecognizerType -> IO CInt 37 | -- |@UIGestureRecognizer - getState@ - get the current state of a 'UIGestureRecognizer'. 38 | getState :: SafeObjCoerce recognizer UIGestureRecognizerType => ObjPtr recognizer -> IO UIGestureRecognizerState 39 | getState ro = 40 | withObjPtr (asUIGestureRecognizer ro) $ \ r -> 41 | toEnum . fromIntegral <$> uiGestureRecognizer_getState r 42 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UILabel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- |Class and instance methods of the @UILabel@ class. 3 | module UIKit.UILabel 4 | ( 5 | -- * Class methods 6 | new 7 | -- * Instance methods 8 | , setFont, setText, setTextColor 9 | -- * Raw FFI bindings 10 | , uiLabel_new, uiLabel_setFont, uiLabel_setText, uiLabel_setTextColor 11 | ) where 12 | 13 | import Control.Monad ((=<<)) 14 | import Foreign.Ptr (Ptr) 15 | import Foundation.Types (NSString, NSStringType) 16 | import ObjC (retainObj, withObjPtr) 17 | import UIKit.Types (MainThread(..), UIColor, UIColorType, UIFont, UIFontType, UILabel, UILabelType) 18 | 19 | 20 | -- |Raw FFI binding to @UILabel + new@ 21 | foreign import ccall unsafe uiLabel_new :: MainThread (Ptr UILabelType) 22 | -- |Create a new 'UILabel' with the default settings. 23 | new :: MainThread UILabel 24 | new = retainObj =<< uiLabel_new 25 | 26 | -- |Raw FFI binding to @UILabel - setFont:@ 27 | foreign import ccall unsafe uiLabel_setFont :: Ptr UILabelType -> Ptr UIFontType -> MainThread () 28 | -- |@UILabel - setFont:@ - set the font of the label, overriding any font information given in string attributes if any. 29 | setFont :: UILabel -> UIFont -> MainThread () 30 | setFont lo fo = 31 | withObjPtr lo $ \ l -> 32 | withObjPtr fo $ \ f -> 33 | uiLabel_setFont l f 34 | 35 | -- |Raw FFI binding to @UILabel - setText:@ 36 | foreign import ccall unsafe uiLabel_setText :: Ptr UILabelType -> Ptr NSStringType -> MainThread () 37 | -- |@UILabel - setText:@ - set the text rendered by the label. 38 | setText :: UILabel -> NSString -> MainThread () 39 | setText lo so = 40 | withObjPtr lo $ \ l -> 41 | withObjPtr so $ \ s -> 42 | uiLabel_setText l s 43 | 44 | -- |Raw FFI binding to @UILabel - setTextColor:@ 45 | foreign import ccall unsafe uiLabel_setTextColor :: Ptr UILabelType -> Ptr UIColorType -> MainThread () 46 | -- |@UILabel - setTextColor:@ - set the color of the label's text, overriding any color information given in the string attributes if any. 47 | setTextColor :: UILabel -> UIColor -> MainThread () 48 | setTextColor lo co = 49 | withObjPtr lo $ \ l -> 50 | withObjPtr co $ \ c -> 51 | uiLabel_setTextColor l c 52 | 53 | -------------------------------------------------------------------------------- /hs-uikit/src/Foundation/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | -- |Types from the @Foundation@ framework, in the @NS@ "namespace". 4 | module Foundation.Types 5 | ( 6 | -- * Pointer types 7 | NSArray 8 | , NSDictionary 9 | , NSMutableArray 10 | , NSString 11 | -- * Pointer type coercions 12 | , asNSArray 13 | -- * Type tokens 14 | , NSArrayType 15 | , NSDictionaryType 16 | , NSMutableArrayType 17 | , NSStringType 18 | ) where 19 | 20 | import ObjC (ObjPtr, ObjType, SafeObjCoerce, coerceObj) 21 | 22 | 23 | -- |Safely coerce a pointer to an 'NSArray' pointer. See 'SafeObjCoerce'. 24 | asNSArray :: SafeObjCoerce a NSArrayType => ObjPtr a -> NSArray 25 | asNSArray = coerceObj 26 | 27 | -- |Type token representing the @NSArray@ class. 28 | data NSArrayType 29 | -- |Pointer to an instance of @NSArray@, ObjC's "immutable" array type. Note that @NSMutableArray@ extends from @NSArray@ and thus a mutable array can be 30 | -- safely coerced to an "immutable" one, and modifications are visible. 31 | type NSArray = ObjPtr NSArrayType 32 | instance SafeObjCoerce NSArrayType ObjType 33 | 34 | -- |Type token representing the @NSDictionary@ class. 35 | data NSDictionaryType 36 | -- |Pointer to an instance of @NSDictionary@, ObjC's "immutable" dictionary (key/value mapping) type. Note that @NSMutableDictionary@ extends from 37 | -- @NSDictionary@ and thus a mutable dictionary can be safely coerced to an "immutable" one, and modifications are visible. 38 | type NSDictionary = ObjPtr NSDictionaryType 39 | instance SafeObjCoerce NSDictionaryType ObjType 40 | 41 | -- |Type token representing the @NSMutableArray@ class. 42 | data NSMutableArrayType 43 | -- |Pointer to an instance of @NSMutableArray@, ObjC's mutable array type. 44 | type NSMutableArray = ObjPtr NSMutableArrayType 45 | instance SafeObjCoerce NSMutableArrayType ObjType 46 | instance SafeObjCoerce NSMutableArrayType NSArrayType 47 | 48 | -- |Type token representing the @NSString@ class. 49 | data NSStringType 50 | -- |Pointer to an instance of @NSString@, ObjC's UTF-16 character string type. 51 | type NSString = ObjPtr NSStringType 52 | instance SafeObjCoerce NSStringType ObjType 53 | 54 | 55 | -------------------------------------------------------------------------------- /examples/draggy/src/Reflex/Native/Examples/Draggy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecursiveDo #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | module Reflex.Native.Examples.Draggy where 10 | 11 | import Data.AdditiveGroup ((^+^), zeroV) 12 | import Data.Functor (($>)) 13 | import Data.Maybe (Maybe(Just, Nothing)) 14 | import Data.Monoid ((<>)) 15 | import Reflex (attachWith, current, ffor, fforMaybeCheap, fmapMaybeCheap, getPostBuild, holdDyn, zipDynWith) 16 | import Reflex.Native 17 | ( MonadNative, ViewBuilder(type ViewBuilderSpace, recognizeGesture, wrapRawView), ViewSpace(type RawView) 18 | , containerWith, textWith_, accessibilityLabel, backgroundColor, dynLayout, layout 19 | , GestureSpec(..), GestureState(..), PanGesture(..), _gestureState_data 20 | , Point(..), Rect(..), Size(..), lightGray, darkGray 21 | , RawViewConfig(..), defaultRawViewConfig 22 | , ViewLayout(..) 23 | , ViewStyle(..), defaultModifyViewStyle 24 | ) 25 | 26 | 27 | main :: forall t m. MonadNative t m => RawView (ViewBuilderSpace m) -> m () 28 | main rootRawView = do 29 | pb <- getPostBuild 30 | let rootViewConfig = defaultRawViewConfig 31 | { _rawViewConfig_modifyStyle = Just $ (defaultModifyViewStyle @t) 32 | { _viewStyle_backgroundColor = pb $> lightGray } 33 | } 34 | _rootView <- wrapRawView rootRawView rootViewConfig 35 | 36 | rec 37 | let pos0 = Point 10 10 38 | layoutDyn = ffor pos $ \ p -> ViewLayout_Fixed (Rect p (Size 100 100)) 39 | (_, vn) <- containerWith (backgroundColor darkGray <> dynLayout layoutDyn <> accessibilityLabel "test view") $ do 40 | textWith_ (layout (ViewLayout_Fixed (Rect (Point 0 0) (Size 100 100)))) "drag me!" 41 | panState <- recognizeGesture vn GestureSpec_Pan 42 | lastStartPos <- holdDyn pos0 $ attachWith const (current pos) $ fforMaybeCheap panState $ \ case 43 | GestureState_Began _ -> Just () 44 | _ -> Nothing 45 | lastDragTranslation <- holdDyn zeroV $ fmapMaybeCheap (fmap _panGesture_translation . _gestureState_data) panState 46 | let pos = zipDynWith (^+^) lastStartPos lastDragTranslation 47 | 48 | pure () 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /reflex-native-test/reflex-native-test.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-native-test 2 | version: 0.1.0.0 3 | synopsis: Unit testing for reflex-native UI components 4 | description: Provides a test harness and headless test view builder for testing of UI components written for Reflex Native, and includes the test suite for 5 | the Reflex Native adjusting builder. 6 | author: Confer Health 7 | maintainer: oss@confer.health 8 | license: BSD3 9 | license-file: LICENSE 10 | build-type: Simple 11 | cabal-version: >= 1.10 12 | homepage: https://github.com/reflex-frp/reflex-native 13 | bug-reports: https://github.com/reflex-frp/reflex-native/issues 14 | 15 | library 16 | default-language: Haskell2010 17 | exposed-modules: 18 | Reflex.Native.Test 19 | Reflex.Native.Test.Evaluation 20 | Reflex.Native.Test.Optics 21 | Reflex.Native.Test.Runner 22 | Reflex.Native.Test.Types 23 | Reflex.Native.Test.ViewBuilder 24 | hs-source-dirs: src 25 | ghc-options: 26 | -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo 27 | ghc-prof-options: -fprof-auto 28 | build-depends: 29 | base 30 | , containers == 0.5.* 31 | , dependent-map == 0.2.* 32 | , dependent-sum >= 0.3 && < 0.5 33 | , dlist == 0.8.* 34 | , exception-transformers == 0.4.* 35 | , generic-lens == 1.0.* 36 | , hspec-expectations == 0.8.* 37 | , lens == 4.16.* 38 | , lifted-base == 0.2.* 39 | , monad-control == 1.0.* 40 | , mtl >= 2.1 && < 2.3 41 | , primitive >= 0.5 && < 0.7 42 | , rank2classes == 1.1.* 43 | , ref-tf == 0.4.* 44 | , reflex 45 | , reflex-native 46 | , stm == 2.4.* 47 | , text == 1.2.* 48 | , transformers >= 0.3 && < 0.6 49 | , transformers-base == 0.4.* 50 | , vector-space == 0.13.* 51 | 52 | test-suite TestViewBuilderSuite 53 | type: exitcode-stdio-1.0 54 | main-is: TestViewBuilderSuite.hs 55 | hs-source-dirs: test 56 | default-language: Haskell2010 57 | ghc-options: -O2 -Wall -rtsopts -liconv 58 | build-depends: 59 | base 60 | , containers == 0.5.* 61 | , dependent-map == 0.2.* 62 | , dependent-sum >= 0.3 && < 0.5 63 | , hspec == 2.5.* 64 | , hspec-expectations == 0.8.* 65 | , lens == 4.16.* 66 | , reflex 67 | , reflex-native 68 | , reflex-native-test 69 | , text == 1.2.* 70 | -------------------------------------------------------------------------------- /reflex-native-uikit/cbits/UIKitViewBuilder.m: -------------------------------------------------------------------------------- 1 | #import 2 | #import "HsFFI.h" 3 | 4 | UIView* uikitViewBuilder_newHolderView() { 5 | UIView* v = [[UIView alloc] initWithFrame:CGRectZero]; 6 | v.backgroundColor = [UIColor clearColor]; 7 | v.opaque = NO; 8 | v.userInteractionEnabled = NO; 9 | return v; 10 | } 11 | 12 | UIView* uikitViewBuilder_newMarkerView() { 13 | UIView* v = [[UIView alloc] initWithFrame:CGRectZero]; 14 | v.backgroundColor = [UIColor clearColor]; 15 | v.opaque = NO; 16 | v.userInteractionEnabled = NO; 17 | return v; 18 | } 19 | 20 | UIView* uikitViewBuilder_collectViewsBetween(UIView* start, UIView* end) { 21 | UIView* holder = uikitViewBuilder_newHolderView(); 22 | UIView* parent = start.superview; 23 | NSArray* subviews = parent.subviews; 24 | NSUInteger limit = subviews.count; 25 | BOOL inRange = NO; 26 | for (NSUInteger i = 0; i < limit; ++i) { 27 | UIView* subview = [subviews objectAtIndex:i]; 28 | if (inRange) { 29 | if (subview == end) { 30 | return holder; 31 | } else { 32 | [holder addSubview:subview]; 33 | } 34 | } else { 35 | if (subview == start) { 36 | inRange = YES; 37 | } 38 | } 39 | } 40 | return holder; 41 | } 42 | 43 | void uikitViewBuilder_deleteViewsBetween(UIView* start, UIView* end) { 44 | UIView* parent = start.superview; 45 | NSArray* subviews = parent.subviews; 46 | NSUInteger limit = subviews.count; 47 | BOOL inRange = NO; 48 | for (NSUInteger i = 0; i < limit; ++i) { 49 | UIView* subview = [subviews objectAtIndex:i]; 50 | if (inRange) { 51 | if (subview == end) { 52 | return; 53 | } else { 54 | [subview removeFromSuperview]; 55 | } 56 | } else { 57 | if (subview == start) { 58 | inRange = YES; 59 | } 60 | } 61 | } 62 | } 63 | 64 | void uikitViewBuilder_replaceBetweenMarkersWithHolder(UIView* start, UIView* end, UIView* holder) { 65 | uikitViewBuilder_deleteViewsBetween(start, end); 66 | UIView* parent = start.superview; 67 | for (UIView* subview in holder.subviews) { 68 | [parent insertSubview:subview belowSubview:end]; 69 | } 70 | } 71 | 72 | void uikitViewBuilder_insertMarkerBeforeMarker(UIView* marker, UIView* beforeMarker) { 73 | [beforeMarker.superview insertSubview:marker belowSubview:beforeMarker]; 74 | } 75 | 76 | void uikitViewBuilder_addSubviewsFromHolder(UIView* parent, UIView* holder) { 77 | for (UIView* subview in holder.subviews) { 78 | [parent addSubview:subview]; 79 | } 80 | } 81 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIPanGestureRecognizer.hs: -------------------------------------------------------------------------------- 1 | -- |Class and instance methods of the @UIPanGestureRecognizer@ class. 2 | module UIKit.UIPanGestureRecognizer 3 | ( 4 | -- * Class methods 5 | new 6 | -- * Instance methods 7 | , getTranslationInSuperview, getVelocityInSuperview 8 | -- * Raw FFI bindings 9 | , uiPanGestureRecognizer_new, uiPanGestureRecognizer_getTranslationInSuperview, uiPanGestureRecognizer_getVelocityInSuperview 10 | ) where 11 | 12 | import Control.Monad ((=<<)) 13 | import CoreGraphics (CGPoint) 14 | import Foreign.Marshal.Alloc (alloca) 15 | import Foreign.Ptr (Ptr) 16 | import Foreign.Storable (peek) 17 | import ObjC (Obj, ObjType, retainObj, withObjPtr) 18 | import UIKit.Types (UIPanGestureRecognizer, UIPanGestureRecognizerType) 19 | 20 | 21 | -- |Raw FFI binding to @UIPanGestureRecognizer + new@ 22 | foreign import ccall unsafe uiPanGestureRecognizer_new :: Ptr ObjType -> IO (Ptr UIPanGestureRecognizerType) 23 | -- |Create a new 'UIPanGestureRecognizer' with the given target object. The target action is always configured as @handler:@. 24 | new :: Obj -> IO UIPanGestureRecognizer 25 | new oo = 26 | withObjPtr oo $ \ o -> 27 | retainObj =<< uiPanGestureRecognizer_new o 28 | 29 | -- |Raw FFI binding to @UIPanGestureRecognizer - getTranslationInView:@ with the view given always the superview of the recognizer's associated view. 30 | foreign import ccall unsafe uiPanGestureRecognizer_getTranslationInSuperview :: Ptr UIPanGestureRecognizerType -> Ptr CGPoint -> IO () 31 | -- |Get the translation recognized by the 'UIPanGestureRecognizer' since the recognizer began recognizing the current gesture expressed in the superview of the 32 | -- recognizer's associated view. 33 | getTranslationInSuperview :: UIPanGestureRecognizer -> IO CGPoint 34 | getTranslationInSuperview ro = 35 | withObjPtr ro $ \ r -> 36 | alloca $ \ ptr -> do 37 | uiPanGestureRecognizer_getTranslationInSuperview r ptr 38 | peek ptr 39 | 40 | -- |Raw FFI binding to @UIPanGestureRecognizer - getVelocityInView:@ with the view given always the superview of the recognizer's associated view. 41 | foreign import ccall unsafe uiPanGestureRecognizer_getVelocityInSuperview :: Ptr UIPanGestureRecognizerType -> Ptr CGPoint -> IO () 42 | -- |Get the velocity recognized by the 'UIPanGestureRecognizer' since the recognizer began recognizing the current gesture expressed in the superview of the 43 | -- recognizer's associated view. 44 | getVelocityInSuperview :: UIPanGestureRecognizer -> IO CGPoint 45 | getVelocityInSuperview ro = 46 | withObjPtr ro $ \ r -> 47 | alloca $ \ ptr -> do 48 | uiPanGestureRecognizer_getVelocityInSuperview r ptr 49 | peek ptr 50 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/Color.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- |Cross-platform notion of colors. 3 | module Reflex.Native.Color 4 | ( 5 | -- * @Color@ type 6 | Color(..) 7 | -- * @Color@ constants and constructors 8 | , gray, black, red, green, blue, yellow, cyan, magenta, lightGray, darkGray, white, clear 9 | ) where 10 | 11 | import Text.Show (showString) 12 | 13 | 14 | -- |Color represented in RGB with an alpha component. Each component should be in the range [0.0 .. 1.0]; values outside of this range are undefined but 15 | -- probably act like their nearest bound. 16 | data Color = Color 17 | { _color_red :: {-# UNPACK #-} !Double 18 | -- ^The red value of the color from 0.0 to 1.0 inclusive. 19 | , _color_green :: {-# UNPACK #-} !Double 20 | -- ^The green value of the color from 0.0 to 1.0 inclusive. 21 | , _color_blue :: {-# UNPACK #-} !Double 22 | -- ^The blue value of the color from 0.0 to 1.0 inclusive. 23 | , _color_alpha :: {-# UNPACK #-} !Double 24 | -- ^The alpha value of the color from 0.0 to 1.0 inclusive. 25 | } deriving (Eq) 26 | 27 | -- |Show a 'Color' as @rgba(r,g,b,a)@. 28 | instance Show Color where 29 | showsPrec _ (Color {..}) 30 | = showString "rgba(" 31 | . shows _color_red . (',':) 32 | . shows _color_green . (',':) 33 | . shows _color_blue . (',':) 34 | . shows _color_alpha 35 | . (')':) 36 | 37 | -- |Construct a neutral gray of the given saturation (0.0 being black and 1.0 being white) and alpha component. 38 | gray :: Double -> Double -> Color 39 | gray value alpha = Color value value value alpha 40 | 41 | -- |Opaque black. 42 | black :: Color 43 | black = Color 0 0 0 1 44 | 45 | -- |Primary opaque blue. 46 | blue :: Color 47 | blue = Color 0 0 1 1 48 | 49 | -- |Completely transparent black (i.e. alpha of 0.0) 50 | clear :: Color 51 | clear = Color 0 0 0 0 52 | 53 | -- |Primary opaque cyan (green and blue combined equally). 54 | cyan :: Color 55 | cyan = Color 0 1 1 1 56 | 57 | -- |Opaque light gray, equivalent to @'gray' (1/3) 1@ 58 | darkGray :: Color 59 | darkGray = gray (1/3) 1 60 | 61 | -- |Primary opaque green. 62 | green :: Color 63 | green = Color 0 1 0 1 64 | 65 | -- |Opaque light gray, equivalent to @'gray' (2/3) 1@ 66 | lightGray :: Color 67 | lightGray = gray (2/3) 1 68 | 69 | -- |Primary opaque magenta (red and blue combined equally). 70 | magenta :: Color 71 | magenta = Color 1 0 1 1 72 | 73 | -- |Primary opaque red. 74 | red :: Color 75 | red = Color 1 0 0 1 76 | 77 | -- |Primary opaque white. 78 | white :: Color 79 | white = Color 1 1 1 1 80 | 81 | -- |Primary opaque yellow (red and green combined equally). 82 | yellow :: Color 83 | yellow = Color 1 1 0 1 84 | 85 | -------------------------------------------------------------------------------- /hs-uikit/hs-uikit.cabal: -------------------------------------------------------------------------------- 1 | name: hs-uikit 2 | version: 0.1.0.0 3 | synopsis: Bindings to UIKit 4 | description: FFI bindings for UIKit, Foundation, CoreGraphics, etc. 5 | author: Confer Health 6 | maintainer: oss@confer.health 7 | license: BSD3 8 | license-file: LICENSE 9 | build-type: Simple 10 | cabal-version: >= 1.10 11 | homepage: https://github.com/reflex-frp/reflex-native 12 | bug-reports: https://github.com/reflex-frp/reflex-native/issues 13 | 14 | library 15 | default-language: Haskell2010 16 | exposed-modules: 17 | CoreAnimation 18 | CoreGraphics 19 | Foundation 20 | Foundation.NSMutableArray 21 | Foundation.NSString 22 | Foundation.Types 23 | ObjC 24 | UIKit 25 | UIKit.Generic.AppDelegate 26 | UIKit.Generic.GestureRecognizerTarget 27 | UIKit.Generic.View 28 | UIKit.Generic.ViewController 29 | UIKit.Types 30 | UIKit.UIAccessibility 31 | UIKit.UIColor 32 | UIKit.UIFont 33 | UIKit.UIGestureRecognizer 34 | UIKit.UILabel 35 | UIKit.UIPanGestureRecognizer 36 | UIKit.UIView 37 | UIKit.UIViewController 38 | UIKit.UIWindow 39 | hs-source-dirs: src 40 | ghc-options: 41 | -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo 42 | -optc-Wno-expansion-to-defined -optc-Wno-nullability-inferred-on-nested-type -optc-Wno-nullability-completeness-on-arrays 43 | -optc-Wno-nullability-completeness -optc-Wno-unknown-attributes 44 | ghc-prof-options: -fprof-auto 45 | cc-options: 46 | -Wno-expansion-to-defined -Wno-nullability-inferred-on-nested-type -Wno-nullability-completeness-on-arrays -Wno-nullability-completeness 47 | -Wno-unknown-attributes -fobjc-arc 48 | build-depends: 49 | base 50 | , monad-control == 1.0.* 51 | , text == 1.2.* 52 | , transformers-base == 0.4.* 53 | if os(ios) 54 | c-sources: 55 | cbits/GenericAppDelegate.m 56 | cbits/GenericGestureRecognizerTarget.m 57 | cbits/GenericView.m 58 | cbits/GenericViewController.m 59 | cbits/MainThread.m 60 | cbits/NSMutableArrayMethods.m 61 | cbits/NSStringMethods.m 62 | cbits/ObjCMethods.m 63 | cbits/UIAccessibilityMethods.m 64 | cbits/UIColorMethods.m 65 | cbits/UIFontMethods.m 66 | cbits/UIGestureRecognizerMethods.m 67 | cbits/UILabelMethods.m 68 | cbits/UIPanGestureRecognizerMethods.m 69 | cbits/UIViewControllerMethods.m 70 | cbits/UIViewMethods.m 71 | cbits/UIWindowMethods.m 72 | frameworks: 73 | CoreGraphics 74 | Foundation 75 | QuartzCore 76 | UIKit 77 | 78 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/Geometry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE ExplicitNamespaces #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | -- |Cross-platform notions of geometry, such as points and rectangles. 6 | module Reflex.Native.Geometry 7 | ( Point(..), Size(..), Rect(..) ) where 8 | 9 | import Data.AdditiveGroup (AdditiveGroup(zeroV, (^+^), negateV, (^-^))) 10 | import Data.VectorSpace (VectorSpace(type Scalar, (*^))) 11 | import GHC.Generics (Generic) 12 | 13 | 14 | -- |2D point represented as X and Y coordinates given as @Double@s. 15 | -- 16 | -- Uses the typical computer graphics flipped cartesian system, i.e. positive X towards the right and positive Y downwards. 17 | data Point = Point 18 | { _point_x :: !Double 19 | , _point_y :: !Double 20 | } deriving (Eq, Generic) 21 | 22 | -- |Show a 'Point' as @(x,y)@ 23 | instance Show Point where 24 | showsPrec _ (Point {..}) 25 | = ('(':) 26 | . shows _point_x . (',':) 27 | . shows _point_y . (')':) 28 | 29 | -- |Points form an additive group by distribution, e.g. @Point x1 y1 ^+^ Point x2 y2 == Point (x1 ^+^ x2) (y1 ^+^ y2)@. 30 | instance AdditiveGroup Point where 31 | zeroV = Point 0 0 32 | negateV (Point x y) = Point (negate x) (negate y) 33 | Point x1 y1 ^+^ Point x2 y2 = Point (x1 + x2) (y1 + y2) 34 | Point x1 y1 ^-^ Point x2 y2 = Point (x1 - x2) (y1 - y2) 35 | 36 | -- |Points form a vector space with the scalar being a @Double@, e.g. @f *^ Point x y == Point (f *^ x) (f *^ y)@. 37 | instance VectorSpace Point where 38 | type Scalar Point = Double 39 | f *^ Point x y = Point (x*f) (y*f) 40 | 41 | -- |2D size represented as width and height dimensions given as @Double@s. 42 | data Size = Size 43 | { _size_width :: !Double 44 | , _size_height :: !Double 45 | } deriving (Eq, Generic) 46 | 47 | -- |Show a 'Size' as @(wxh)@. 48 | instance Show Size where 49 | showsPrec _ (Size {..}) 50 | = ('(':) 51 | . shows _size_width . ('x':) 52 | . shows _size_height . (')':) 53 | 54 | -- |Sizes form an additive group by distribution, e.g. @Size w1 h1 ^+^ Size w2 h2 == Size (w1 ^+^ w2) (h1 ^+^ h2)@. 55 | instance AdditiveGroup Size where 56 | zeroV = Size 0 0 57 | negateV (Size x y) = Size (negate x) (negate y) 58 | Size x1 y1 ^+^ Size x2 y2 = Size (x1 + x2) (y1 + y2) 59 | Size x1 y1 ^-^ Size x2 y2 = Size (x1 - x2) (y1 - y2) 60 | 61 | -- |Sizes form a vector space with the scalar being a @Double@, e.g. @f *^ Size w h == Size (f *^ w) (f *^ h)@. 62 | instance VectorSpace Size where 63 | type Scalar Size = Double 64 | f *^ Size w h = Size (w*f) (h*f) 65 | 66 | -- |2D rectangles represented by an origin point and a size. 67 | data Rect = Rect 68 | { _rect_origin :: !Point 69 | , _rect_size :: !Size 70 | } deriving (Eq, Generic) 71 | 72 | -- |Show a 'Rect' as @(x,y)+(wxh)@ 73 | instance Show Rect where 74 | showsPrec _ (Rect {..}) = shows _rect_origin . ('+':) . shows _rect_size 75 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL := /bin/bash 2 | 3 | platforms = host ios android 4 | bash = $(shell nix-instantiate --eval -E '(import {}).bash + /bin/bash') 5 | cabal_files = $(shell find . -type f -a -name '*.cabal' | grep -v '^[.]/_build' | grep -v '^[.]/[.]') 6 | nix_files = default.nix $(shell find . -type f -a -name default.nix | grep -v '^[.]/_build' | grep -v '^[.]/[.]') 7 | 8 | # this sed hackery is here to work around a shortcoming with cabal new-build where error and warning messages get output with paths that are relative to the 9 | # package being built, not the project root, and so vim (or similar) which try to parse those messages to allow quick navigation to the source line get 10 | # bamboozled. 11 | 12 | .PHONY: all clean $(platforms) 13 | 14 | host: _build/host/shell host.project 15 | set -eo pipefail ; env -i $(bash) _build/host/shell cabal --project-file=host.project --builddir=_build/host/dist new-build hs-uikit 2>&1 | sed -e 's,^src/,hs-uikit/src/,g' 16 | set -eo pipefail ; env -i $(bash) _build/host/shell cabal --project-file=host.project --builddir=_build/host/dist new-build reflex-native 2>&1 | sed -e 's,^src/,reflex-native/src/,g' 17 | set -eo pipefail ; env -i $(bash) _build/host/shell cabal --project-file=host.project --builddir=_build/host/dist new-build reflex-native-test 2>&1 | sed -e 's,^src/,reflex-native-test/src/,g' 18 | set -eo pipefail ; env -i $(bash) _build/host/shell cabal --project-file=host.project --builddir=_build/host/dist new-build reflex-native-draggy 2>&1 | sed -e 's,^src/,examples/draggy/src/,g' 19 | set -eo pipefail ; env -i $(bash) _build/host/shell cabal --project-file=host.project --builddir=_build/host/dist new-test reflex-native-test 2>&1 | sed -e 's,^test/,reflex-native-test/test/,g' 20 | set -eo pipefail ; env -i $(bash) _build/host/shell cabal --project-file=host.project --builddir=_build/host/dist new-test reflex-native-draggy 2>&1 | sed -e 's,^test/,examples/draggy/test/,g' 21 | 22 | ios: _build/ios/shell ios.project 23 | set -eo pipefail ; env -i $(bash) _build/ios/shell cabal --project-file=ios.project --builddir=_build/ios/dist new-build hs-uikit 2>&1 | sed -e 's,^src/,hs-uikit/src/,g' 24 | set -eo pipefail ; env -i $(bash) _build/ios/shell cabal --project-file=ios.project --builddir=_build/ios/dist new-build reflex-native 2>&1 | sed -e 's,^src/,reflex-native/src/,g' 25 | set -eo pipefail ; env -i $(bash) _build/ios/shell cabal --project-file=ios.project --builddir=_build/ios/dist new-build reflex-native-draggy 2>&1 | sed -e 's,^src/,examples/draggy/src/,g' 26 | 27 | clean: 28 | rm -rf _build 29 | 30 | all: $(platforms) 31 | 32 | _build/%/shell: $(nix_files) $(cabal_files) 33 | mkdir -p $(dir $@) 34 | mkdir -p _build/$*/nix-root 35 | rm -f $@ 36 | nix-shell --pure --add-root _build/$*/nix-root/nix-gc-root --indirect -A shells.$* --run 'declare -p | grep -v -E "^declare( -[^ ]* )?(BASH_[^=]*|BASHOPTS|BASHPID|EUID|GROUPS|PPID|SHELLOPTS|UID)="' > $@ 37 | echo 'runHook shellHook' >> $@ 38 | echo '"$$@"' >> $@ 39 | echo 'exit $$?' >> $@ 40 | chmod +x $@ 41 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/Gesture.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | -- |Cross-platform notion of gestures and recognition thereof. 8 | module Reflex.Native.Gesture 9 | ( 10 | -- * Gesture types and recognition parameters 11 | GestureType(..), GestureSpec(..) 12 | -- * Recognition states and data 13 | , GestureData, PanGesture(..), GestureState(..), _gestureState_data 14 | ) where 15 | 16 | import Data.Maybe (Maybe(Just, Nothing)) 17 | import Reflex.Native.Geometry (Point) 18 | 19 | 20 | -- |Represents the types of gesture that can be recognized. Typically used as a kind via @DataKinds@. 21 | data GestureType 22 | = GestureType_Pan 23 | -- ^Pan (or drag) gestures where a touch starts and is moved while being held. Continuous. 24 | deriving (Eq, Show) 25 | 26 | -- |Specification of recognition parameters for each 'GestureType' 27 | data GestureSpec (gt :: GestureType) where 28 | GestureSpec_Pan :: GestureSpec 'GestureType_Pan 29 | 30 | -- |Type family mapping 'GestureType' to data for the recognized gesture. 31 | type family GestureData (gt :: GestureType) where 32 | GestureData 'GestureType_Pan = PanGesture 33 | 34 | -- |Data about a pan gesture ('GestureType_Pan' / 'GestureSpec_Pan') in progress. 35 | data PanGesture = PanGesture 36 | { _panGesture_translation :: {-# UNPACK #-} !Point -- FIXME the "relative to began state" thing is obnoxious. 37 | -- ^Translation of the pan gesture currently. Only useful in relation to the translation reported with 'GestureState_Began'. 38 | , _panGesture_velocity :: {-# UNPACK #-} !Point 39 | -- ^Velocity of the pan gesture currently. 40 | } deriving (Eq, Show) 41 | 42 | -- |State of a gesture, from not recognized (@GestureState_None@) through various states of recognition. 43 | -- 44 | -- Gestures are either discrete where they immediately go from @GestureState_None@ to @GestureState_Ended@, or continuous where they go through the full range 45 | -- of states. 46 | data GestureState a 47 | = GestureState_None 48 | -- ^The gesture is not presently recognized to be occurring. 49 | | GestureState_Began a 50 | -- ^The continuous gesture has just been recognized. 51 | | GestureState_Changed a 52 | -- ^The continuous gesture has changed but not yet ended. 53 | | GestureState_Ended a 54 | -- ^The discrete gesture was recognized or the continuous gesture finished. 55 | | GestureState_Cancelled 56 | -- ^The continuous gesture was cancelled after beginning. 57 | deriving (Eq, Functor, Show) 58 | 59 | -- |Project the gesture data @a@ from a @GestureState a@ if it's holding gesture data (i.e. is @GestureState_Began@, @GestureState_Changed@, or 60 | -- @GestureState_Ended@). 61 | _gestureState_data :: GestureState a -> Maybe a 62 | _gestureState_data = \ case 63 | GestureState_None -> Nothing 64 | GestureState_Began a -> Just a 65 | GestureState_Changed a -> Just a 66 | GestureState_Ended a -> Just a 67 | GestureState_Cancelled -> Nothing 68 | -------------------------------------------------------------------------------- /hs-uikit/cbits/GenericAppDelegate.m: -------------------------------------------------------------------------------- 1 | #import "GenericAppDelegate.h" 2 | #import 3 | #import "UIKit/Generic/AppDelegate_stub.h" 4 | 5 | 6 | @interface GenericAppDelegate () 7 | 8 | @end 9 | 10 | static HsStablePtr genericAppDelegate_globalConfig; 11 | 12 | @implementation GenericAppDelegate 13 | 14 | - (BOOL)application:(UIApplication*)application willFinishLaunchingWithOptions:(NSDictionary*)launchOptions { 15 | return genericAppDelegate_willFinishLaunchingWithOptions(genericAppDelegate_globalConfig, (__bridge HsPtr)application, (__bridge HsPtr)launchOptions); 16 | } 17 | 18 | - (BOOL)application:(UIApplication*)application didFinishLaunchingWithOptions:(NSDictionary*)launchOptions { 19 | self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]]; 20 | self.window.backgroundColor = [UIColor redColor]; 21 | return genericAppDelegate_didFinishLaunchingWithOptions(genericAppDelegate_globalConfig, (__bridge HsPtr)application, (__bridge HsPtr)launchOptions, (__bridge HsPtr)self.window); 22 | } 23 | 24 | - (void)applicationWillResignActive:(UIApplication*)application { 25 | genericAppDelegate_willResignActive(genericAppDelegate_globalConfig, (__bridge HsPtr)application); 26 | } 27 | 28 | - (void)applicationDidEnterBackground:(UIApplication*)application { 29 | genericAppDelegate_didEnterBackground(genericAppDelegate_globalConfig, (__bridge HsPtr)application); 30 | } 31 | 32 | - (void)applicationWillEnterForeground:(UIApplication*)application { 33 | genericAppDelegate_willEnterForeground(genericAppDelegate_globalConfig, (__bridge HsPtr)application); 34 | } 35 | 36 | - (void)applicationDidBecomeActive:(UIApplication*)application { 37 | genericAppDelegate_didBecomeActive(genericAppDelegate_globalConfig, (__bridge HsPtr)application); 38 | } 39 | 40 | - (void)applicationWillTerminate:(UIApplication*)application { 41 | genericAppDelegate_willTerminate(genericAppDelegate_globalConfig, (__bridge HsPtr)application); 42 | } 43 | 44 | - (void)applicationSignificantTimeChange:(UIApplication*)application { 45 | genericAppDelegate_significantTimeChange(genericAppDelegate_globalConfig, (__bridge HsPtr)application); 46 | } 47 | 48 | /* 49 | - (void)application:(UIApplication*)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData*)deviceToken { 50 | } 51 | 52 | - (void)application:(UIApplication*)application didReceiveRemoteNotification:(NSDictionary*)userInfo fetchCompletionHandler:(void (^)(UIBackgroundFetchResult result))completionHandler { 53 | } 54 | 55 | - (void)application:(UIApplication*)application didFailToRegisterForRemoteNotificationsWithError:(NSError*)error { 56 | } 57 | 58 | - (BOOL)application:(UIApplication*)application continueUserActivity:(NSUserActivity*)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler { 59 | } 60 | */ 61 | 62 | @end 63 | 64 | void genericAppDelegate_runApplication(HsStablePtr config) { 65 | @autoreleasepool { 66 | genericAppDelegate_globalConfig = config; 67 | char* _Nonnull argv [] = {"", 0}; 68 | UIApplicationMain(0, argv, nil, NSStringFromClass([GenericAppDelegate class])); 69 | } 70 | } 71 | 72 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/Generic/GestureRecognizerTarget.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | -- |Generic target for @UIGestureRecognizer@ which invokes a Haskell callback. 4 | module UIKit.Generic.GestureRecognizerTarget 5 | ( 6 | -- * Type token and pointer type 7 | GenericGestureRecognizerTargetType, GenericGestureRecognizerTarget 8 | -- * Creating 9 | , new 10 | -- * Instance methods 11 | , setRecognizer 12 | -- * Raw FFI bindings 13 | , genericGestureRecognizerTarget_new, genericGestureRecognizerTarget_setRecognizer 14 | ) where 15 | 16 | import Control.Monad ((=<<), (<=<)) 17 | import Control.Monad.IO.Class (liftIO) 18 | import Foreign.Ptr (Ptr) 19 | import Foreign.StablePtr (StablePtr, deRefStablePtr, newStablePtr) 20 | import ObjC (ObjPtr, ObjType, SafeObjCoerce, retainObj, withObjPtr) 21 | import UIKit.Types (MainThread(..), UIGestureRecognizer, UIGestureRecognizerType, asUIGestureRecognizer) 22 | 23 | 24 | -- |Type token for the @GenericGestureRecognizerTarget@ class. 25 | data GenericGestureRecognizerTargetType 26 | -- |Pointer to a @GenericGestureRecognizerTarget@ instance. 27 | type GenericGestureRecognizerTarget = ObjPtr GenericGestureRecognizerTargetType 28 | instance SafeObjCoerce GenericGestureRecognizerTargetType ObjType 29 | 30 | -- |Raw FFI binding to the ObjC function @genericGestureRecognizerTarget_new@ which creates and configures a @GenericGestureRecognizerTarget@ with the given 31 | -- callback. 32 | foreign import ccall unsafe genericGestureRecognizerTarget_new :: StablePtr (UIGestureRecognizer -> MainThread ()) -> IO (Ptr GenericGestureRecognizerTargetType) 33 | 34 | -- |Create a new 'GenericGestureRecognizerTarget' which invokes the given callback whenever it's called by an associated gesture recognizer. 35 | new :: (UIGestureRecognizer -> MainThread ()) -> IO GenericGestureRecognizerTarget 36 | new = retainObj <=< genericGestureRecognizerTarget_new <=< newStablePtr 37 | 38 | foreign export ccall genericGestureRecognizerTarget_handler :: StablePtr (UIGestureRecognizer -> MainThread ()) -> Ptr UIGestureRecognizerType -> MainThread () 39 | -- |Callback invoked from the ObjC code which triggers the configured callback. 40 | genericGestureRecognizerTarget_handler :: StablePtr (UIGestureRecognizer -> MainThread ()) -> Ptr UIGestureRecognizerType -> MainThread () 41 | genericGestureRecognizerTarget_handler callbackPtr recognizerPtr = do 42 | callback <- liftIO $ deRefStablePtr callbackPtr 43 | callback =<< retainObj recognizerPtr 44 | 45 | -- |Raw FFI binding which associates a gesture recognizer with the recognizer target. 46 | foreign import ccall unsafe genericGestureRecognizerTarget_setRecognizer :: Ptr GenericGestureRecognizerTargetType -> Ptr UIGestureRecognizerType -> IO () 47 | -- |Associate a 'UIGestureRecognizer' with the recognizer target. The recognizer will be released when the target is released, which helps the usual case where 48 | -- a target is associated 1:1 with a recognizer and the recognizer is only useful while the target is active. Recognizers do not retain their targets so there 49 | -- is no cycle. 50 | setRecognizer :: SafeObjCoerce recognizer UIGestureRecognizerType => GenericGestureRecognizerTarget -> ObjPtr recognizer -> IO () 51 | setRecognizer to ro = 52 | withObjPtr to $ \ t -> 53 | withObjPtr (asUIGestureRecognizer ro) $ \ r -> 54 | genericGestureRecognizerTarget_setRecognizer t r 55 | 56 | -------------------------------------------------------------------------------- /hs-uikit/src/CoreGraphics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- |Types corresponding to those in the @CoreGraphics@ framework. 3 | module CoreGraphics 4 | ( 5 | -- * @CGFloat@ 6 | CGFloat, sizeOfCgFloat 7 | -- * @CGPoint@ 8 | , CGPoint(..), sizeOfCgPoint 9 | -- * @CGSize@ 10 | , CGSize(..), sizeOfCgSize 11 | -- * @CGRect@ 12 | , CGRect(..), sizeOfCgRect 13 | ) where 14 | 15 | import Data.Void (Void) 16 | import Foreign.Ptr (Ptr, castPtr, plusPtr) 17 | import Foreign.Storable (Storable(alignment, sizeOf, peek, poke)) 18 | 19 | 20 | -- |Type corresponding to the @CGFloat@ type alias. This binding currently assumes only 64-bit targets, where @CGFloat@ is equivalent to 'Double'. 21 | type CGFloat = Double -- FIXME 64-bit assumption 22 | 23 | -- |Size of a 'CGFloat' in bytes, as a short hand for 'sizeOf'. 24 | {-# INLINE sizeOfCgFloat #-} 25 | sizeOfCgFloat :: Int 26 | sizeOfCgFloat = sizeOf (undefined :: CGFloat) 27 | 28 | -- |@CGPoint@ - a 2D cartesian point represented by a pair of 'CGFloat's. 29 | data CGPoint = CGPoint 30 | { _cgPoint_x :: {-# UNPACK #-} !CGFloat 31 | , _cgPoint_y :: {-# UNPACK #-} !CGFloat 32 | } deriving (Eq, Show) 33 | 34 | -- |Size of a 'CGPoint' in bytes, as a short hand for 'sizeOf'. 35 | {-# INLINE sizeOfCgPoint #-} 36 | sizeOfCgPoint :: Int 37 | sizeOfCgPoint = sizeOfCgFloat * 2 38 | 39 | -- |Stores a 'CGPoint' as the X coordinate followed by the Y, conforming to the C @struct@ definition. 40 | instance Storable CGPoint where 41 | alignment _ = alignment (undefined :: Ptr Void) 42 | sizeOf _ = sizeOfCgPoint 43 | peek ptr = CGPoint <$> peek (castPtr ptr) <*> peek (castPtr $ ptr `plusPtr` sizeOfCgFloat) 44 | poke ptr (CGPoint {..}) = poke (castPtr ptr) _cgPoint_x >> poke (castPtr $ ptr `plusPtr` sizeOfCgFloat) _cgPoint_y 45 | 46 | -- |@CGSize@ - a 2D measure of size represented by a pair of @CGFloat@s. 47 | data CGSize = CGSize 48 | { _cgSize_width :: {-# UNPACK #-} !CGFloat 49 | , _cgSize_height :: {-# UNPACK #-} !CGFloat 50 | } deriving (Eq, Show) 51 | 52 | -- |Size of a 'CGSize' in bytes, as a short hand for 'sizeOf'. 53 | {-# INLINE sizeOfCgSize #-} 54 | sizeOfCgSize :: Int 55 | sizeOfCgSize = sizeOfCgFloat * 2 56 | 57 | -- |Stores a 'CGSize' as the width dimension followed by the height dimension, conforming to the C @struct@ definition. 58 | instance Storable CGSize where 59 | alignment _ = alignment (undefined :: Ptr Void) 60 | sizeOf _ = sizeOfCgSize 61 | peek ptr = CGSize <$> peek (castPtr ptr) <*> peek (castPtr $ ptr `plusPtr` sizeOfCgFloat) 62 | poke ptr (CGSize {..}) = poke (castPtr ptr) _cgSize_width >> poke (castPtr $ ptr `plusPtr` sizeOfCgFloat) _cgSize_height 63 | 64 | -- |@CGRect@ - a 2D rectangle represented by an origin 'CGPoint' along with a 'CGSize'. 65 | data CGRect = CGRect 66 | { _cgRect_origin :: {-# UNPACK #-} !CGPoint 67 | , _cgRect_size :: {-# UNPACK #-} !CGSize 68 | } deriving (Eq, Show) 69 | 70 | -- |Size of a 'CGRect' in bytes, as a short hand for 'sizeOf'. 71 | {-# INLINE sizeOfCgRect #-} 72 | sizeOfCgRect :: Int 73 | sizeOfCgRect = sizeOfCgPoint + sizeOfCgSize 74 | 75 | -- |Stores a 'CGRect' as the origin followed by the size, conforming to the C @struct@ definition. 76 | instance Storable CGRect where 77 | alignment _ = alignment (undefined :: Ptr Void) 78 | sizeOf _ = sizeOfCgRect 79 | peek ptr = CGRect <$> peek (castPtr ptr) <*> peek (castPtr $ ptr `plusPtr` sizeOfCgPoint) 80 | poke ptr (CGRect {..}) = poke (castPtr ptr) _cgRect_origin >> poke (castPtr $ ptr `plusPtr` sizeOfCgPoint) _cgRect_size 81 | 82 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/ViewConfig.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | -- |Configuration of any type of view. 4 | module Reflex.Native.ViewConfig 5 | ( 6 | -- * Configuration for regular views created with Reflex Native 7 | ViewConfig(..), defaultViewConfig 8 | -- * Configuration for other views adopted by Reflex Native 9 | , RawViewConfig(..), defaultRawViewConfig, viewConfigToRawViewConfig 10 | ) where 11 | 12 | import Data.Functor.Identity (Identity) 13 | import Data.Maybe (Maybe(Nothing)) 14 | import Data.Text (Text) 15 | import GHC.Generics (Generic) 16 | import Reflex.Class (Event) 17 | import Reflex.Native.Geometry (Rect(..), Point(..), Size(..)) 18 | import Reflex.Native.ViewLayout (ViewLayout(..)) 19 | import Reflex.Native.ViewStyle (ViewStyle, defaultInitialViewStyle) 20 | 21 | 22 | -- |Configuration of any type of view created by Reflex native, including its style, layout, and accessibility parameters. 23 | data ViewConfig t = ViewConfig 24 | { _viewConfig_initialStyle :: ViewStyle Identity 25 | -- ^Style to initially use when displaying the view. 26 | , _viewConfig_modifyStyle :: Maybe (ViewStyle (Event t)) 27 | -- ^Optional @Event@s to dynamically update the view style after initial display. 28 | , _viewConfig_initialLayout :: ViewLayout 29 | -- ^Initial layout for the view. 30 | , _viewConfig_setLayout :: Maybe (Event t ViewLayout) 31 | -- ^Optional @Event@ to update the layout of a view dynamically. 32 | , _viewConfig_initialAccessibilityLabel :: Maybe Text 33 | -- ^Initial accessibility label to apply to the view. 34 | , _viewConfig_setAccessibilityLabel :: Maybe (Event t (Maybe Text)) 35 | -- ^Optional @Event@ to dynamically update accessiblity label after initial display. 36 | } deriving (Generic) 37 | 38 | -- |Default 'ViewConfig' with the 'defaultInitialViewStyle', fixed 0x0+0x0 layout, and no dynamically updating anything. 39 | defaultViewConfig :: ViewConfig t 40 | defaultViewConfig = ViewConfig 41 | { _viewConfig_initialStyle = defaultInitialViewStyle 42 | , _viewConfig_modifyStyle = Nothing 43 | , _viewConfig_initialLayout = ViewLayout_Fixed (Rect (Point 0 0) (Size 0 0)) 44 | , _viewConfig_setLayout = Nothing 45 | , _viewConfig_initialAccessibilityLabel = Nothing 46 | , _viewConfig_setAccessibilityLabel = Nothing 47 | } 48 | 49 | -- |Configuration of a raw view created outside Reflex Native and then adopted using 'Reflex.Native.ViewBuilder.Class.wrapRawView' or similar. Allows dynamic 50 | -- update of a view just like 'ViewConfig', but not the initial setting. 51 | data RawViewConfig t = RawViewConfig 52 | { _rawViewConfig_modifyStyle :: Maybe (ViewStyle (Event t)) 53 | -- ^Optional @Event@s to dynamically update the view style after initial display. 54 | , _rawViewConfig_setLayout :: Maybe (Event t ViewLayout) 55 | -- ^Optional @Event@ to update the layout of a view dynamically. 56 | , _rawViewConfig_setAccessibilityLabel :: Maybe (Event t (Maybe Text)) 57 | -- ^Optional @Event@ to dynamically update accessiblity label after initial display. 58 | } deriving (Generic) 59 | 60 | -- |Default 'RawViewConfig' which never dynamically updates anything. 61 | defaultRawViewConfig :: RawViewConfig t 62 | defaultRawViewConfig = RawViewConfig 63 | { _rawViewConfig_modifyStyle = Nothing 64 | , _rawViewConfig_setLayout = Nothing 65 | , _rawViewConfig_setAccessibilityLabel = Nothing 66 | } 67 | 68 | -- |Extract the equivalent 'RawViewConfig' for some 'ViewConfig'. 69 | viewConfigToRawViewConfig :: ViewConfig t -> RawViewConfig t 70 | viewConfigToRawViewConfig (ViewConfig {..}) = RawViewConfig 71 | { _rawViewConfig_modifyStyle = _viewConfig_modifyStyle 72 | , _rawViewConfig_setLayout = _viewConfig_setLayout 73 | , _rawViewConfig_setAccessibilityLabel = _viewConfig_setAccessibilityLabel 74 | } 75 | 76 | -------------------------------------------------------------------------------- /reflex-native-uikit/src/Reflex/UIKit/Specializations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | -- |Specializations of various performance critical functions used in Reflex UIKit. 4 | module Reflex.UIKit.Specializations where 5 | 6 | import Data.Dependent.Map (DMap) 7 | import Data.GADT.Compare (GCompare) 8 | import Data.IntMap (IntMap) 9 | import qualified Data.IntMap as IntMap 10 | import Reflex.Class (Event) 11 | import Reflex.Patch.DMap (PatchDMap) 12 | import Reflex.Patch.DMapWithMove (PatchDMapWithMove) 13 | import Reflex.Patch.IntMap (PatchIntMap) 14 | import Reflex.PerformEvent.Base (PerformEventT) 15 | import Reflex.PostBuild.Base (PostBuildT, mapIntMapWithAdjustImpl) 16 | import Reflex.Spider (Global, Spider, SpiderHost, SpiderTimeline) 17 | import Reflex.UIKit.ViewBuilder (UIKitViewBuilderT) 18 | import Reflex.UIKit.ViewBuilder as ViewBuilder 19 | import UIKit.Types (UIView) 20 | 21 | 22 | -- t ~ (SpiderTimeline Global) 23 | -- m ~ UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) 24 | 25 | {-# SPECIALIZE mapIntMapWithAdjustImpl :: forall v v'. 26 | ( (IntMap.Key -> (Event (SpiderTimeline Global) (), v) -> (UIKitViewBuilderT Spider (PerformEventT Spider (SpiderHost Global))) v') 27 | -> IntMap (Event (SpiderTimeline Global) (), v) 28 | -> Event (SpiderTimeline Global) (PatchIntMap (Event (SpiderTimeline Global) (), v)) 29 | -> (UIKitViewBuilderT Spider (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) 30 | ) 31 | -> (IntMap.Key -> v -> PostBuildT (SpiderTimeline Global) (UIKitViewBuilderT Spider (PerformEventT Spider (SpiderHost Global))) v') 32 | -> IntMap v 33 | -> Event (SpiderTimeline Global) (PatchIntMap v) 34 | -> PostBuildT (SpiderTimeline Global) (UIKitViewBuilderT Spider (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) 35 | #-} 36 | 37 | {-# SPECIALIZE append :: 38 | UIView 39 | -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) () 40 | #-} 41 | 42 | {-# SPECIALIZE appendFragment :: 43 | UIView 44 | -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) () 45 | #-} 46 | 47 | {-# SPECIALIZE uikitRunWithReplace :: forall a b. 48 | UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) a 49 | -> Event (SpiderTimeline Global) (UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) b) 50 | -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) (a, Event (SpiderTimeline Global) b) 51 | #-} 52 | 53 | {-# SPECIALIZE uikitTraverseIntMapWithKeyWithAdjust :: forall v v'. 54 | (IntMap.Key -> v -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) v') 55 | -> IntMap v 56 | -> Event (SpiderTimeline Global) (PatchIntMap v) 57 | -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) 58 | #-} 59 | 60 | {-# SPECIALIZE uikitTraverseDMapWithKeyWithAdjust :: forall k v v'. GCompare k 61 | => (forall a. k a -> v a -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) (v' a)) 62 | -> DMap k v 63 | -> Event (SpiderTimeline Global) (PatchDMap k v) 64 | -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) (DMap k v', Event (SpiderTimeline Global) (PatchDMap k v')) 65 | #-} 66 | 67 | {-# SPECIALIZE uikitTraverseDMapWithKeyWithAdjustWithMove :: forall k v v'. GCompare k 68 | => (forall a. k a -> v a -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) (v' a)) 69 | -> DMap k v 70 | -> Event (SpiderTimeline Global) (PatchDMapWithMove k v) 71 | -> UIKitViewBuilderT (SpiderTimeline Global) (PerformEventT Spider (SpiderHost Global)) (DMap k v', Event (SpiderTimeline Global) (PatchDMapWithMove k v')) 72 | #-} 73 | 74 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE ExplicitNamespaces #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | -- |Reexports of the various @Reflex.Native@ modules and the 'MonadNative' constraint alias for writing shorter but less precise signatures. 10 | module Reflex.Native 11 | ( 12 | -- * Reexports 13 | module Export 14 | -- * @MonadNative@ 15 | , MonadNativeConstraints, MonadNative 16 | ) where 17 | 18 | import Control.Monad.Fix (MonadFix) 19 | import Control.Monad.IO.Class (MonadIO) 20 | import Control.Monad.Ref (MonadRef(type Ref)) 21 | import Reflex as Export 22 | import Reflex.Host.Class (MonadReflexCreateTrigger) 23 | import Reflex.Native.Color as Export 24 | import Reflex.Native.Font as Export 25 | import Reflex.Native.Geometry as Export 26 | import Reflex.Native.Gesture as Export 27 | import Reflex.Native.TextConfig as Export 28 | import Reflex.Native.TextStyle as Export 29 | import Reflex.Native.Widget.Basic as Export 30 | import Reflex.Native.Widget.Customization as Export 31 | import Reflex.Native.ViewBuilder.Class as Export 32 | import Reflex.Native.ViewConfig as Export 33 | import Reflex.Native.ViewLayout as Export 34 | import Reflex.Native.ViewStyle as Export 35 | import Reflex.NotReady.Class as Export 36 | 37 | 38 | -- |Grab-bag of constraints which make a fully-featured Reflex Native monad stack. 39 | -- 40 | -- Specifically: 41 | -- 42 | -- * 'ViewBuilder', granting the ability to build reactive view hierarchies that are cross platform. 43 | -- * 'Adjustable', implied by @ViewBuilder@, granting the ability to react to @Event@s by changing the built view hierarchy at various levels of 44 | -- granularity. 45 | -- * 'NotReady', implied by @ViewBuilder@, granting the ability to defer installation of views until prerequisites are available. 46 | -- * 'Reflex', granting essential FRP functionality like @Behavior@, @Event@, etc. and associated functions. 47 | -- * 'MonadFix', granting the ability to make recursive bindings which is especially important for UIs as components often rely on previous state to 48 | -- determine future state and the order of views controls which views overlap others, but the flow of data might not be in the same order. 49 | -- * 'MonadHold', granting additional functionality to hold @Event@s and create @Behavior@s and @Dynamic@s which update when those events fire, allowing 50 | -- stateful behavior. 51 | -- * 'MonadSample', granting the ability to sample the values of @Behavior@s at build time. 52 | -- * 'TriggerEvent' and 'MonadReflexCreateTrigger', granting the ability to create @Event@s which trigger based on externally invoked @IO@ actions. 53 | -- * 'PostBuild', exposing an @Event@ which fires every time a build phase completes. 54 | -- * 'MonadIO', granting the ability to run arbitrary IO actions at build time. Of course, IO actions cannot be rewound so be aware when using @MonadIO@ 55 | -- with @Adjustable@. 56 | -- * 'MonadRef', which is redundant with @MonadIO@ available but convenient for generic functions. 57 | -- * 'PerformEvent', granting the ability to execute arbitrary monadic actions in response to @Event@s firing, along with the guarantee that whatever monad 58 | -- is used is @MonadIO@ and @MonadRef@. 59 | -- * @Monad@, @Applicative@, and @Functor@, implied by many of the previous. 60 | type MonadNativeConstraints t m = 61 | ( ViewBuilder t m 62 | , Reflex t 63 | , MonadFix m 64 | , MonadHold t m 65 | , MonadSample t (Performable m) 66 | , MonadReflexCreateTrigger t m 67 | , PostBuild t m 68 | , MonadIO m 69 | , TriggerEvent t m 70 | , MonadRef m, Ref m ~ Ref IO 71 | , PerformEvent t m 72 | , MonadIO (Performable m) 73 | , MonadRef (Performable m), Ref (Performable m) ~ Ref IO 74 | ) 75 | 76 | -- |Class which implies all constraints of 'MonadNativeConstraints' but doesn't require additional language extensions at the use site. 77 | class MonadNativeConstraints t m => MonadNative t m | m -> t 78 | -- |Trivial instance for all types @t@, @m@ 79 | instance MonadNativeConstraints t m => MonadNative t m 80 | 81 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/Generic/View.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- |A generic subclass of 'UIView' where lifecycle callbacks are implemented by calling back to Haskell actions. 3 | module UIKit.Generic.View 4 | ( 5 | -- * Configuring 6 | ViewConfig(..), defaultViewConfig 7 | -- * Creating 8 | , new 9 | -- * Raw FFI bindings 10 | , genericView_new 11 | ) where 12 | 13 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 14 | import Control.Monad ((=<<)) 15 | import Control.Monad.IO.Class (liftIO) 16 | import CoreGraphics (CGRect) 17 | import Foreign.Ptr (Ptr) 18 | import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr) 19 | import Foreign.Storable (peek) 20 | import ObjC (retainObj) 21 | import UIKit.Types (MainThread(..), UIView, UIViewType) 22 | 23 | 24 | -- |Configuration for a generic view including some user-specified data @a@ which will be held as long as the view remains live and actions to execute during 25 | -- the view lifecycle. 26 | -- 27 | -- __Warning:__ take care to not refer back to the @UIView@ strongly from @a@, as that will cause a reference cycle which will never be deallocated. 28 | data ViewConfig a = ViewConfig 29 | { 30 | _view_a :: a 31 | -- ^ User-defined data to keep alive with the view and pass to each callback. 32 | -- __Warning:__ take care to not refer back to the @UIView@ strongly from @a@, as that will cause a reference cycle which will never be deallocated. 33 | , _view_drawRect :: a -> CGRect -> MainThread () 34 | -- ^ Callback to invoke when @UIView - drawRect:@ is called on the view. 35 | } 36 | 37 | -- |Create a new 'ViewConfig' with default no-op callbacks and the given @a@. 38 | defaultViewConfig :: a -> ViewConfig a 39 | defaultViewConfig a = ViewConfig 40 | { _view_a = a 41 | , _view_drawRect = \ _ _ -> pure () 42 | } 43 | 44 | -- |Raw FFI binding to @[[GenericView alloc] initWithCallback:]@. 45 | foreign import ccall genericView_new 46 | :: StablePtr (UIView -> MainThread (StablePtr (ViewConfig a))) 47 | -> MainThread (Ptr UIViewType) 48 | 49 | -- |Create a new generic view, invoking the given callback after the view is allocated but before it finishes initializing to configure the view. 50 | new 51 | :: (UIView -> MainThread (ViewConfig a)) 52 | -> MainThread (UIView, ViewConfig a) 53 | new initialize = do 54 | configRef <- liftIO $ newEmptyMVar 55 | callbackPtr <- liftIO $ newStablePtr $ \ v -> do 56 | config <- initialize v 57 | liftIO $ putMVar configRef config 58 | liftIO $ newStablePtr config 59 | v <- retainObj =<< genericView_new callbackPtr 60 | liftIO $ freeStablePtr callbackPtr 61 | config <- liftIO $ takeMVar configRef 62 | pure (v, config) 63 | 64 | foreign export ccall genericViewImpl_initialize 65 | :: Ptr UIViewType 66 | -> StablePtr (UIView -> MainThread (StablePtr (ViewConfig a))) 67 | -> MainThread (StablePtr (ViewConfig a)) 68 | -- |Callback from the ObjC code to invoke the Haskell initialization callback. 69 | genericViewImpl_initialize 70 | :: Ptr UIViewType 71 | -> StablePtr (UIView -> MainThread (StablePtr (ViewConfig a))) 72 | -> MainThread (StablePtr (ViewConfig a)) 73 | genericViewImpl_initialize vPtr callbackPtr = do 74 | v <- retainObj vPtr 75 | callback <- liftIO $ deRefStablePtr callbackPtr 76 | callback v 77 | 78 | foreign export ccall genericViewImpl_release 79 | :: StablePtr (ViewConfig a) 80 | -> MainThread () 81 | -- |Callback from the ObjC code when the view is being released to release the 'StablePtr' holding the configuration live. 82 | genericViewImpl_release 83 | :: StablePtr (ViewConfig a) 84 | -> MainThread () 85 | genericViewImpl_release = liftIO . freeStablePtr 86 | 87 | foreign export ccall genericViewImpl_drawRect 88 | :: StablePtr (ViewConfig a) 89 | -> Ptr CGRect 90 | -> MainThread () 91 | -- |Callback from the ObjC code when @UIView - drawRect:@ is called to draw the contents of the view by invoking the configured '_view_drawRect' callback. 92 | genericViewImpl_drawRect 93 | :: StablePtr (ViewConfig a) 94 | -> Ptr CGRect 95 | -> MainThread () 96 | genericViewImpl_drawRect configPtr rectPtr = do 97 | ViewConfig {..} <- liftIO $ deRefStablePtr configPtr 98 | rect <- liftIO $ peek rectPtr 99 | _view_drawRect _view_a rect 100 | 101 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/UIView.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- |Class and instance methods of the @UIView@ class. 3 | module UIKit.UIView 4 | ( 5 | -- * Instance methods 6 | addGestureRecognizer, addSubview, removeFromSuperview, setAutoresizesSubviews, setAutoresizingMask, setBackgroundColor, setFrame 7 | -- * Raw FFI bindings 8 | , uiView_addGestureRecognizer, uiView_addSubview, uiView_removeFromSuperview, uiView_setAutoresizesSubviews, uiView_setAutoresizingMask 9 | , uiView_setBackgroundColor, uiView_setFrame 10 | ) where 11 | 12 | import CoreGraphics (CGRect) 13 | import Foreign.C.Types (CChar(..), CInt(..)) 14 | import Foreign.Marshal.Alloc (alloca) 15 | import Foreign.Ptr (Ptr) 16 | import Foreign.Storable (poke) 17 | import ObjC (ObjPtr, SafeObjCoerce, objcBool, withObjPtr) 18 | import UIKit.Types 19 | ( MainThread(..), UIColor, UIColorType, UIGestureRecognizerType, UIViewType, asUIGestureRecognizer, asUIView 20 | , unsafeUnMainThread 21 | ) 22 | 23 | 24 | -- |Raw FFI binding to @UIView - addGestureRecognizer:@ 25 | foreign import ccall unsafe uiView_addGestureRecognizer :: Ptr UIViewType -> Ptr UIGestureRecognizerType -> MainThread () 26 | -- |@UIView - addGestureRecognizer:@ - attach the given gesture recognizer to the view so that touch events are passed to the recognizer. 27 | addGestureRecognizer :: (SafeObjCoerce view UIViewType, SafeObjCoerce recognizer UIGestureRecognizerType) => ObjPtr view -> ObjPtr recognizer -> MainThread () 28 | addGestureRecognizer vo ro = 29 | withObjPtr (asUIView vo) $ \ v -> 30 | withObjPtr (asUIGestureRecognizer ro) $ \ r -> 31 | uiView_addGestureRecognizer v r 32 | 33 | -- |Raw FFI binding to @UIView - addSubview:@ 34 | foreign import ccall unsafe uiView_addSubview :: Ptr UIViewType -> Ptr UIViewType -> MainThread () 35 | -- |@UIView - addSubview:@ - add a view to the subviews of the view above all other existing subviews. 36 | addSubview :: (SafeObjCoerce parent UIViewType, SafeObjCoerce subview UIViewType) => ObjPtr parent -> ObjPtr subview -> MainThread () 37 | addSubview po svo = 38 | withObjPtr (asUIView po) $ \ p -> 39 | withObjPtr (asUIView svo) $ \ sv -> 40 | uiView_addSubview p sv 41 | 42 | -- |Raw FFI binding to @UIView - removeFromSuperview@ 43 | foreign import ccall unsafe uiView_removeFromSuperview :: Ptr UIViewType -> MainThread () 44 | -- |@UIView - removeFromSuperview@ - remove a view from the view hierarchy and specifically from its current superview's subviews. No-op if the view does not 45 | -- have a superview. 46 | removeFromSuperview :: SafeObjCoerce v UIViewType => ObjPtr v -> MainThread () 47 | removeFromSuperview vo = 48 | withObjPtr (asUIView vo) $ \ v -> 49 | uiView_removeFromSuperview v 50 | 51 | -- |Raw FFI binding to @UIView - setAutoresizesSubviews:@ 52 | foreign import ccall unsafe uiView_setAutoresizesSubviews :: Ptr UIViewType -> CChar -> MainThread () 53 | -- |@UIView - setAutoresizesSubviews:@ - turn on or off the view laying out its subviews according to their autoresizing masks. 54 | setAutoresizesSubviews :: SafeObjCoerce v UIViewType => ObjPtr v -> Bool -> MainThread () 55 | setAutoresizesSubviews vo b = 56 | withObjPtr (asUIView vo) $ \ v -> 57 | uiView_setAutoresizesSubviews v (objcBool b) 58 | 59 | -- |Raw FFI binding to @UIView - setAutoresizingMask:@ 60 | foreign import ccall unsafe uiView_setAutoresizingMask :: Ptr UIViewType -> CInt -> MainThread () 61 | -- @UIView - setAutoresizingMask:@ - set the bitvector which controls how the view is laid out in its superview, if the superview has its @autoresizesSubviews@ 62 | -- flag turned on. 63 | setAutoresizingMask :: SafeObjCoerce v UIViewType => ObjPtr v -> CInt -> MainThread () 64 | setAutoresizingMask vo m = 65 | withObjPtr (asUIView vo) $ \ v -> 66 | uiView_setAutoresizingMask v m 67 | 68 | -- |Raw FFI binding to @UIView - setBackgroundColor:@ 69 | foreign import ccall unsafe uiView_setBackgroundColor :: Ptr UIViewType -> Ptr UIColorType -> MainThread () 70 | -- |@UIView - setBackgroundColor:@ - set the background color of the view. Automatically sets @isOpaque@ based on the alpha component of the color. 71 | -- property appropriately. 72 | setBackgroundColor :: SafeObjCoerce v UIViewType => ObjPtr v -> UIColor -> MainThread () 73 | setBackgroundColor vo co = 74 | withObjPtr (asUIView vo) $ \ v -> 75 | withObjPtr co $ \ c -> 76 | uiView_setBackgroundColor v c 77 | 78 | -- |Raw FFI binding to @UIView - setFrame:@ 79 | foreign import ccall unsafe uiView_setFrame :: Ptr UIViewType -> Ptr CGRect -> MainThread () 80 | -- |@UIView - setFrame:@ - set the frame (position and size) of the view in the coordinate system of its superview. 81 | setFrame :: SafeObjCoerce v UIViewType => ObjPtr v -> CGRect -> MainThread () 82 | setFrame vo rect = 83 | withObjPtr (asUIView vo) $ \ v -> 84 | MainThread . alloca $ \ ptr -> do 85 | poke ptr rect 86 | unsafeUnMainThread $ uiView_setFrame v ptr 87 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | rec { 2 | # Functions which extend a haskellPackages with the packages local to this repository and appropriate for the given platform using 3 | # haskellPackages.callPackage. Used later to make augmented platform-specific package sets, but also useful for integrating Reflex Native into your Nix 4 | # build environment. 5 | packages = { 6 | common = haskellPackages: { 7 | reflex-native = haskellPackages.callCabal2nix "reflex-native" ./reflex-native {}; 8 | reflex-native-draggy = haskellPackages.callPackage ./examples/draggy {}; 9 | reflex-native-test = haskellPackages.callCabal2nix "reflex-native-test" ./reflex-native-test {}; 10 | }; 11 | 12 | host = packages.common; 13 | 14 | android = haskellPackages: packages.common haskellPackages // { 15 | }; 16 | 17 | ios = haskellPackages: packages.common haskellPackages // { 18 | hs-uikit = haskellPackages.callPackage ./hs-uikit {}; 19 | reflex-native-uikit = haskellPackages.callCabal2nix "reflex-native-uikit" ./reflex-native-uikit {}; 20 | }; 21 | }; 22 | 23 | # Version of reflex-platform we use for iteration on Reflex Native and compiling the examples 24 | reflex-platform-src = (import {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./reflex-platform-version.json)); 25 | 26 | # reflex-platform for iteration on Reflex Native and compiling the examples 27 | reflex-platform = import reflex-platform-src {}; 28 | 29 | # Host nixpkgs from reflex-platform 30 | nixpkgs = reflex-platform.nixpkgs; 31 | 32 | # Alias to the iOS cross-building nixpkgs from reflex-platform. Useful when nix REPLing. 33 | iosAarch64 = reflex-platform.nixpkgsCross.ios.aarch64; 34 | 35 | # What overrides we make to a haskellPackages for each platform, both external dependencies that we adjust and local packages. 36 | overrides = { 37 | common = self: super: { 38 | generic-lens = nixpkgs.haskell.lib.dontCheck super.generic-lens; 39 | # rank2classes = nixpkgs.haskell.lib.dontCheck (self.callCabal2nix "rank2classes" (nixpkgs.fetchFromGitHub { 40 | # owner = "blamario"; 41 | # repo = "grampa"; 42 | # rev = "f35d8882ee6a60e91a86db339bdac94710d8bc6b"; 43 | # sha256 = "1ssv0lrbbj694rficrka56l628ha9l61wrnxqxy6yn9dawk6h6n8"; 44 | # } + /rank2classes) {}); 45 | 46 | # reflex = nixpkgs.haskell.lib.enableCabalFlag (self.callPackage (nixpkgs.fetchFromGitHub { 47 | # owner = "reflex-frp"; 48 | # repo = "reflex"; 49 | # rev = "9fcbf0792702f48185736cd4bebc2973f299e848"; 50 | # sha256 = "1p5b7gp1vwhq1slhfgbdlrgk5xll431rkzg3bzq15j8k9qy4b2bc"; 51 | # }) { useTemplateHaskell = false; }) "fast-weak"; 52 | }; 53 | 54 | host = nixpkgs.lib.composeExtensions overrides.common (self: super: packages.common self); 55 | 56 | android = nixpkgs.lib.composeExtensions overrides.common (self: super: packages.android self); 57 | 58 | ios = nixpkgs.lib.composeExtensions overrides.common (self: super: packages.ios self); 59 | }; 60 | 61 | # haskellPackages for the host extended with our local overrides. 62 | ghcHost = reflex-platform.ghc.override { overrides = overrides.host; }; 63 | 64 | # haskellPackages for Android extended with our local overrides. 65 | ghcAndroidAarch64 = reflex-platform.ghcAndroidAarch64.override { overrides = overrides.android; }; 66 | 67 | # haskellPackages for iOS extended with our local overrides. 68 | ghcIosAarch64 = reflex-platform.ghcIosAarch64.override { overrides = overrides.ios; }; 69 | 70 | # Shell environments for the various platforms 71 | shells = { 72 | # Shell environment for working on the cross-platform bits only, notably the test framework. 73 | host = (reflex-platform.workOnMulti' { 74 | env = ghcHost; 75 | packageNames = ["reflex-native" "reflex-native-draggy" "reflex-native-test"]; 76 | }); 77 | 78 | # Shell environment for working on the Android side with Android related packages and common packages. 79 | android = (reflex-platform.workOnMulti' { 80 | env = ghcAndroidAarch64; 81 | packageNames = ["reflex-native" "reflex-native-draggy"]; 82 | }); 83 | 84 | # Shell environment for working on the iOS side with the UIKit related packages, common packages, and any special environmental magics to get iOS cross 85 | # building working in a shell 86 | ios = (reflex-platform.workOnMulti' { 87 | env = ghcIosAarch64; 88 | packageNames = ["hs-uikit" "reflex-native" "reflex-native-draggy" "reflex-native-uikit"]; 89 | 90 | # special magics to get the preConfigureHook which adds the framework search paths for iOS frameworks 91 | # ideally this would not be necessary, and it isn't if haskellPackages generic-builder is doing the work, but since we're running cabal manually it's 92 | # needed 93 | tools = env: [ iosAarch64.buildPackages.darwin.xcode_8_2 ]; 94 | }).overrideAttrs (_: { shellHook = "runHook preConfigureHooks"; }); 95 | }; 96 | 97 | # Derivations for building each of the examples, grouped by the target platform 98 | examples = { 99 | # Derivations for building iOS app examples 100 | ios = { 101 | # Derivation for building the reflex-native-draggy example as a packaged iOS app. 102 | draggy = (reflex-platform.iosWithHaskellPackages ghcIosAarch64).buildApp { 103 | package = p: p.reflex-native-draggy; 104 | executableName = "reflex-native-draggy-uikit"; 105 | bundleIdentifier = "org.reflexfrp.reflex-native-draggy"; 106 | bundleName = "Reflex Native Draggy"; 107 | }; 108 | }; 109 | }; 110 | } 111 | 112 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Reflex Native 2 | 3 | ### Fully native apps using Reflex 4 | 5 | _Caution:_ This README contains forward looking statements. See [the project status](#project-status). 6 | 7 | Reflex Native is a framework for writing fully native apps using [Reflex](https://github.com/reflex-frp/reflex/), a 8 | [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library for Haskell. 9 | 10 | It provides a [cross-platform layer](#cross-platform) on top of several platform specific libraries for writing components and applications which run on iOS 11 | or Android fully native with little to no compromise in resulting app quality - that is, executing as native ARM binaries and using the platform's UI toolkit, 12 | no JavaScript runtime nor web views. 13 | 14 | ### iOS prerequisites 15 | 16 | Reflex Native UIKit and apps that use it can only be built on a Mac with Xcode installed at `/Applications/Xcode.app` with an iPhoneOS SDK of the version that 17 | `reflex-platform` expects, currently 10.2. 18 | 19 | You can get this version by downloading Xcode 8.2.1, unpacking it, and copying 20 | 21 | `Xcode 8.2.1.app/Contents/Developer/Platforms/iPhoneOS.platform/Developer/SDKs/iPhoneOS10.2.sdk` 22 | 23 | to 24 | 25 | `/Applications/Xcode.app/Contents/Developer/Platforms/iPhoneOS.platform/Developer/SDKs/iPhoneOS10.2.sdk` 26 | 27 | You don't need to actually use Xcode 8.2.1, but that's the version of Xcode that has the 10.2 SDK in it. 28 | 29 | ### Android prerequisites 30 | 31 | TBD :'( 32 | 33 | ### Getting started 34 | 35 | First, see [the project status](#project-status) for cautions about the current immature state of this project. 36 | 37 | #### Building the examples for iOS 38 | 39 | Use `nix-build` with the derivations under `examples` in `default.nix`, for example `nix-build -A examples.ios.draggy` to build `examples/draggy` as an iOS app. 40 | `nix-build` by default makes a link to the build result called `result`, and the apps include packaging and deployment scripts, so continuing the example you 41 | could deploy the draggy example app to an attached iPhone using `result/bin/deploy ` where `` is your Apple developer team ID. 42 | 43 | #### Building the examples for Android 44 | 45 | TBD :'( 46 | 47 | #### Using in your own project 48 | 49 | TBD :'( 50 | 51 | ### Developing Reflex Native itself 52 | 53 | tl;dr: use `make host`, `make android`, or `make ios`. 54 | 55 | Shells are provided for each of the platforms as attributes in `default.nix`: 56 | 57 | * `shells.host` for headless UI testing and the cross-platform components only. 58 | * `shells.ios` for iOS and the cross-platform components. See [iOS preqrequisites](#ios-prerequisites). 59 | * `shells.android` for Android and the cross-platform components. 60 | 61 | You can enter each of these with `nix-shell`, e.g. `nix-shell -A shells.ios`, and then use `cabal new-build` to do incremental builds within the shell. 62 | `cabal new-build` uses a project file to determine what packages to build and any configuration overrides to use when building them, and one is provided for 63 | each platform: 64 | 65 | * `host.project` 66 | * `ios.project` 67 | * `android.project` 68 | 69 | So for example to do an incremental build of the iOS components: 70 | 71 | 1. `nix-shell -A shells.ios` 72 | 2. `cabal --project-file=ios.project --builddir=_build/ios/dist new-build all` 73 | 74 | However as a development environment this leaves some things to be desired: 75 | 76 | * It's tedious to type every time 77 | * It doesn't work well with editor build functions which are typically not running inside the `nix-shell` 78 | * `nix-shell` takes a few moments to start even when it has nothing to build (exacerbating the previous issue) 79 | 80 | So, a `Makefile` is provided with targets for each platform which also builds each shell once and caches the environment. 81 | 82 | Make targets: 83 | 84 | * `make host` makes `_build/host/shell` by caching the `shells.host` `nix-shell` environment and runs 85 | `cabal --project-file=host.project --builddir=_build/ios/dist new-build all` in that environment. `host` is also the default Make target. 86 | * `make ios` and `make android` do the same for iOS and Android respectively. 87 | * `make all` is equivalent to `make host ios android` in the unlikely circumstance your machine is capable of building all platforms. 88 | * `make clean` removes the `_build` directory where all the intermediate build products go. 89 | 90 | ### Cross-platform 91 | 92 | Reflex Native provides a cross-platform view building abstraction which allows components to be written once and operate identically across the supported 93 | platforms. This abstraction is intentionally conservative; any functionality which can't be equally supported should not be in the cross-platform abstraction. 94 | 95 | Any substantial app requires some amount of platform-specific behavior, such as varying navigation, platform-specific functionality or libraries, or 96 | specializations to fit the platform's native look and feel. To that end, Reflex Native is intended to provide the cross-platform tools to write components that 97 | work everywhere but the overall app is intended to be platform-specific and reuse the cross-platform components. 98 | 99 | Using a combination of platform-specific code, cross-platform code, and Haskell's excellent features for reuse you can assemble an app with maximum code sharing 100 | among platforms while avoiding the uncanny valley of cross-platform apps; views created either using the platform-specific `reflex-native-*` or cross-platform 101 | `reflex-native` packages create and maintain actual platform views and not simulacrums, and the platform-specific code you write can complete the product. 102 | 103 | ### Project status 104 | 105 | This project is in its very early stages and is probably not suitable for building a production application on immediately. In particular: 106 | 107 | - It has not been thoroughly tested, nor been used in a production application yet. 108 | - Android support is still missing. 109 | - Cross-platform layout support is still TODO. 110 | 111 | It is being open sourced early in order to foster community involvement or in the hopes that it will be useful, and is still under active development. If you're 112 | interested in building an application using it, please [contribute](CONTRIBUTING.md)! We're actively soliciting volunteers to work on it and make it better. 113 | 114 | As it's in active development this README talks about intended features as if they exist, most notably Android support. 115 | 116 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/Generic/ViewController.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- |Generic @UIViewController@ subclass that is configured with callbacks for the lifecycle events of a view controller. 3 | module UIKit.Generic.ViewController 4 | ( 5 | -- * Configuring 6 | ViewControllerConfig(..), defaultViewControllerConfig 7 | -- * Creating 8 | , new 9 | -- * Raw FFI bindings 10 | , genericViewController_new 11 | ) where 12 | 13 | import Control.Applicative ((<$>), pure) 14 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 15 | import Control.Monad ((=<<)) 16 | import Control.Monad.IO.Class (liftIO) 17 | import Foreign.Ptr (Ptr) 18 | import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr, freeStablePtr) 19 | import ObjC (hsobjc_retain, retainObj, withObjPtr) 20 | import qualified UIKit.Generic.View as GenericView 21 | import UIKit.Types (MainThread(..), UIView, UIViewType, UIViewController, UIViewControllerType) 22 | 23 | 24 | -- |Configuration for a generic view controller with a user-specified @a@ to hold as long as the view controller remains live and the callbacks to invoke when 25 | -- view controller lifecycle events occur. 26 | -- 27 | -- __Warning:__ take care to not refer back to the @UIViewController@ strongly from @a@, as that will cause a reference cycle which will never be deallocated. 28 | data ViewControllerConfig a = ViewControllerConfig 29 | { _viewController_a :: a 30 | -- ^User data to keep while the view controller is live and is passed to each callback invocation. 31 | -- 32 | -- __Warning:__ take care to not refer back to the @UIViewController@ strongly from @a@, as that will cause a reference cycle which will never be deallocated. 33 | , _viewController_loadView :: a -> MainThread UIView 34 | -- ^Callback to invoke when @UIViewController - loadView@ is called which builds and returns the initial view for the view controller. 35 | , _viewController_viewDidLoad :: a -> MainThread () 36 | -- ^Callback to invoke when @UIViewController - viewDidLoad@ is called. 37 | , _viewController_didReceiveMemoryWarning :: a -> MainThread () 38 | -- ^Callback to invoke when @UIViewController - didReceiveMemoryWarning@ is called. 39 | } 40 | 41 | -- |Create a 'ViewControllerConfig' with the given value and no-op callbacks. '_viewController_loadView' returns an empty "UIKit.Generic.View". 42 | defaultViewControllerConfig :: a -> ViewControllerConfig a 43 | defaultViewControllerConfig a = ViewControllerConfig 44 | { _viewController_a = a 45 | , _viewController_loadView = \ _ -> fst <$> GenericView.new (\ _ -> pure $ GenericView.defaultViewConfig ()) 46 | , _viewController_viewDidLoad = \ _ -> pure () 47 | , _viewController_didReceiveMemoryWarning = \ _ -> pure () 48 | } 49 | 50 | -- |Raw FFI binding to @genericViewController_new@ which takes a callback to run during initialization. 51 | foreign import ccall genericViewController_new 52 | :: StablePtr (UIViewController -> MainThread (StablePtr (ViewControllerConfig a))) 53 | -> MainThread (Ptr UIViewControllerType) 54 | 55 | -- |Create a new generic view controller, running the given callback after the view controller has been allocated but before it's initialized which creates the 56 | -- configuration for the new view controller. 57 | new 58 | :: (UIViewController -> MainThread (ViewControllerConfig a)) 59 | -> MainThread (UIViewController, ViewControllerConfig a) 60 | new initialize = do 61 | configRef <- liftIO newEmptyMVar 62 | callbackPtr <- liftIO . newStablePtr $ \ vc -> do 63 | config <- initialize vc 64 | liftIO $ putMVar configRef config 65 | liftIO $ newStablePtr config 66 | vc <- retainObj =<< genericViewController_new callbackPtr 67 | liftIO $ freeStablePtr callbackPtr 68 | config <- liftIO $ takeMVar configRef 69 | pure (vc, config) 70 | 71 | foreign export ccall genericViewController_initialize 72 | :: Ptr UIViewControllerType 73 | -> StablePtr (UIViewController -> MainThread (StablePtr (ViewControllerConfig a))) 74 | -> MainThread (StablePtr (ViewControllerConfig a)) 75 | -- |Callback from ObjC during initialization to invoke the initialization callback. 76 | genericViewController_initialize 77 | :: Ptr UIViewControllerType 78 | -> StablePtr (UIViewController -> MainThread (StablePtr (ViewControllerConfig a))) 79 | -> MainThread (StablePtr (ViewControllerConfig a)) 80 | genericViewController_initialize vcPtr callbackPtr = do 81 | vc <- retainObj vcPtr 82 | callback <- liftIO $ deRefStablePtr callbackPtr 83 | callback vc 84 | 85 | foreign export ccall genericViewController_release 86 | :: StablePtr (ViewControllerConfig a) 87 | -> MainThread () 88 | -- |Callback from ObjC when the view controller is released to release the configuration 'StablePtr' 89 | genericViewController_release 90 | :: StablePtr (ViewControllerConfig a) 91 | -> MainThread () 92 | genericViewController_release = liftIO . freeStablePtr 93 | 94 | foreign export ccall genericViewController_loadView 95 | :: StablePtr (ViewControllerConfig a) 96 | -> MainThread (Ptr UIViewType) 97 | -- |Callback from ObjC to trigger the '_viewController_loadView' callback. 98 | genericViewController_loadView 99 | :: StablePtr (ViewControllerConfig a) 100 | -> MainThread (Ptr UIViewType) 101 | genericViewController_loadView configPtr = do 102 | ViewControllerConfig {..} <- liftIO $ deRefStablePtr configPtr 103 | vo <- _viewController_loadView _viewController_a 104 | withObjPtr vo $ \ v -> do 105 | liftIO $ hsobjc_retain v 106 | pure v 107 | 108 | foreign export ccall genericViewController_viewDidLoad 109 | :: StablePtr (ViewControllerConfig a) 110 | -> MainThread () 111 | -- |Callback from ObjC to trigger the '_viewController_viewDidLoad' callback. 112 | genericViewController_viewDidLoad 113 | :: StablePtr (ViewControllerConfig a) 114 | -> MainThread () 115 | genericViewController_viewDidLoad configPtr = do 116 | ViewControllerConfig {..} <- liftIO $ deRefStablePtr configPtr 117 | _viewController_viewDidLoad _viewController_a 118 | 119 | foreign export ccall genericViewController_didReceiveMemoryWarning 120 | :: StablePtr (ViewControllerConfig a) 121 | -> MainThread () 122 | -- |Callback from ObjC to trigger the '_viewController_didReceiveMemoryWarning' callback. 123 | genericViewController_didReceiveMemoryWarning 124 | :: StablePtr (ViewControllerConfig a) 125 | -> MainThread () 126 | genericViewController_didReceiveMemoryWarning configPtr = do 127 | ViewControllerConfig {..} <- liftIO $ deRefStablePtr configPtr 128 | _viewController_didReceiveMemoryWarning _viewController_a 129 | 130 | 131 | -------------------------------------------------------------------------------- /hs-uikit/src/ObjC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | -- |Basic types and functionality for interoperating with Objective-C for using UIKit. 5 | -- 6 | -- Objective-C is a reference counted object oriented language with classes, objects which are instances of those classes, and protocols describing common 7 | -- behavior among classes. 8 | -- 9 | -- Objective-C classes are represented by type tokens, data types with no constructors used as phantom type parameters to 'ObjPtr's which represent pointers 10 | -- to object instances. Protocols are represented as classes since they only describe what methods can be used on an instance like classes do and are otherwise 11 | -- an ObjC implementation detail. 12 | -- 13 | -- Objective-C supports nominal subtyping by way of classes extending other classes. This relationship is embedded on the Haskell side along with protocol 14 | -- conformance using the @'SafeObjType' from to@ typeclass, whose instances describe which ObjC types are subtypes of others. 'coerceObj' allows for safe 15 | -- coercion of a subtype to its supertype, while 'downCastObj' allows for explicit (possibly unsafe) casting from a supertype to a subtype. 16 | -- 17 | -- Objective-C reference counting is supported via 'ObjPtr' which wraps a pointer to the Objective-C object along with retainment characteristics. 18 | module ObjC 19 | ( 20 | -- * Object pointers and coercions 21 | ObjPtr(..), withObjPtr 22 | , SafeObjCoerce, coerceObj, downCastObj 23 | -- * @id@ / @NSObject@ 24 | , ObjType, Obj, asObj 25 | -- * @BOOL@ 26 | , yes, no, objcBool, unObjcBool 27 | -- * Reference counting 28 | , retainObj 29 | -- * Raw FFI bindings 30 | , hsobjc_retain, hsobjc_release 31 | ) where 32 | 33 | import Control.Monad ((=<<)) 34 | import Control.Monad.IO.Class (MonadIO, liftIO) 35 | import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM) 36 | import Data.Bool (Bool(True, False), bool) 37 | import Foreign.C.Types (CChar) 38 | import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, newForeignPtr, withForeignPtr) 39 | import Foreign.Ptr (FunPtr, Ptr) 40 | 41 | 42 | -- |Reference to an Objective-C object of type @a@, a type token representing a class or protocol. 43 | -- 44 | -- Presently only has one retainment style, @ObjPtr_Owned@, where the retain count was incremented when the object was adopted by the Haskell RTS which will be 45 | -- released when the @ObjPtr@ is finalized by the Haskell GC. Might be extended in the future to support borrowing where the retain count is not incremented, 46 | -- as that's more memory efficient for callbacks and similar albeit more dangerous. 47 | newtype ObjPtr a = ObjPtr_Owned { _objPtr_value :: ForeignPtr a } 48 | 49 | -- |Execute some 'IO' action using the actual 'Ptr' represented by an 'ObjPtr'. 50 | -- 51 | -- __Caution:__ Do not refer to the @Ptr@ outside of the action, as the reference to the @ObjPtr@ might have gone out of scope and the pointer finalized, 52 | -- causing the referent to be released. See 'ForeignPtr' for more. 53 | {-# INLINABLE withObjPtr #-} 54 | withObjPtr :: MonadBaseControl IO m => ObjPtr a -> (Ptr a -> m b) -> m b 55 | withObjPtr op = \ action -> 56 | restoreM =<< liftBaseWith (\ runInBase -> withForeignPtr (_objPtr_value op) (runInBase . action)) 57 | 58 | -- |Type token for any Objective-C object, usually conforming to @NSObject@. 59 | data ObjType 60 | -- |Pointer to some Objective-C object, analogous to Objective-C's @id@ type. 61 | type Obj = ObjPtr ObjType 62 | 63 | -- |Typeclass whose instances denote types which are subtypes of others and thus can be safely coerced. For example, @SafeObjCoerce NSStringType ObjType@ 64 | -- denotes that @NSString@ is a subtype of @id@ and thus can be safely coerced in that direction. 65 | class SafeObjCoerce from to 66 | -- |Any type is trivially and safely coerced to itself. 67 | instance {-# OVERLAPPABLE #-} SafeObjCoerce a a 68 | 69 | -- |Coerce an @'ObjPtr' a@ to an @'ObjPtr' b@ if an instance @'SafeObjCoerce' a b@ exists indicating that it's a safe coercion to perform. 70 | {-# INLINE coerceObj #-} 71 | coerceObj :: SafeObjCoerce from to => ObjPtr from -> ObjPtr to 72 | coerceObj = ObjPtr_Owned . castForeignPtr . _objPtr_value 73 | 74 | -- |Cast an @'ObjPtr' a@ to an @'ObjPtr' b@ if an instance @'SafeObjCoerce' b a@ indicates that there is some possible subtyping relationship present. This is 75 | -- unchecked at compile time and potentially unsafe as it's not known except at runtime whether the pointer really points to an instance conforming to @b@. 76 | {-# INLINE downCastObj #-} 77 | downCastObj :: SafeObjCoerce to from => ObjPtr from -> ObjPtr to 78 | downCastObj = ObjPtr_Owned . castForeignPtr . _objPtr_value 79 | 80 | -- |Raw FFI binding to @NSObject - retain@ by way of @CFBridgingRetain@. __Warning:__ while the typical naming strategy for binding functions is 81 | -- @haskellModule_method@, it is crucial this does not get named @objc_retain@, as the linker will silently replace the ObjC runtime function of the same name 82 | -- and then all calls to @retain@ will infinite loop. 83 | foreign import ccall hsobjc_retain :: Ptr a -> IO () 84 | -- |Raw FFI binding to @NSObject - release@ by way of @CFBridgingRelease@. __Warning:__ while the typical naming strategy for binding functions is 85 | -- @haskellModule_method@, it is crucial this does not get named @objc_release@, as the linker will silently replace the ObjC runtime function of the same name 86 | -- and then all calls to @release@ will infinite loop. 87 | foreign import ccall "&hsobjc_release" hsobjc_release :: FunPtr (Ptr a -> IO ()) 88 | 89 | -- |Increment the reference counter of an Objective-C object using 'hsobjc_retain' and then wrap it in an 'ObjPtr' which will decrement the reference later 90 | -- when the @ObjPtr@ is no longer referred to. 91 | {-# INLINABLE retainObj #-} 92 | retainObj :: (MonadIO m, SafeObjCoerce a ObjType) => Ptr a -> m (ObjPtr a) 93 | retainObj p = liftIO $ do 94 | hsobjc_retain p 95 | ObjPtr_Owned <$> newForeignPtr hsobjc_release p 96 | 97 | -- |Safely coerce any Objective-C object to 'Obj'. 98 | {-# INLINABLE asObj #-} 99 | asObj :: SafeObjCoerce a ObjType => ObjPtr a -> Obj 100 | asObj = coerceObj 101 | 102 | -- |Constant corresponding to Objective-C's @NO@ of type @BOOl@ (a type alias for @char@). 103 | {-# INLINABLE no #-} 104 | no :: CChar 105 | no = 0 106 | 107 | -- |Constant corresponding to Objective-C's @NO@ of type @BOOl@ (a type alias for @char@). 108 | {-# INLINABLE yes #-} 109 | yes :: CChar 110 | yes = 1 111 | 112 | -- |Convert a Haskell 'Bool' to an Objective-C @BOOL@ ('CChar'). 113 | {-# INLINABLE objcBool #-} 114 | objcBool :: Bool -> CChar 115 | objcBool = bool no yes 116 | 117 | -- |Convert an Objective-C @BOOL@ ('CChar') to a Haskell 'Bool'. 118 | {-# INLINABLE unObjcBool #-} 119 | unObjcBool :: CChar -> Bool 120 | unObjcBool c = if c == 0 then False else True 121 | 122 | -------------------------------------------------------------------------------- /reflex-native-uikit/src/Reflex/UIKit/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# OPTIONS_GHC -fspecialise-aggressively #-} 5 | -- |Functions for starting a Reflex UIKit application, all the way from @UIApplicationMain@ up to your application's root Reflex Native builder. 6 | module Reflex.UIKit.Main 7 | ( 8 | -- * Running an application or view controller 9 | run, runViewController 10 | -- * Specific types in UIKit apps 11 | , UIKitHost, runUIKitHost, UIKitTimeline, UIKitWidget 12 | ) where 13 | 14 | import Control.Applicative ((<$>), pure) 15 | import Control.Concurrent (forkOS) 16 | import Control.Concurrent.Chan (Chan, newChan, readChan) 17 | import Control.Monad ((=<<), forever) 18 | import Control.Monad.IO.Class (liftIO) 19 | import Control.Monad.Ref (readRef) 20 | import Data.Dependent.Sum (DSum((:=>))) 21 | import Data.Foldable (for_) 22 | import Data.Functor (void) 23 | import Data.Functor.Identity (Identity(..)) 24 | import Data.IORef (IORef, readIORef) 25 | import Data.Maybe (Maybe, catMaybes) 26 | import Data.Traversable (for) 27 | import Foreign.StablePtr (newStablePtr) 28 | import Reflex.UIKit.Specializations () -- for SPECIALIZATION pragmas 29 | import Reflex.UIKit.ViewBuilder (UIKitViewBuilderT, runUIKitViewBuilderT, _buildFrame_retainObjs, _env_frame) 30 | import Reflex.Host.Class (ReflexHost(type EventTrigger), newEventWithTriggerRef) 31 | import Reflex.PerformEvent.Base (FireCommand(..), PerformEventT, hostPerformEventT) 32 | import Reflex.PostBuild.Base (PostBuildT, runPostBuildT) 33 | import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost) 34 | import Reflex.TriggerEvent.Base (EventTriggerRef(..), TriggerInvocation(..)) 35 | import UIKit.Generic.AppDelegate (AppDelegateConfig(_appDelegate_didFinishLaunchingWithOptions), defaultAppDelegateConfig, runGenericApplication) 36 | import UIKit.Generic.View (defaultViewConfig) 37 | import UIKit.Generic.ViewController (defaultViewControllerConfig) 38 | import qualified UIKit.Generic.View as View 39 | import qualified UIKit.Generic.ViewController as ViewController 40 | import UIKit.Types (MainThread(..), UIView, UIViewController, unsafeInMainThread) 41 | import UIKit.UIColor (colorWithRedGreenBlueAlpha) 42 | import qualified UIKit.UIView as UIView 43 | import qualified UIKit.UIViewController as UIViewController 44 | import qualified UIKit.UIWindow as UIWindow 45 | 46 | 47 | -- |The underlying Reflex host monad used for UIKit applications, @SpiderHost@. 48 | type UIKitHost = SpiderHost Global 49 | 50 | -- |The Reflex timeline in use for UIKit applications (@t@), @Spider@. 51 | type UIKitTimeline = Spider 52 | 53 | -- |The concrete type conforming to 'Reflex.Native.MonadNativeConstraints' that UIKit apps run in. 54 | type UIKitWidget = PostBuildT UIKitTimeline (UIKitViewBuilderT UIKitTimeline (PerformEventT UIKitTimeline UIKitHost)) 55 | 56 | -- |How to run the underlying Reflex host monad 'UIKitHost' as an 'IO' action ('runSpiderHost'). 57 | runUIKitHost :: UIKitHost a -> IO a 58 | runUIKitHost = runSpiderHost 59 | 60 | -- |Run a @UIApplication@ using a generic app delegate which uses the given builder function to create and run the root view controller. 61 | {-# INLINABLE run #-} 62 | run :: (UIView -> UIKitWidget ()) -> IO () 63 | run mkRootWidget = runGenericApplication config 64 | where 65 | config = (defaultAppDelegateConfig ()) 66 | { _appDelegate_didFinishLaunchingWithOptions } 67 | _appDelegate_didFinishLaunchingWithOptions _ _app _launchOptions window = do 68 | viewController <- runViewController (\ _ -> mkRootWidget) 69 | UIWindow.setRootViewController window viewController 70 | UIWindow.makeKeyAndVisible window 71 | pure True 72 | 73 | -- |Run a view controller using the given builder to create and run the root view hierarchy. 74 | -- 75 | -- __Warning:__ This function presently leaks an asynchronous message processing thread so should not be used for short lived controllers. 76 | {-# INLINABLE runViewController #-} 77 | runViewController :: (UIViewController -> UIView -> UIKitWidget ()) -> MainThread UIViewController 78 | runViewController mkWidget = fst <$> ViewController.new initializeController 79 | where 80 | initializeController vc = do 81 | (rootView, _) <- View.new $ \ v -> do 82 | UIView.setAutoresizesSubviews v False 83 | UIView.setAutoresizingMask v 0 84 | pure (defaultViewConfig ()) 85 | 86 | unsafeInMainThread $ UIView.setBackgroundColor rootView =<< liftIO (colorWithRedGreenBlueAlpha 1.0 0.5 0.0 1.0) 87 | UIViewController.setView vc rootView 88 | 89 | let widget = mkWidget vc rootView 90 | 91 | ((env, events), fireCommand) <- liftIO . attachWidget'' $ \ events -> do 92 | (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef 93 | (_, env) <- runUIKitViewBuilderT (runPostBuildT widget postBuild) rootView events 94 | pure ((env, events), postBuildTriggerRef) 95 | 96 | -- FIXME hold on to the root retain objs forever. any objects retained by a dynamic component of the initial build will not be in the root retain objs 97 | -- but instead held by the Requester, and we don't support end of lifetime for these view controllers anyway by virtue of processAsyncEvents running 98 | -- forever 99 | void . liftIO . newStablePtr . _buildFrame_retainObjs . _env_frame $ env 100 | 101 | liftIO $ processAsyncEvents events fireCommand -- FIXME runs forever, even if the view controller is only used for a short time 102 | pure $ defaultViewControllerConfig () 103 | 104 | -- |Type of channel used to pass event firings from the build or asynchronous activities resulting from the build such as native event handlers to the 105 | -- asynchronous event loop implemented by 'processAsyncEvents'. 106 | type EventChannel = Chan [DSum (EventTriggerRef UIKitTimeline) TriggerInvocation] 107 | 108 | -- |Set up a fully working builder support environment with event processing and then invoke the action with the 'EventChannel'. 109 | {-# INLINABLE attachWidget'' #-} 110 | attachWidget'' 111 | :: (EventChannel -> PerformEventT UIKitTimeline UIKitHost (a, IORef (Maybe (EventTrigger UIKitTimeline ())))) 112 | -> IO (a, FireCommand UIKitTimeline UIKitHost) 113 | attachWidget'' f = do 114 | events <- newChan 115 | runUIKitHost $ do 116 | ((result, postBuildTriggerRef), fireCommand@(FireCommand fire)) <- hostPerformEventT $ f events 117 | postBuildTriggerMay <- readRef postBuildTriggerRef 118 | for_ postBuildTriggerMay $ \ postBuildTrigger -> 119 | fire [postBuildTrigger :=> Identity ()] (pure ()) 120 | pure (result, fireCommand) 121 | 122 | -- |Loop forever waiting for events to show up on the given 'EventChannel' and process the firings back in the main thread. 123 | processAsyncEvents :: EventChannel -> FireCommand UIKitTimeline UIKitHost -> IO () 124 | processAsyncEvents events (FireCommand fire) = 125 | void . forkOS . forever $ do 126 | eventRequests <- readChan events 127 | void . runUIKitHost $ do 128 | requestMays <- liftIO . for eventRequests $ \ (EventTriggerRef requestMayRef :=> TriggerInvocation a _) -> do 129 | requestMay <- readIORef requestMayRef 130 | pure $ (:=> Identity a) <$> requestMay 131 | _ <- fire (catMaybes requestMays) (pure ()) 132 | liftIO . for_ eventRequests $ \ (_ :=> TriggerInvocation _ cb) -> cb 133 | 134 | 135 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/Widget/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | -- |Basic widgets based on the 'ViewBuilder' abstraction. 3 | -- 4 | -- Each type of widget usually has several flavors, though not every widget has every flavor. The flavors are: 5 | -- 6 | -- * @widget@ - default styled version, returning the created view. 7 | -- * @widget_@ - default styled version, returning @()@ or your action's @a@ only. 8 | -- * @widgetWith@ - version customized as given, returning the created view. See "Reflex.Native.Widget.Customization" for the 'Customization' type and 9 | -- various constructors for it. 10 | -- * @widgetWith_@ - customized widget returning @()@ or @a@. 11 | -- constructors for it. 12 | -- * @dynWidget@ - for widgets that have some displayed value, the version without @dyn@ shows a static value while the @dyn@ version tracks a 'Dynamic' 13 | -- over time and returns the created view. See "Reflex.Native.Test.Widget.Basic#dynTiming". 14 | -- * @dynWidget_@ - dynamic valued widget returning @()@ or @a@. 15 | -- * @dynWidgetWith@ - dynamic valued widget with customizations. 16 | -- * @dynWidgetWith_@ - dynamic valued widget with customzations returning @()@ or @a@. 17 | -- 18 | -- #dynTiming# 19 | -- == Timing of @dyn@ widgets 20 | -- 21 | -- To avoid accidental causality loops, these versions always delay their initial display until the next frame though this should be unnoticeable - see 22 | -- 'notReadyUntil'. 23 | module Reflex.Native.Widget.Basic 24 | ( 25 | -- * Plain container views 26 | container, container_, containerWith, containerWith_ 27 | -- * Test display views 28 | , text, text_, textWith, textWith_, dynText, dynText_, dynTextWith, dynTextWith_ 29 | ) where 30 | 31 | import Data.Functor (void) 32 | import Data.Text (Text) 33 | import Reflex.Class (Dynamic, current, leftmost, tag, updated) 34 | import Reflex.Native.TextConfig (TextConfig(..), defaultTextConfig) 35 | import Reflex.Native.Widget.Customization (Customization(..)) 36 | import Reflex.Native.ViewBuilder.Class (TextView, View, ViewBuilder(type ViewBuilderSpace, buildView, buildTextView)) 37 | import Reflex.Native.ViewConfig (ViewConfig(..), defaultViewConfig) 38 | import Reflex.NotReady.Class (NotReady, notReadyUntil) 39 | import Reflex.PostBuild.Class (PostBuild, getPostBuild) 40 | 41 | 42 | -- |Build a plain container view with some hierarchy inside and the 'defaultViewConfig'. 43 | container 44 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 45 | => m a 46 | -- ^The child hierarchy to build inside the container. 47 | -> m (a, View (ViewBuilderSpace m) t) 48 | container = containerWith mempty 49 | 50 | -- |Build a plain container view with some hierarchy inside and the 'defaultViewConfig'. 51 | container_ 52 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 53 | => m a 54 | -- ^The child hierarchy to build inside the container. 55 | -> m a 56 | container_ = fmap fst . container 57 | 58 | -- |Build a plain container view with some hierarchy inside and the 'defaultViewConfig' but with the 'ViewStyle' tweaked using the given function. 59 | containerWith 60 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 61 | => Customization t (ViewConfig t) 62 | -- ^The customization to apply. See "Reflex.Native.Widget.Customization". 63 | -> m a 64 | -- ^The child hierarchy to build inside the container. 65 | -> m (a, View (ViewBuilderSpace m) t) 66 | containerWith customization body = case customization of 67 | Customization_Immediate f -> buildView (f defaultViewConfig) body 68 | Customization_PostBuild f -> do 69 | pb <- getPostBuild 70 | notReadyUntil pb 71 | buildView (f pb defaultViewConfig) body 72 | 73 | -- |Build a plain container view with some hierarchy inside and the 'defaultViewConfig' but with the 'ViewStyle' tweaked using the given function. 74 | containerWith_ 75 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 76 | => Customization t (ViewConfig t) 77 | -- ^The customization to apply. See "Reflex.Native.Widget.Customization". 78 | -> m a 79 | -- ^The child hierarchy to build inside the container. 80 | -> m a 81 | containerWith_ f = fmap fst . containerWith f 82 | 83 | -- |Build a plain static text view with the given text and the 'defaultTextConfig'. 84 | text 85 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 86 | => Text 87 | -- ^The text to display. 88 | -> m (TextView (ViewBuilderSpace m) t) 89 | text = textWith mempty 90 | 91 | -- |Build a plain static text view with the given text and the 'defaultTextConfig'. 92 | text_ 93 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 94 | => Text 95 | -- ^The text to display. 96 | -> m () 97 | text_ = void . text 98 | 99 | -- |Build a static text view with the given text and the 'defaultTextConfig' customized using the given function. 100 | textWith 101 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 102 | => Customization t (TextConfig t) 103 | -- ^The customization to apply. See "Reflex.Native.Widget.Customization". 104 | -> Text 105 | -- ^The text to display. 106 | -> m (TextView (ViewBuilderSpace m) t) 107 | textWith customization t = case customization of 108 | Customization_Immediate f -> buildTextView (f $ defaultTextConfig { _textConfig_initialText = t }) 109 | Customization_PostBuild f -> do 110 | pb <- getPostBuild 111 | notReadyUntil pb 112 | buildTextView (f pb $ defaultTextConfig { _textConfig_initialText = t }) 113 | 114 | -- |Build a static text view with the given text and the 'defaultTextConfig' customized using the given function. 115 | textWith_ 116 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 117 | => Customization t (TextConfig t) 118 | -- ^The customization to apply. See "Reflex.Native.Widget.Customization". 119 | -> Text 120 | -- ^The text to display. 121 | -> m () 122 | textWith_ f t = void $ textWith f t 123 | 124 | -- |Build a plain dynamic text view with the given dynamically updating text and the 'defaultTextConfig'. 125 | dynText 126 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 127 | => Dynamic t Text 128 | -- ^The text to display over time. 129 | -> m (TextView (ViewBuilderSpace m) t) 130 | dynText = dynTextWith mempty 131 | 132 | -- |Build a plain dynamic text view with the given dynamically updating text and the 'defaultTextConfig'. 133 | dynText_ 134 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 135 | => Dynamic t Text 136 | -- ^The text to display over time. 137 | -> m () 138 | dynText_ = void . dynText 139 | 140 | -- |Build a dynamic text view with the given dynamically updating text and the 'defaultTextConfig' customized using the given function. 141 | dynTextWith 142 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 143 | => Customization t (TextConfig t) 144 | -- ^The customization to apply. See "Reflex.Native.Widget.Customization". 145 | -> Dynamic t Text 146 | -- ^The text to display over time. 147 | -> m (TextView (ViewBuilderSpace m) t) 148 | dynTextWith customization dt = do 149 | pb <- getPostBuild 150 | let f = case customization of 151 | Customization_Immediate g -> g 152 | Customization_PostBuild g -> g pb 153 | notReadyUntil pb 154 | buildTextView . f $ defaultTextConfig { _textConfig_setText = Just $ leftmost [updated dt, tag (current dt) pb] } 155 | 156 | -- |Build a dynamic text view with the given dynamically updating text and the 'defaultTextConfig' customized using the given function. 157 | dynTextWith_ 158 | :: (NotReady t m, PostBuild t m, ViewBuilder t m) 159 | => Customization t (TextConfig t) 160 | -- ^The customization to apply. See "Reflex.Native.Widget.Customization". 161 | -> Dynamic t Text 162 | -- ^The text to display over time. 163 | -> m () 164 | dynTextWith_ f dt = void $ dynTextWith f dt 165 | 166 | -------------------------------------------------------------------------------- /reflex-native-test/src/Reflex/Native/Test/Runner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | -- |Test harness for running cross-platform components in 'TestViewBuilder' with isolated Spider instance. 11 | module Reflex.Native.Test.Runner 12 | ( TestWidget, withTestHost, testWith, processEventsAndRead, processEvents ) where 13 | 14 | import Control.Concurrent.Chan (newChan, readChan, writeChan) 15 | import Control.Concurrent.STM (atomically) 16 | import Control.Concurrent.STM.TVar (newTVarIO, readTVarIO, writeTVar) 17 | import Control.Monad ((<=<), when) 18 | import Control.Monad.IO.Class (MonadIO, liftIO) 19 | import Control.Monad.RWS.Strict (ask, put, runRWST) 20 | import Control.Monad.Trans.Class (lift) 21 | import Data.DList (DList) 22 | import qualified Data.DList as DList 23 | import Data.Dependent.Sum (DSum((:=>))) 24 | import Data.Foldable (for_) 25 | import Data.Functor (void) 26 | import Data.Functor.Identity (Identity(..)) 27 | import Data.IORef (readIORef) 28 | import Data.List.NonEmpty (NonEmpty, nonEmpty) 29 | import Data.Maybe (catMaybes, isJust, maybe) 30 | import Data.Proxy (Proxy(..)) 31 | import Data.Sequence (Seq) 32 | import qualified Data.Sequence as Seq 33 | import Data.Traversable (for) 34 | import Reflex.Class (MonadHold, MonadSample) 35 | import Reflex.Host.Class (MonadReadEvent(readEvent), newEventWithTriggerRef, subscribeEvent) 36 | import Reflex.Native.Test.Types (TestEnv(..), TestEvaluation(..), TestHolder, TestView, traverseTestView) 37 | import Reflex.Native.Test.ViewBuilder (BuildFrame(..), Env(..), TestViewBuilderT, runTestViewBuilderT) 38 | import Reflex.PerformEvent.Base (FireCommand(..), PerformEventT, hostPerformEventT) 39 | import Reflex.PostBuild.Base (PostBuildT, runPostBuildT) 40 | import Reflex.Spider.Internal (HasSpiderTimeline, SpiderHost, SpiderTimeline, SpiderTimelineEnv, runSpiderHostForTimeline, withSpiderTimeline) 41 | import Reflex.TriggerEvent.Base (EventTriggerRef(..), TriggerInvocation(..)) 42 | 43 | 44 | -- |The type conforming to 'Reflex.Native.MonadNativeConstraints' that test widgets run as. 45 | type TestWidget x = PostBuildT (SpiderTimeline x) (TestViewBuilderT (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))) 46 | 47 | -- |Helper function used by 'testWith' and 'processEventsAndRead' to read out the current state of the view hierarchy. 48 | snapshotViewHierarchy :: MonadIO m => TestHolder -> m (Seq (TestView Identity)) 49 | snapshotViewHierarchy rootHolder = 50 | liftIO $ traverse (traverseTestView (\ f -> fmap Identity . f <=< readTVarIO)) =<< readTVarIO rootHolder 51 | 52 | -- |Enter an environment where 'testWith' can be run by creating a local Spider timeline for the test to execute in. 53 | -- 54 | -- Usually one or more 'testWith' invocations are run inside. Do not execute test concurrently within a single test host. 55 | withTestHost 56 | :: (forall proxy t x. (t ~ SpiderTimeline x, HasSpiderTimeline x) => proxy t -> SpiderHost x a) 57 | -> IO a 58 | withTestHost action = 59 | withSpiderTimeline $ \ (env :: SpiderTimelineEnv x) -> 60 | runSpiderHostForTimeline (action (Proxy @(SpiderTimeline x))) env 61 | 62 | -- |Test a widget by running its first build and then performing a series of evaluation steps. Usually wrapped by 'withTestHost'. 63 | testWith 64 | :: HasSpiderTimeline x 65 | => TestWidget x a 66 | -- ^The build to run. 67 | -> (a -> TestEvaluation x b) 68 | -- ^The evaluation program to execute after the build is complete. 69 | -> SpiderHost x b 70 | testWith widget evaluation = do 71 | _testEnv_rootHolder <- liftIO $ newTVarIO Seq.empty 72 | _testEnv_rootReady <- liftIO $ newTVarIO False 73 | _testEnv_eventChan <- liftIO newChan 74 | (stepCompleteEvent, _testEnv_stepCompleteTriggerRef) <- newEventWithTriggerRef 75 | (postBuildEvent, postBuildTriggerMayRef) <- newEventWithTriggerRef 76 | 77 | _testEnv_stepCompleteEventHandle <- subscribeEvent stepCompleteEvent 78 | 79 | ((a, env), _testEnv_fireCommand) <- hostPerformEventT $ do 80 | runTestViewBuilderT (runPostBuildT widget postBuildEvent) _testEnv_rootHolder (atomically $ writeTVar _testEnv_rootReady True) _testEnv_eventChan 81 | unreadyChildren <- liftIO . readTVarIO . _buildFrame_unreadyChildren . _env_frame $ env 82 | when (unreadyChildren == 0) $ 83 | liftIO . atomically . writeTVar _testEnv_rootReady $ True 84 | postBuildTriggerMay <- liftIO $ readIORef postBuildTriggerMayRef 85 | for_ postBuildTriggerMay $ \ trigger -> 86 | runFireCommand _testEnv_fireCommand [trigger :=> Identity ()] (pure ()) 87 | 88 | (b, _, _) <- runRWST (unTestEvaluation (evaluation a)) (TestEnv {..}) =<< snapshotViewHierarchy _testEnv_rootHolder 89 | pure b 90 | 91 | -- |Process any pending event triggers until no more are pending, then process a read phase to read out states of @Event@s, @Behavior@s, or @Dynamic@s. 92 | -- 93 | -- __Note on read actions:__ The read action may be performed many times, for two reasons. 94 | -- 95 | -- 1. Internally, 'PerformEventT' runs one or more event propagation passes and the precise 96 | -- number depends on how many times an event propagation triggers a performed event action; each time an event triggers a perform event, event propagation 97 | -- occurs again after action is performed, until no more perform event requests are made. 98 | -- 99 | -- Because each of these event propagations happen in a frame, if you read out an @Event@ using 'MonadReadEvent', then unless your @Event@ fires on each of the 100 | -- propagations it will be firing in only one of the returned results, so be careful to consider this when reading @Event@s. 101 | -- 102 | -- 2. @processEventsAndRead@ will process multiple batches of events until a marker event is processed and it can't know how many batches have been enqueued 103 | -- on the internal @Chan@ until that marker event shows up. Each of the batches is processed in a separate frame, like @PerformEventT@ from the previous point. 104 | processEventsAndRead 105 | :: forall x a. HasSpiderTimeline x 106 | => (forall m. (MonadReadEvent (SpiderTimeline x) m, MonadHold (SpiderTimeline x) m, MonadSample (SpiderTimeline x) m) => m a) 107 | -- ^Action to execute during the read phase allowing readout of @Event@s, @Behavior@s, and @Dynamic@s. 108 | -> TestEvaluation x (NonEmpty a) 109 | processEventsAndRead readAction = do 110 | TestEnv {..} <- TestEvaluation ask 111 | 112 | liftIO $ writeChan _testEnv_eventChan [EventTriggerRef _testEnv_stepCompleteTriggerRef :=> TriggerInvocation () (pure ())] 113 | 114 | let processBatches :: DList a -> SpiderHost x (DList a) 115 | processBatches prevReadResults = do 116 | eventRequests <- liftIO $ readChan _testEnv_eventChan 117 | 118 | requestMays <- liftIO . for eventRequests $ \ (EventTriggerRef requestMayRef :=> TriggerInvocation a _) -> do 119 | fmap (:=> Identity a) <$> readIORef requestMayRef 120 | (completes, readResults) <- fmap unzip $ 121 | runFireCommand _testEnv_fireCommand (catMaybes requestMays) $ 122 | ((,) <$> readEvent _testEnv_stepCompleteEventHandle <*> readAction) 123 | liftIO . for_ eventRequests $ \ (_ :=> TriggerInvocation _ cb) -> cb 124 | 125 | (if any isJust completes then pure else processBatches) (DList.append prevReadResults (DList.fromList readResults)) 126 | 127 | readResultsList <- TestEvaluation . lift $ DList.toList <$> processBatches DList.empty 128 | readResultsNonEmpty <- 129 | maybe (fail "read results should have been nonempty, but runFireCommand ran the read phase zero times?") pure (nonEmpty readResultsList) 130 | 131 | TestEvaluation . put =<< snapshotViewHierarchy _testEnv_rootHolder 132 | 133 | pure readResultsNonEmpty 134 | 135 | -- |Process any pending event triggers until no more are pending. A simpler version of 'processEventsAndRead' when you don't need to inspect the state of the 136 | -- FRP network after each propagation. 137 | processEvents :: forall x. HasSpiderTimeline x => TestEvaluation x () 138 | processEvents = void $ processEventsAndRead (pure ()) 139 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | -- |Pointer types and type tokens from the @UIKit@ framework, along with an abstraction for making @UIKit@ functions and methods which must only run on the 7 | -- main (UI) thread more safe. 8 | module UIKit.Types 9 | ( 10 | -- * 'MainThread' and associated functionality 11 | MainThread(..), unsafeInMainThread, checkMainThread, isMainThread, dispatchAsyncMain 12 | -- * Pointer types 13 | , UIApplication, UIColor, UIFont, UIGestureRecognizer, UIPanGestureRecognizer, UILabel, UIView, UIViewController, UIWindow 14 | -- * Type coercions 15 | , asUIGestureRecognizer, asUIView, asUIViewController 16 | -- * Type tokens 17 | , UIApplicationType, UIColorType, UIFontType, UIGestureRecognizerType, UIPanGestureRecognizerType, UILabelType, UIViewType, UIViewControllerType, UIWindowType 18 | -- * Raw FFI bindings 19 | , mainThread_checkMainThread, mainThread_isMainThread, mainThread_inMainThread, mainThread_dispatchAsyncMain 20 | ) where 21 | 22 | import Control.Applicative (Applicative, Alternative) 23 | import Control.Monad (Monad, MonadPlus, (<=<)) 24 | import Control.Monad.Base (MonadBase) 25 | import Control.Monad.Fail (MonadFail) 26 | import Control.Monad.Fix (MonadFix) 27 | import Control.Monad.IO.Class (MonadIO, liftIO) 28 | import Control.Monad.Trans.Control (MonadBaseControl) 29 | import Data.Functor (Functor) 30 | import Foreign.C.Types (CChar(..)) 31 | import Foreign.StablePtr (StablePtr, deRefStablePtr, freeStablePtr, newStablePtr) 32 | import ObjC (ObjPtr, ObjType, SafeObjCoerce, coerceObj, unObjcBool) 33 | 34 | 35 | -- |Wrapped 'IO' action which should only ever be executed on the main UIKit thread. 36 | -- 37 | -- See 'dispatchAsyncMain' for a way to schedule a @MainThread@ action on the main thread using Grand Central Dispatch. 38 | -- See 'isMainThread' for a way to test if the currently executing thread is the main thread. 39 | -- See 'unsafeInMainThread' for a way to execute a @MainThread@ action on the current thread, hopefully after checking that it's the main thread. 40 | newtype MainThread a = MainThread { unsafeUnMainThread :: IO a } 41 | deriving instance Alternative MainThread 42 | deriving instance Applicative MainThread 43 | deriving instance Functor MainThread 44 | deriving instance Monad MainThread 45 | deriving instance MonadBase IO MainThread 46 | deriving instance MonadBaseControl IO MainThread 47 | deriving instance MonadFail MainThread 48 | deriving instance MonadFix MainThread 49 | deriving instance MonadIO MainThread 50 | deriving instance MonadPlus MainThread 51 | 52 | -- |Unwrap a 'MainThread' via 'unsafeUnMainThread' and 'liftIO' it. Unsafe because there's no check that the thread the resulting @m a@ executes on is in fact 53 | -- the main thread. 54 | unsafeInMainThread :: MonadIO m => MainThread a -> m a 55 | unsafeInMainThread = liftIO . unsafeUnMainThread 56 | 57 | -- |Raw FFI binding which checks if the current thread is the main thread and logs a warning (via @os_log@) if not. 58 | foreign import ccall unsafe mainThread_checkMainThread :: IO () 59 | -- |Check if the currently executing thread is the main thread and log a warning via @os_log@ if not. Used at key entry points to provide a point to diagnose 60 | -- issues with actions running on the wrong thread. 61 | checkMainThread :: IO () 62 | checkMainThread = mainThread_checkMainThread 63 | 64 | -- |Raw FFI binding to @NSThread + isMainThread@. 65 | foreign import ccall unsafe mainThread_isMainThread :: IO CChar 66 | -- |@NSThread + isMainThread@ - return @True@ iff the currently executing thread is the main UIKit thread, and thus 'MainThread' actions are safe to execute. 67 | isMainThread :: IO Bool 68 | isMainThread = unObjcBool <$> mainThread_isMainThread 69 | 70 | foreign export ccall mainThread_inMainThread :: StablePtr (MainThread ()) -> IO () 71 | -- |Raw FFI callback from C code to execute a 'MainThread' action referred to by a 'StablePtr'. 72 | mainThread_inMainThread :: StablePtr (MainThread ()) -> IO () 73 | mainThread_inMainThread callbackPtr = do 74 | callback <- liftIO $ deRefStablePtr callbackPtr 75 | liftIO $ freeStablePtr callbackPtr 76 | unsafeUnMainThread callback 77 | 78 | -- |Raw FFI binding to @dispatch_async(dispatch_get_main_queue(), ^{ … })@. 79 | foreign import ccall unsafe mainThread_dispatchAsyncMain :: StablePtr (MainThread ()) -> IO () 80 | -- |Arrange for a 'MainThread' action to be later executed on the main UIKit thread using the Grand Central Dispatch @dispatch_async@ function. 81 | -- 82 | -- The action will be executed approximately when the next @UIApplicationMain@ top level loop iteration occurs, though GCD does not give precise guarantees on 83 | -- whether that will be the next iteration or some later one. 84 | dispatchAsyncMain :: MainThread () -> IO () 85 | dispatchAsyncMain = mainThread_dispatchAsyncMain <=< newStablePtr 86 | 87 | -- |Safely coerce an object pointer to 'UIGestureRecognizer'. 88 | asUIGestureRecognizer :: SafeObjCoerce a UIGestureRecognizerType => ObjPtr a -> UIGestureRecognizer 89 | asUIGestureRecognizer = coerceObj 90 | 91 | -- |Safely coerce an object pointer to 'UIView'. 92 | asUIView :: SafeObjCoerce a UIViewType => ObjPtr a -> UIView 93 | asUIView = coerceObj 94 | 95 | -- |Safely coerce an object pointer to 'UIViewController'. 96 | asUIViewController :: SafeObjCoerce a UIViewControllerType => ObjPtr a -> UIViewController 97 | asUIViewController = coerceObj 98 | 99 | -- |Type token representing @UIApplication@. 100 | data UIApplicationType 101 | -- |Pointer to a @UIApplication@ instance. See "UIKit.UIApplication" for methods pertaining to @UIColor@. 102 | type UIApplication = ObjPtr UIApplicationType 103 | instance SafeObjCoerce UIApplicationType ObjType 104 | 105 | -- |Type token representing @UIColor@. 106 | data UIColorType 107 | -- |Pointer to a @UIColor@ instance. See "UIKit.UIColor" for methods pertaining to @UIColor@. 108 | type UIColor = ObjPtr UIColorType 109 | instance SafeObjCoerce UIColorType ObjType 110 | 111 | -- |Type token representing @UIFont@. 112 | data UIFontType 113 | -- |Pointer to a @UIFont@ instance. See "UIKit.UIFont" for methods pertaining to @UIFont@. 114 | type UIFont = ObjPtr UIFontType 115 | instance SafeObjCoerce UIFontType ObjType 116 | 117 | -- |Type token representing @UIGestureRecognizer@. 118 | data UIGestureRecognizerType 119 | -- |Pointer to a @UIGestureRecognizer@ instance. See "UIKit.UIGestureRecognizer" for methods pertaining to @UIGestureRecognizer@ and its subclasses. 120 | type UIGestureRecognizer = ObjPtr UIGestureRecognizerType 121 | instance SafeObjCoerce UIGestureRecognizerType ObjType 122 | 123 | -- |Type token representing @UIGestureRecognizer@. 124 | data UIPanGestureRecognizerType 125 | -- |Pointer to a @UIGestureRecognizer@ instance. See "UIKit.UIGestureRecognizer" for methods pertaining to @UIGestureRecognizer@ and its subclasses. 126 | type UIPanGestureRecognizer = ObjPtr UIPanGestureRecognizerType 127 | instance SafeObjCoerce UIPanGestureRecognizerType ObjType 128 | instance SafeObjCoerce UIPanGestureRecognizerType UIGestureRecognizerType 129 | 130 | -- |Type token representing @UILabel@. 131 | data UILabelType 132 | -- |Pointer to a @UILabel@ instance. See "UIKit.UILabel" for methods pertaining to @UILabel@ and its subclasses. 133 | type UILabel = ObjPtr UILabelType 134 | instance SafeObjCoerce UILabelType ObjType 135 | instance SafeObjCoerce UILabelType UIViewType 136 | 137 | -- |Type token representing @UIView@. 138 | data UIViewType 139 | -- |Pointer to a @UIView@ instance. See "UIKit.UIView" for methods pertaining to @UIView@ and its subclasses. 140 | type UIView = ObjPtr UIViewType 141 | instance SafeObjCoerce UIViewType ObjType 142 | 143 | -- |Type token representing @UIViewController@. 144 | data UIViewControllerType 145 | -- |Pointer to a @UIViewController@ instance. See "UIKit.UIViewController" for methods pertaining to @UIViewController@ and its subclasses. 146 | type UIViewController = ObjPtr UIViewControllerType 147 | instance SafeObjCoerce UIViewControllerType ObjType 148 | 149 | -- |Type token representing @UIWindow@. 150 | data UIWindowType 151 | -- |Pointer to a @UIWindow@ instance. See "UIKit.UIWindow" for methods pertaining to @UIWindow@ and its subclasses. 152 | type UIWindow = ObjPtr UIWindowType 153 | instance SafeObjCoerce UIWindowType ObjType 154 | instance SafeObjCoerce UIWindowType UIViewType 155 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/Widget/Customization.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | -- |Optics for conveniently customizing view configuration structures, typically used in conjunction with the @widgetWith@ widget building function flavor from 8 | -- "Reflex.Native.Widget.Basic". 9 | -- 10 | -- For example: 11 | -- 12 | -- @ 13 | -- import Control.Lens ((.~)) 14 | -- import qualified Reflex.Native.Color as Color 15 | -- import Reflex.Native.Widget.Basic (textWith_) 16 | -- import Reflex.Native.Widget.Customization (backgroundColor, textColor) 17 | -- 18 | -- textWith_ (backgroundColor .~ Color.gray . textColor .~ Color.red) "whoa!" 19 | -- @ 20 | module Reflex.Native.Widget.Customization 21 | ( 22 | -- * @Customization@ 23 | Customization(..) 24 | -- * Customizations for all views 25 | -- ** View styles 26 | , backgroundColor, dynBackgroundColor 27 | -- ** Other view properties 28 | , accessibilityLabel, dynAccessibilityLabel 29 | , layout, dynLayout 30 | -- * Customization for text views 31 | -- ** Text view styles 32 | , textColor, dynTextColor 33 | , textFont, dynTextFont 34 | -- * Helper classes and functions 35 | , HasViewConfig(..), initialViewStyle, modifyViewStyle, initialTextStyle, modifyTextStyle 36 | ) where 37 | 38 | import Control.Lens (Lens', set, view) 39 | import Data.Functor.Identity (Identity(..)) 40 | import Data.Generics.Product (field) 41 | import Data.Maybe (fromMaybe) 42 | import Data.Semigroup (Semigroup) 43 | import qualified Data.Semigroup as Semigroup 44 | import Data.Text (Text) 45 | import Reflex.Class (Dynamic, Event, Reflex, current, leftmost, tag, updated) 46 | import Reflex.Native.Color (Color) 47 | import Reflex.Native.Font (Font) 48 | import Reflex.Native.TextConfig (TextConfig) 49 | import Reflex.Native.TextStyle (TextStyle, defaultModifyTextStyle) 50 | import Reflex.Native.ViewConfig (ViewConfig) 51 | import Reflex.Native.ViewLayout (ViewLayout) 52 | import Reflex.Native.ViewStyle (ViewStyle, defaultModifyViewStyle) 53 | 54 | 55 | -- |Type which can customize some view configuration structure such as 'ViewConfig' or 'TextConfig'. 56 | -- 57 | -- The customization is represented either as a pure function @a -> a@ for customizations which can be applied immediately or as a customization 58 | -- @Event t () -> a -> a@ which relies on a @Dynamic@ and so the resulting view should not be ready immediately but instead at post build time. 59 | data Customization t a 60 | = Customization_Immediate (a -> a) 61 | | Customization_PostBuild (Event t () -> a -> a) 62 | 63 | -- |Right-biased composition of customizations - for customizations which overlap the rightmost wins. 64 | instance Semigroup (Customization t a) where 65 | {-# INLINE (<>) #-} 66 | Customization_Immediate f <> Customization_Immediate g = Customization_Immediate ( g . f ) 67 | Customization_Immediate f <> Customization_PostBuild g = Customization_PostBuild (\ e -> g e . f ) 68 | Customization_PostBuild f <> Customization_Immediate g = Customization_PostBuild (\ e -> g . f e) 69 | Customization_PostBuild f <> Customization_PostBuild g = Customization_PostBuild (\ e -> g e . f e) 70 | 71 | -- |Right-biased composition of customizations - for customizations which overlap the rightmost wins. 72 | instance Monoid (Customization t a) where 73 | mempty = Customization_Immediate id 74 | {-# INLINE mappend #-} 75 | mappend = (Semigroup.<>) 76 | 77 | -- |Set the background color of any view to a static color. 78 | backgroundColor :: HasViewConfig t s => Color -> Customization t s 79 | backgroundColor c = Customization_Immediate $ 80 | set (initialViewStyle . field @"_viewStyle_backgroundColor") (Identity c) 81 | 82 | -- |Dynamically set the background color of any view. 83 | dynBackgroundColor :: (Reflex t, HasViewConfig t s) => Dynamic t Color -> Customization t s 84 | dynBackgroundColor d = Customization_PostBuild $ \ pb -> 85 | modifyViewStyle $ set (field @"_viewStyle_backgroundColor") (leftmost [updated d, tag (current d) pb]) 86 | 87 | -- |Set the accessibility label of any view to a static value. 88 | accessibilityLabel :: HasViewConfig t s => Text -> Customization t s 89 | accessibilityLabel t = Customization_Immediate $ 90 | set (viewConfig . field @"_viewConfig_initialAccessibilityLabel") (Just t) 91 | 92 | -- |Dynamically set the accessibility label of any view. 93 | dynAccessibilityLabel :: (Reflex t, HasViewConfig t s) => Dynamic t (Maybe Text) -> Customization t s 94 | dynAccessibilityLabel d = Customization_PostBuild $ \ pb -> 95 | set (viewConfig . field @"_viewConfig_setAccessibilityLabel") (Just $ leftmost [updated d, tag (current d) pb]) 96 | 97 | -- |Set the layout of any view to a static value. 98 | layout :: HasViewConfig t s => ViewLayout -> Customization t s 99 | layout l = Customization_Immediate $ 100 | set (viewConfig . field @"_viewConfig_initialLayout") l 101 | 102 | -- |Dynamically set the layout of any view. 103 | dynLayout :: (Reflex t, HasViewConfig t s) => Dynamic t ViewLayout -> Customization t s 104 | dynLayout d = Customization_PostBuild $ \ pb -> 105 | set (viewConfig . field @"_viewConfig_setLayout") (Just $ leftmost [updated d, tag (current d) pb]) 106 | 107 | -- |Set the text color of a text view to a static color. 108 | textColor :: Color -> Customization t (TextConfig t) 109 | textColor c = Customization_Immediate $ 110 | set (initialTextStyle . field @"_textStyle_textColor") (Identity c) 111 | 112 | -- |Dynamically set the text color of a text view. 113 | dynTextColor :: Reflex t => Dynamic t Color -> Customization t (TextConfig t) 114 | dynTextColor d = Customization_PostBuild $ \ pb -> 115 | modifyTextStyle $ set (field @"_textStyle_textColor") (leftmost [updated d, tag (current d) pb]) 116 | 117 | -- |Set the font of a text view to a static color. 118 | textFont :: Font -> Customization t (TextConfig t) 119 | textFont f = Customization_Immediate $ 120 | set (initialTextStyle . field @"_textStyle_font") (Identity f) 121 | 122 | -- |Dynamically set the font of a text view. 123 | dynTextFont :: Reflex t => Dynamic t Font -> Customization t (TextConfig t) 124 | dynTextFont d = Customization_PostBuild $ \ pb -> 125 | modifyTextStyle $ set (field @"_textStyle_font") (leftmost [updated d, tag (current d) pb]) 126 | 127 | -- |Class to paper over the various view configurations which include a 'ViewConfig'. 128 | class HasViewConfig t a | a -> t where 129 | viewConfig :: Lens' a (ViewConfig t) 130 | 131 | -- |Trivial identity case. 132 | instance HasViewConfig t (ViewConfig t) where 133 | viewConfig = id 134 | 135 | -- |Focus on the 'ViewConfig' inside a 'TextConfig'. 136 | instance HasViewConfig t (TextConfig t) where 137 | viewConfig = field @"_textConfig_viewConfig" 138 | 139 | -- |Focus on the '_viewConfig_initialViewStyle' of any config which has or is a 'ViewConfig'. 140 | initialViewStyle :: HasViewConfig t s => Lens' s (ViewStyle Identity) 141 | initialViewStyle = viewConfig . field @"_viewConfig_initialStyle" 142 | 143 | -- |Helper to build a customization which sets a @modifyViewStyle@. @modifyViewStyle@ defaults to @Nothing@; this helper substitutes 144 | -- @Just defaultModifyViewStyle@ then applies the given function. 145 | modifyViewStyle :: forall t s. (Reflex t, HasViewConfig t s) => (ViewStyle (Event t) -> ViewStyle (Event t)) -> s -> s 146 | modifyViewStyle f s = 147 | let target :: Lens' s (Maybe (ViewStyle (Event t))) 148 | target = viewConfig . field @"_viewConfig_modifyStyle" 149 | in set target (Just . f . fromMaybe defaultModifyViewStyle . view target $ s) s 150 | 151 | -- |Focus on the '_textConfig_initialTextStyle' of a 'TextConfig'. 152 | initialTextStyle :: Lens' (TextConfig t) (TextStyle Identity) 153 | initialTextStyle = field @"_textConfig_initialStyle" 154 | 155 | -- |Helper to build a customization which sets a @modifyTextStyle@. @modifyTextStyle@ defaults to @Nothing@; this helper substitutes 156 | -- @Just defaultModifyTextStyle@ then applies the given function. 157 | modifyTextStyle :: forall t. Reflex t => (TextStyle (Event t) -> TextStyle (Event t)) -> TextConfig t -> TextConfig t 158 | modifyTextStyle f s = 159 | let target :: Lens' (TextConfig t) (Maybe (TextStyle (Event t))) 160 | target = field @"_textConfig_modifyStyle" 161 | in set target (Just . f . fromMaybe defaultModifyTextStyle . view target $ s) s 162 | 163 | -------------------------------------------------------------------------------- /reflex-native/src/Reflex/Native/ViewBuilder/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | -- |Cross platform building of view hierarchies with reactive style, layout, and hierarchy. 12 | module Reflex.Native.ViewBuilder.Class where 13 | 14 | import Control.Monad (Monad) 15 | import Control.Monad.Fix (MonadFix) 16 | import Control.Monad.Reader (ReaderT(..), ask) 17 | import Control.Monad.State.Strict (get, put, runStateT) 18 | import Control.Monad.Trans.Class (MonadTrans(lift)) 19 | import Data.Monoid (Monoid) 20 | import Data.Semigroup (Semigroup) 21 | import Reflex.Adjustable.Class (Adjustable) 22 | import Reflex.Class (Event, MonadHold, Reflex) 23 | import Reflex.DynamicWriter.Base (DynamicWriterT(..)) 24 | import Reflex.EventWriter.Base (EventWriterT(..)) 25 | import Reflex.Native.Gesture (GestureData, GestureSpec, GestureState) 26 | import Reflex.Native.TextConfig (TextConfig) 27 | import Reflex.Native.ViewConfig (ViewConfig, RawViewConfig) 28 | import Reflex.NotReady.Class (NotReady) 29 | import Reflex.Patch (Additive, Group) 30 | import Reflex.PerformEvent.Class (PerformEvent) 31 | import Reflex.PostBuild.Base (PostBuildT(..)) 32 | import Reflex.Query.Base (QueryT(..)) 33 | import Reflex.Query.Class (Query) 34 | import Reflex.Requester.Base (RequesterT(..)) 35 | 36 | 37 | -- |Class of types which denote a particular "view space" or particular underlying view system in use, e.g. @UIKitViewSpace@, @TestViewSpace@, or 38 | -- @AndroidViewSpace@, which associate types for each of the standard view types in that underlying view system. 39 | class ViewSpace space where 40 | -- |The type of text views in the underlying view system, e.g. @UILabel@ on UIKit or @TextView@ on Android. 41 | type RawTextView space :: * 42 | 43 | -- |The type of any arbitrary view in the underlying view system that can be installed via 'placeRawView' or installed and made Reflex-aware using 44 | -- 'wrapRawView', e.g. @UIView@ on UIKit or @View@ on Android. 45 | type RawView space :: * 46 | 47 | -- |Wrapper around a 'RawTextView' for a given 'ViewSpace'. 48 | newtype TextView space t = TextView { _buildTextView_raw :: RawTextView space } 49 | 50 | -- |Wrapper around a 'RawView' for a given 'ViewSpace'. 51 | newtype View space t = View { _buildView_raw :: RawView space } 52 | 53 | -- |Typeclass for monads used to build view hierarchies which react over time to events in a cross-platform way. A function being polymorphic over 54 | -- @ViewBuilder t m@ means it should work identically on any supported platform. 55 | class (Monad m, Reflex t, Adjustable t m, NotReady t m, ViewSpace (ViewBuilderSpace m)) => ViewBuilder t m | m -> t where 56 | -- |The associated 'ViewSpace' for this builder monad. 57 | type ViewBuilderSpace m :: * 58 | 59 | -- |Create a static text view with the given configuration and place it in the hierarchy. 60 | buildTextView :: TextConfig t -> m (TextView (ViewBuilderSpace m) t) 61 | 62 | -- |Create a view containing some child hierarchy, returning the created view along with whatever the result of the inner build was. 63 | buildView :: ViewConfig t -> m a -> m (a, View (ViewBuilderSpace m) t) 64 | 65 | -- |Place a 'RawView' created externally in the view hierarchy being built, for example with functions or libraries that know the precise type of view 66 | -- hierarchy in use. 67 | -- 68 | -- Behavior is undefined if the given view node is already in the view hierarchy somewhere else, though each specific view hierarchy has a defined behavior. 69 | placeRawView :: RawView (ViewBuilderSpace m) -> m () 70 | 71 | -- |Wrap a 'RawView' for the appropriate 'ViewSpace' with Reflex functionality configured via the given 'RawViewConfig', such as the ability to change the 72 | -- view style or layout in response to @Event@s or recognize gestures using 'recognizeGesture'. 73 | -- 74 | -- Behavior of a view wrapped twice will probably not be what you expect; updates associated with later invocations of @wrapRawView@ will probably stomp 75 | -- earlier invocations of @wrapRawView@, though it is undefined for any @ViewBuilder t m@ if that is so, and even if so which property updates will be 76 | -- applied. 77 | wrapRawView :: RawView (ViewBuilderSpace m) -> RawViewConfig t -> m (View (ViewBuilderSpace m) t) 78 | 79 | -- |Given some gesture to recognize and any parameters of that recognition, return an @Event@ which fires each time the state of recognition of the gesture 80 | -- on the given view changes. 81 | -- 82 | -- For example, 83 | -- 84 | -- @ 85 | -- do 86 | -- e <- recognizeGesture v GestureSpec_Pan 87 | -- _ <- buildTextView (defaultTextConfig { _textConfig_setText = show <$> e }) 88 | -- @ 89 | -- 90 | -- Will show the state of any pan gesture occuring on @v@: @GestureState_None@ initially then @GestureState_Began …@ when the user starts dragging their 91 | -- finger across @v@, @GestureState_Changed …@ regularly while the user continues to slide their finger, and @GestureState_Ended …@ when the user lifts their 92 | -- finger. 93 | -- 94 | -- __Warning:__ the returned @Event@ is only guaranteed to be valid in the current builder scope. It may (or may not) fire after the current scope is removed 95 | -- by way of 'Reflex.Class.Adjustable' methods such as 'Reflex.Class.runWithReplace'. 96 | recognizeGesture :: View (ViewBuilderSpace m) t -> GestureSpec gs -> m (Event t (GestureState (GestureData gs))) 97 | 98 | {-# INLINABLE buildTextView #-} 99 | default buildTextView 100 | :: (MonadTrans f, m ~ f n, ViewBuilderSpace n ~ ViewBuilderSpace m, ViewBuilder t n, Monad n) 101 | => TextConfig t -> m (TextView (ViewBuilderSpace m) t) 102 | buildTextView cfg = lift $ buildTextView cfg 103 | 104 | {-# INLINABLE placeRawView #-} 105 | default placeRawView 106 | :: (MonadTrans f, m ~ f n, ViewBuilderSpace n ~ ViewBuilderSpace m, ViewBuilder t n, Monad n) 107 | => RawView (ViewBuilderSpace m) -> m () 108 | placeRawView v = lift $ placeRawView v 109 | 110 | {-# INLINABLE wrapRawView #-} 111 | default wrapRawView 112 | :: (MonadTrans f, m ~ f n, ViewBuilderSpace n ~ ViewBuilderSpace m, ViewBuilder t n, Monad n) 113 | => RawView (ViewBuilderSpace m) -> RawViewConfig t -> m (View (ViewBuilderSpace m) t) 114 | wrapRawView v cfg = lift $ wrapRawView v cfg 115 | 116 | {-# INLINABLE recognizeGesture #-} 117 | default recognizeGesture 118 | :: (MonadTrans f, m ~ f n, ViewBuilderSpace n ~ ViewBuilderSpace m, ViewBuilder t n, Monad n) 119 | => View (ViewBuilderSpace m) t -> GestureSpec gs -> m (Event t (GestureState (GestureData gs))) 120 | recognizeGesture v spec = lift $ recognizeGesture v spec 121 | 122 | -- |Pass through 'PostBuildT'. 123 | instance (ViewBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => ViewBuilder t (PostBuildT t m) where 124 | type ViewBuilderSpace (PostBuildT t m) = ViewBuilderSpace m 125 | buildView cfg (PostBuildT body) = PostBuildT $ buildView cfg body 126 | 127 | -- |Pass through 'ReaderT'. 128 | instance (ViewBuilder t m, Monad m) => ViewBuilder t (ReaderT r m) where 129 | type ViewBuilderSpace (ReaderT r m) = ViewBuilderSpace m 130 | buildView cfg body = do 131 | r <- ask 132 | (a, vn) <- lift $ buildView cfg (runReaderT body r) 133 | pure (a, vn) 134 | 135 | -- |Pass through 'DynamicWriterT'. 136 | instance (ViewBuilder t m, MonadHold t m, MonadFix m, Monoid w) => ViewBuilder t (DynamicWriterT t w m) where 137 | type ViewBuilderSpace (DynamicWriterT t w m) = ViewBuilderSpace m 138 | buildView cfg (DynamicWriterT body) = DynamicWriterT $ do 139 | oldS <- get 140 | ((a, newS), vn) <- lift . buildView cfg $ runStateT body oldS 141 | put newS 142 | pure (a, vn) 143 | 144 | -- |Pass through 'RequesterT'. 145 | instance (ViewBuilder t m, MonadHold t m, MonadFix m) => ViewBuilder t (RequesterT t request response m) where 146 | type ViewBuilderSpace (RequesterT t request response m) = ViewBuilderSpace m 147 | buildView cfg (RequesterT body) = RequesterT $ do 148 | r <- ask 149 | oldS <- get 150 | ((a, newS), vn) <- lift . lift . buildView cfg $ runReaderT (runStateT body oldS) r 151 | put newS 152 | pure (a, vn) 153 | 154 | -- |Pass through 'EventWriterT'. 155 | instance (ViewBuilder t m, MonadHold t m, MonadFix m, Semigroup w) => ViewBuilder t (EventWriterT t w m) where 156 | type ViewBuilderSpace (EventWriterT t w m) = ViewBuilderSpace m 157 | buildView cfg (EventWriterT body) = EventWriterT $ do 158 | oldS <- get 159 | ((a, newS), vn) <- lift . buildView cfg $ runStateT body oldS 160 | put newS 161 | pure (a, vn) 162 | 163 | -- |Pass through 'QueryT'. 164 | instance (ViewBuilder t m, MonadHold t m, MonadFix m, Group q, Query q, Additive q) => ViewBuilder t (QueryT t q m) where 165 | type ViewBuilderSpace (QueryT t q m) = ViewBuilderSpace m 166 | buildView cfg (QueryT body) = QueryT $ do 167 | oldS <- get 168 | ((a, newS), vn) <- lift . buildView cfg $ runStateT body oldS 169 | put newS 170 | pure (a, vn) 171 | 172 | -------------------------------------------------------------------------------- /hs-uikit/src/UIKit/Generic/AppDelegate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- |Generic @UIApplication@ delegate implementation using explicit configuration and callbacks. 3 | module UIKit.Generic.AppDelegate 4 | ( 5 | -- * Configuring 6 | AppDelegateConfig(..), defaultAppDelegateConfig 7 | -- * Running a @UIApplication@ 8 | , runGenericApplication 9 | -- * Raw FFI bindings 10 | , genericAppDelegate_runApplication 11 | ) where 12 | 13 | import Control.Applicative ((<$>), pure) 14 | import Control.Monad.IO.Class (liftIO) 15 | import Data.Bool (Bool(True)) 16 | import Foreign.C.Types (CChar(..)) 17 | import Foreign.Ptr (Ptr) 18 | import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr) 19 | import Foundation (NSDictionary, NSDictionaryType) 20 | import ObjC (retainObj, objcBool) 21 | import UIKit.Types (MainThread(..), UIApplication, UIApplicationType, UIWindow, UIWindowType) 22 | 23 | 24 | -- |Configuration for an app delegate which gives some user-specified additional data @a@ which will be held as long as the app delegate is live along with 25 | -- callbacks to invoke during the various lifecycle events of the application. 26 | -- 27 | -- __Warning:__ take care to not refer back to the @UIApplication@ strongly from @a@, as that will cause a reference cycle which will never be deallocated. Of 28 | -- course, applications typically run the entire lifetime of the process so it's not that bad in practice. 29 | data AppDelegateConfig a = AppDelegateConfig 30 | { _appDelegate_a :: a 31 | -- ^The user-specified data to hold while the app delegate is live. 32 | -- 33 | -- __Warning:__ take care to not refer back to the @UIApplication@ strongly from @a@, as that will cause a reference cycle which will never be deallocated. Of 34 | -- course, applications typically run the entire lifetime of the process so it's not that bad in practice. 35 | , _appDelegate_willFinishLaunchingWithOptions :: a -> UIApplication -> NSDictionary -> MainThread Bool 36 | -- ^Callback to invoke when @UIApplicationDelegate - application:willFinishLaunchingWithOptions:@ is called. Invoked with the user-specified data @a@ 37 | -- ('_appDelegate_a'), the @UIApplication@ that will launch, and the launch options as a @NSDictionary@. Can return @False@ if the launch options indicate 38 | -- the application is being launched to handle a URI and the application shouldn't handle the URI. 39 | , _appDelegate_didFinishLaunchingWithOptions :: a -> UIApplication -> NSDictionary -> UIWindow -> MainThread Bool 40 | -- ^Callback to invoke when @UIApplicationDelegate - application:didFinishLaunchingWithOptions:@ is called. Invoked with the user-specified data @a@ 41 | -- ('_appDelegate_a'), the @UIApplication@ that did launch, and the launch options as a @NSDictionary@. Can return @False@ if the launch options indicate 42 | -- the application is being launched to handle a URI and the application shouldn't handle the URI. 43 | , _appDelegate_didBecomeActive :: a -> UIApplication -> MainThread () 44 | -- ^Callback to invoke when @UIApplicationDelegate - applicationDidBecomeActive:@ is called. Invoked with the user-specified data @a@ 45 | -- ('_appDelegate_a'), and the @UIApplication@ that did become active. 46 | , _appDelegate_willResignActive :: a -> UIApplication -> MainThread () 47 | -- ^Callback to invoke when @UIApplicationDelegate - applicationWillResignActive:@ is called. Invoked with the user-specified data @a@ 48 | -- ('_appDelegate_a'), and the @UIApplication@ that will resign being active. 49 | , _appDelegate_didEnterBackground :: a -> UIApplication -> MainThread () 50 | -- ^Callback to invoke when @UIApplicationDelegate - applicationDidEnterBackground:@ is called. Invoked with the user-specified data @a@ 51 | -- ('_appDelegate_a'), and the @UIApplication@ that will enter the background. 52 | , _appDelegate_willEnterForeground :: a -> UIApplication -> MainThread () 53 | -- ^Callback to invoke when @UIApplicationDelegate - applicationWillEnterForeground:@ is called. Invoked with the user-specified data @a@ 54 | -- ('_appDelegate_a'), and the @UIApplication@ that will enter the foreground. 55 | , _appDelegate_willTerminate :: a -> UIApplication -> MainThread () 56 | -- ^Callback to invoke when @UIApplicationDelegate - applicationWillTerminate:@ is called. Invoked with the user-specified data @a@ 57 | -- ('_appDelegate_a'), and the @UIApplication@ that will terminate. 58 | , _appDelegate_significantTimeChange :: a -> UIApplication -> MainThread () 59 | -- ^Callback to invoke when @UIApplicationDelegate - applicationSignificantTimeChange:@ is called. Invoked with the user-specified data @a@ 60 | -- ('_appDelegate_a'), and the @UIApplication@ that experienced a significant wallclock time change. 61 | } 62 | 63 | -- |Create an 'AppDelegateConfig' with the given @a@ and no-op callbacks. 64 | defaultAppDelegateConfig :: a -> AppDelegateConfig a 65 | defaultAppDelegateConfig a = AppDelegateConfig 66 | { _appDelegate_a = a 67 | , _appDelegate_willFinishLaunchingWithOptions = \ _ _ _ -> pure True 68 | , _appDelegate_didFinishLaunchingWithOptions = \ _ _ _ _ -> pure True 69 | , _appDelegate_didBecomeActive = \ _ _ -> pure () 70 | , _appDelegate_willResignActive = \ _ _ -> pure () 71 | , _appDelegate_didEnterBackground = \ _ _ -> pure () 72 | , _appDelegate_willEnterForeground = \ _ _ -> pure () 73 | , _appDelegate_willTerminate = \ _ _ -> pure () 74 | , _appDelegate_significantTimeChange = \ _ _ -> pure () 75 | } 76 | 77 | -- |Raw FFI callback to @genericAppDelegate_runApplication@ which invokes @UIApplicationMain@ with a new app delegate configured with the given configuration. 78 | foreign import ccall genericAppDelegate_runApplication :: StablePtr (AppDelegateConfig a) -> IO () 79 | 80 | -- |Launch an application using @UIApplicationMain@ and the @GenericAppDelegate@ class which will use the given 'AppDelegateConfig'. This is typically used 81 | -- to implement @main@. 82 | -- 83 | -- __Note:__ The underlying ObjC code uses a global variable to pass the configuration into the newly created @GenericAppDelegate@ as it is not possible to 84 | -- create the app delegate directly. Because of this, it's possible that concurrent calls to @runGenericApplication@ (which should never occur anyways!) would 85 | -- clobber each other's configuration. Since there should be only one @UIApplicationMain@ call ever in a process, that situation should never be a problem. 86 | runGenericApplication :: AppDelegateConfig a -> IO b 87 | runGenericApplication cfg = do 88 | ptr <- newStablePtr cfg -- leaks, which is probably fine 89 | genericAppDelegate_runApplication ptr 90 | error "UIApplicationMain should never return" 91 | 92 | foreign export ccall genericAppDelegate_willFinishLaunchingWithOptions 93 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> Ptr NSDictionaryType -> MainThread CChar 94 | -- |Callback from ObjC which triggers the '_appDelegateConfig_willFinishLaunchingWithOptions' callback. 95 | genericAppDelegate_willFinishLaunchingWithOptions 96 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> Ptr NSDictionaryType -> MainThread CChar 97 | genericAppDelegate_willFinishLaunchingWithOptions configPtr applicationPtr launchOptionsPtr = do 98 | application <- retainObj applicationPtr 99 | launchOptions <- retainObj launchOptionsPtr 100 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 101 | objcBool <$> _appDelegate_willFinishLaunchingWithOptions _appDelegate_a application launchOptions 102 | 103 | foreign export ccall genericAppDelegate_didFinishLaunchingWithOptions 104 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> Ptr NSDictionaryType -> Ptr UIWindowType -> MainThread CChar 105 | -- |Callback from ObjC which triggers the '_appDelegateConfig_didFinishLaunchingWithOptions' callback. 106 | genericAppDelegate_didFinishLaunchingWithOptions 107 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> Ptr NSDictionaryType -> Ptr UIWindowType -> MainThread CChar 108 | genericAppDelegate_didFinishLaunchingWithOptions configPtr applicationPtr launchOptionsPtr windowPtr = do 109 | application <- retainObj applicationPtr 110 | launchOptions <- retainObj launchOptionsPtr 111 | window <- retainObj windowPtr 112 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 113 | objcBool <$> _appDelegate_didFinishLaunchingWithOptions _appDelegate_a application launchOptions window 114 | 115 | foreign export ccall genericAppDelegate_didBecomeActive 116 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 117 | -- |Callback from ObjC which triggers the '_appDelegateConfig_didBecomeActive' callback. 118 | genericAppDelegate_didBecomeActive 119 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 120 | genericAppDelegate_didBecomeActive configPtr applicationPtr = do 121 | application <- retainObj applicationPtr 122 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 123 | _appDelegate_didBecomeActive _appDelegate_a application 124 | 125 | foreign export ccall genericAppDelegate_willResignActive 126 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 127 | -- |Callback from ObjC which triggers the '_appDelegateConfig_willResignActive' callback. 128 | genericAppDelegate_willResignActive 129 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 130 | genericAppDelegate_willResignActive configPtr applicationPtr = do 131 | application <- retainObj applicationPtr 132 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 133 | _appDelegate_willResignActive _appDelegate_a application 134 | 135 | foreign export ccall genericAppDelegate_didEnterBackground 136 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 137 | -- |Callback from ObjC which triggers the '_appDelegateConfig_didEnterBackground' callback. 138 | genericAppDelegate_didEnterBackground 139 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 140 | genericAppDelegate_didEnterBackground configPtr applicationPtr = do 141 | application <- retainObj applicationPtr 142 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 143 | _appDelegate_didEnterBackground _appDelegate_a application 144 | 145 | foreign export ccall genericAppDelegate_willEnterForeground 146 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 147 | -- |Callback from ObjC which triggers the '_appDelegateConfig_willEnterForeground' callback. 148 | genericAppDelegate_willEnterForeground 149 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 150 | genericAppDelegate_willEnterForeground configPtr applicationPtr = do 151 | application <- retainObj applicationPtr 152 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 153 | _appDelegate_willEnterForeground _appDelegate_a application 154 | 155 | foreign export ccall genericAppDelegate_willTerminate 156 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 157 | -- |Callback from ObjC which triggers the '_appDelegateConfig_willTerminate' callback. 158 | genericAppDelegate_willTerminate 159 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 160 | genericAppDelegate_willTerminate configPtr applicationPtr = do 161 | application <- retainObj applicationPtr 162 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 163 | _appDelegate_willTerminate _appDelegate_a application 164 | 165 | foreign export ccall genericAppDelegate_significantTimeChange 166 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 167 | -- |Callback from ObjC which triggers the '_appDelegateConfig_significantTimeChange' callback. 168 | genericAppDelegate_significantTimeChange 169 | :: StablePtr (AppDelegateConfig a) -> Ptr UIApplicationType -> MainThread () 170 | genericAppDelegate_significantTimeChange configPtr applicationPtr = do 171 | application <- retainObj applicationPtr 172 | AppDelegateConfig {..} <- liftIO $ deRefStablePtr configPtr 173 | _appDelegate_significantTimeChange _appDelegate_a application 174 | -------------------------------------------------------------------------------- /reflex-native-test/src/Reflex/Native/Test/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | -- |Functions for evaluating the current state of a built UI hierarchy and making assertions about that state. 6 | module Reflex.Native.Test.Evaluation 7 | ( 8 | -- * Basic functions 9 | askRootViews, askRootReady, runFrame, selectFromViews, lookupFromViews 10 | -- * "Test.Hspec.Expectations" lifted to 'TestEvaluation' 11 | , expectationFailure, shouldBe, shouldSatisfy, shouldStartWith, shouldEndWith, shouldContain, shouldMatchList, shouldReturn, shouldNotBe, shouldNotSatisfy 12 | , shouldNotContain, shouldNotReturn 13 | -- * Expectations similar to @Test.Hspec.Expectations.Lens@ for views 14 | , shouldHave, shouldNotHave, shouldView, shouldPreview, shouldList 15 | ) where 16 | 17 | import Control.Concurrent.STM.TVar (readTVarIO) 18 | import Control.Lens (Getting, has, hasn't, preview, toListOf, view) 19 | import Control.Monad (unless, when) 20 | import Control.Monad.IO.Class (liftIO) 21 | import Control.Monad.RWS.Strict (asks, get, gets) 22 | import Control.Monad.Trans.Class (lift) 23 | import Data.Functor.Identity (Identity) 24 | import Data.List (intercalate) 25 | import Data.Monoid (All, Any, Endo, First) 26 | import Data.Sequence (Seq) 27 | import GHC.Stack (HasCallStack) 28 | import Reflex.Host.Class (ReflexHost(type HostFrame), runHostFrame) 29 | import Reflex.Native.Test.Types (TestEnv(..), TestEvaluation(..), TestView, showTestViewHierarchy) 30 | import Reflex.Spider.Internal (HasSpiderTimeline, SpiderTimeline) 31 | import Reflex.TriggerEvent.Base (TriggerEventT, runTriggerEventT) 32 | import qualified Test.Hspec.Expectations as Hspec 33 | 34 | 35 | -- |Get the current view hierarchy, updated each time 'processEventsAndRead' is run. 36 | askRootViews :: TestEvaluation x (Seq (TestView Identity)) 37 | askRootViews = TestEvaluation get 38 | 39 | -- |Get whether the root has become ready. 40 | askRootReady :: TestEvaluation x Bool 41 | askRootReady = TestEvaluation (asks _testEnv_rootReady) >>= liftIO . readTVarIO 42 | 43 | -- |Run a frame of Reflex, letting you sample, hold, subscribe to events, or create triggers during a 'TestEvaluation'. 44 | runFrame 45 | :: forall x a. HasSpiderTimeline x 46 | => (TriggerEventT (SpiderTimeline x) (HostFrame (SpiderTimeline x)) a) 47 | -> TestEvaluation x a 48 | runFrame action = TestEvaluation $ do 49 | chan <- asks _testEnv_eventChan 50 | lift $ runHostFrame (runTriggerEventT action chan) 51 | 52 | -- |Apply some @Fold@ to the current view hierarchy returning the results. 53 | selectFromViews :: Getting (Endo [a]) (Seq (TestView Identity)) a -> TestEvaluation x [a] 54 | selectFromViews f = TestEvaluation $ gets (toListOf f) 55 | 56 | -- |Apply some @Fold@ to the current view hierarchy returning the first result if any. 57 | lookupFromViews :: Getting (First a) (Seq (TestView Identity)) a -> TestEvaluation x (Maybe a) 58 | lookupFromViews f = TestEvaluation $ gets (preview f) 59 | 60 | -- |Signal that an expectation failed with some message, aborting the test. 61 | expectationFailure :: HasCallStack => String -> TestEvaluation x () 62 | expectationFailure = liftIO . Hspec.expectationFailure 63 | 64 | infix 2 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn` 65 | infix 2 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn` 66 | 67 | -- |@actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal to @expected@. 68 | shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> TestEvaluation x () 69 | actual `shouldBe` expected = liftIO $ actual `Hspec.shouldBe` expected 70 | 71 | -- |@v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@. 72 | shouldSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> TestEvaluation x () 73 | v `shouldSatisfy` p = liftIO $ v `Hspec.shouldSatisfy` p 74 | 75 | -- |@list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@, 76 | shouldStartWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> TestEvaluation x () 77 | xs `shouldStartWith` ys = liftIO $ xs `Hspec.shouldStartWith` ys 78 | 79 | -- |@list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@, 80 | shouldEndWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> TestEvaluation x () 81 | xs `shouldEndWith` ys = liftIO $ xs `Hspec.shouldEndWith` ys 82 | 83 | -- |@list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained, wholly and intact, anywhere in @list@. 84 | shouldContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> TestEvaluation x () 85 | xs `shouldContain` ys = liftIO $ xs `Hspec.shouldContain` ys 86 | 87 | -- |@xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same elements that @ys@ has, possibly in another order 88 | shouldMatchList :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> TestEvaluation x () 89 | xs `shouldMatchList` ys = liftIO $ xs `Hspec.shouldMatchList` ys 90 | 91 | -- |@action \`shouldReturn\` expected@ sets the expectation that @action@ returns @expected@. 92 | shouldReturn :: (HasCallStack, Show a, Eq a) => TestEvaluation x a -> a -> TestEvaluation x () 93 | action `shouldReturn` expected = action >>= (`shouldBe` expected) 94 | 95 | -- |@actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not equal to @notExpected@ 96 | shouldNotBe :: (HasCallStack, Show a, Eq a) => a -> a -> TestEvaluation x () 97 | actual `shouldNotBe` notExpected = liftIO $ actual `Hspec.shouldNotBe` notExpected 98 | 99 | -- |@v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@. 100 | shouldNotSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> TestEvaluation x () 101 | v `shouldNotSatisfy` p = liftIO $ v `Hspec.shouldNotSatisfy` p 102 | 103 | -- |@list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not contained anywhere in @list@. 104 | shouldNotContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> TestEvaluation x () 105 | list `shouldNotContain` sublist = liftIO $ list `Hspec.shouldNotContain` sublist 106 | 107 | -- |@action \`shouldNotReturn\` notExpected@ sets the expectation that @action@ does not return @notExpected@. 108 | shouldNotReturn :: (HasCallStack, Show a, Eq a) => TestEvaluation x a -> a -> TestEvaluation x () 109 | action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected) 110 | 111 | infixl 2 `shouldHave`, `shouldNotHave`, `shouldView`, `shouldPreview`, `shouldList` 112 | 113 | -- | @s \`shouldHave\` l@ sets the expectation that 'Fold' @l@ has non-zero number of targets in the view hierarchy 114 | -- 115 | -- > s `shouldBe` t ≡ s `shouldHave` only t 116 | -- 117 | -- @ 118 | -- shouldHave :: 'Getter' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 119 | -- shouldHave :: 'Fold' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 120 | -- shouldHave :: 'Iso'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 121 | -- shouldHave :: 'Lens'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 122 | -- shouldHave :: 'Traversal'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 123 | -- shouldHave :: 'Prism'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 124 | -- @ 125 | shouldHave :: HasCallStack => Getting Any (Seq (TestView Identity)) a -> TestEvaluation x () 126 | shouldHave l = do 127 | vs <- askRootViews 128 | unless (has l vs) $ 129 | expectationFailure $ "Fold had zero targets but expected at least one in:\n" ++ intercalate "\n" (showTestViewHierarchy " " vs) 130 | 131 | -- | @shouldNotHave l@ sets the expectation that 'Fold' @l@ has exactly zero targets in the view hierarchy 132 | -- 133 | -- @ 134 | -- shouldNotHave :: 'Getter' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 135 | -- shouldNotHave :: 'Fold' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 136 | -- shouldNotHave :: 'Iso'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 137 | -- shouldNotHave :: 'Lens'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 138 | -- shouldNotHave :: 'Traversal'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 139 | -- shouldNotHave :: 'Prism'' (Seq ('TestView' Identity)) a -> 'TestEvaluation' x () 140 | -- @ 141 | shouldNotHave :: (HasCallStack, Show a) => Getting All (Seq (TestView Identity)) a -> TestEvaluation x () 142 | shouldNotHave l = do 143 | vs <- askRootViews 144 | unless (hasn't l vs) $ do 145 | expectationFailure $ "Fold was supposed to have zero targets in:\n" ++ intercalate "\n" (showTestViewHierarchy " " vs) 146 | 147 | -- | @l \`shouldView\` t@ sets the expectation that you can see target @t@ in the view hierarchy though a 'Getter' @l@ 148 | -- 149 | -- @ 150 | -- shouldView :: ('Show' a, 'Eq' a) => 'Getter' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 151 | -- shouldView :: ('Data.Monoid.Monoid' m, 'Show' a, 'Eq' a) => 'Fold' (Seq ('TestView' Identity)) m -> a -> 'TestEvaluation' x () 152 | -- shouldView :: ('Show' a, 'Eq' a) => 'Iso'' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 153 | -- shouldView :: ('Show' a, 'Eq' a) => 'Lens'' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 154 | -- shouldView :: ('Data.Monoid.Monoid' m, 'Show' a, 'Eq' a) => 'Traversal'' (Seq ('TestView' Identity)) m -> a -> 'TestEvaluation' x () 155 | -- shouldView :: ('Data.Monoid.Monoid' m, 'Show' a, 'Eq' a) => 'Prism'' (Seq ('TestView' Identity)) m -> a -> 'TestEvaluation' x () 156 | -- @ 157 | shouldView :: (HasCallStack, Show a, Eq a) => Getting a (Seq (TestView Identity)) a -> a -> TestEvaluation x () 158 | l `shouldView` t = do 159 | vs <- askRootViews 160 | let t' = view l vs 161 | when (t /= t') $ 162 | expectationFailure $ "expected " ++ show t ++ " but got " ++ show t' ++ " in:\n" ++ intercalate "\n" (showTestViewHierarchy " " vs) 163 | 164 | -- | @l \`shouldPreview\` t@ sets the expectation that your @y@ is the first target of the 'Fold' @l@ in the view hierarchy 165 | -- 166 | -- @ 167 | -- shouldPreview :: ('Show' a, 'Eq' a) => 'Getter' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 168 | -- shouldPreview :: ('Show' a, 'Eq' a) => 'Fold' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 169 | -- shouldPreview :: ('Show' a, 'Eq' a) => 'Lens'' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 170 | -- shouldPreview :: ('Show' a, 'Eq' a) => 'Iso'' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 171 | -- shouldPreview :: ('Show' a, 'Eq' a) => 'Traversal'' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 172 | -- shouldPreview :: ('Show' a, 'Eq' a) => 'Prism'' (Seq ('TestView' Identity)) a -> a -> 'TestEvaluation' x () 173 | -- @ 174 | shouldPreview :: (HasCallStack, Show a, Eq a) => Getting (First a) (Seq (TestView Identity)) a -> a -> TestEvaluation x () 175 | l `shouldPreview` t = do 176 | vs <- askRootViews 177 | let t'May = preview l vs 178 | when (Just t /= t'May) $ 179 | expectationFailure $ "expected (Just) " ++ show t ++ " but got " ++ show t'May ++ " in:\n" ++ intercalate "\n" (showTestViewHierarchy " " vs) 180 | 181 | -- | @l \`shouldList\` ts@ sets the expectation that @ts@ is a list of the Fold @l@ targets in the view hierarchy. 182 | -- 183 | -- @ 184 | -- shouldList :: ('Show' a, 'Eq' a) => s -> [a] -> 'Getter' s a -> 'TestEvaluation' x () 185 | -- shouldList :: ('Show' a, 'Eq' a) => s -> [a] -> 'Fold' s a -> 'TestEvaluation' x () 186 | -- shouldList :: ('Show' a, 'Eq' a) => s -> [a] -> 'Lens'' s a -> 'TestEvaluation' x () 187 | -- shouldList :: ('Show' a, 'Eq' a) => s -> [a] -> 'Iso'' s a -> 'TestEvaluation' x () 188 | -- shouldList :: ('Show' a, 'Eq' a) => s -> [a] -> 'Traversal'' s a -> 'TestEvaluation' x () 189 | -- shouldList :: ('Show' a, 'Eq' a) => s -> [a] -> 'Prism'' s a -> 'TestEvaluation' x () 190 | -- @ 191 | shouldList :: (HasCallStack, Show a, Eq a) => Getting (Endo [a]) (Seq (TestView Identity)) a -> [a] -> TestEvaluation x () 192 | l `shouldList` ts = do 193 | vs <- askRootViews 194 | let ts' = toListOf l vs 195 | when (ts /= ts') $ 196 | expectationFailure $ "expected " ++ show ts ++ " but got " ++ show ts' ++ " in:\n" ++ intercalate "\n" (showTestViewHierarchy " " vs) 197 | --------------------------------------------------------------------------------