packages feed

haste-prim (empty) → 0.6.0.0

raw patch · 7 files changed

+1143/−0 lines, 7 filesdep +basedep +ghc-primdep +integer-gmpsetup-changed

Dependencies added: base, ghc-prim, integer-gmp

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Anton Ekblad++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Anton Ekblad nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haste-prim.cabal view
@@ -0,0 +1,58 @@+-- Initial haste-prim.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                haste-prim+version:             0.6.0.0+synopsis:            Low level primitives for the Haste compiler.+description:         FFI and low-level hackery for haste-lib to build on.+homepage:            http://haste-lang.org+license:             BSD3+license-file:        LICENSE+author:              Anton Ekblad+maintainer:          anton@ekblad.cc+-- copyright:           +category:            Web+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++flag haste+     description: Is haste-prim being installed for Haste?+     default: False++library+  exposed-modules:+    Haste.Prim+    Haste.Prim.Any+    Haste.Prim.Foreign+    Haste.Prim.JSType+  other-extensions:+    ForeignFunctionInterface+    OverloadedStrings+    BangPatterns+    CPP+    TypeFamilies+    FlexibleInstances+    UndecidableInstances+    OverlappingInstances+    PatternGuards+    TypeOperators+    ScopedTypeVariables+    FlexibleContexts+    DefaultSignatures+    TupleSections+    EmptyDataDecls+    MagicHash+    TypeSynonymInstances+    UnboxedTuples+    MultiParamTypeClasses+    UnliftedFFITypes+  build-depends:+    base           >=4.6 && <4.9,+    ghc-prim       >=0.3 && <0.5+  if !flag(haste)+    build-depends: integer-gmp >=0.5 && <2+  else+    build-depends: integer-gmp >=0.5 && <0.6+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Haste/Prim.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, +    TypeSynonymInstances, FlexibleInstances, CPP, UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Haste.Prim (+  JSString (..), URL, toJSStr, fromJSStr, catJSStr, JSAny (..),+  Ptr, toPtr, fromPtr, veryUnsafePerformIO) where+import Foreign.Ptr+import Data.String+#ifdef __HASTE__+import Unsafe.Coerce+import GHC.CString+import qualified GHC.HastePrim as HP+#else+import Data.List (intercalate)+#endif+import GHC.Prim+import GHC.Types (IO (..))++type URL = JSString++-- | Any JS value, with one layer of indirection.+newtype JSAny = JSAny (Ptr Any)++instance Eq JSAny where+  (==) = __eq++{-# INLINE veryUnsafePerformIO #-}+-- | Strict, inlineable, dupable version of 'unsafePerformIO'. Only use if you+--   are extremely sure this is not a problem. So please don't.+veryUnsafePerformIO :: IO a -> a+veryUnsafePerformIO (IO act) =+  case act realWorld# of+    (# _, x #) -> x++-- | Concatenate a series of JSStrings using the specified separator.+catJSStr :: JSString -> [JSString] -> JSString+#ifdef __HASTE__+foreign import ccall jsCat :: Ptr [JSString] -> JSString -> JSString+foreign import ccall __eq  :: JSAny -> JSAny -> Bool+catJSStr sep strs = jsCat (toPtr strs) sep+#else+catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs)+__eq :: JSAny -> JSAny -> Bool+__eq _ _ = undefined+#endif++#ifdef __HASTE__+foreign import ccall strEq :: JSString -> JSString -> Bool+foreign import ccall strOrd :: JSString -> JSString -> Ptr Ordering++-- | Native JavaScript strings.+newtype JSString = JSString JSAny++instance Eq JSString where+  (==) = strEq++instance Ord JSString where+  compare a b = fromPtr (strOrd a b)++instance Show JSString where+  show = fromJSStr++-- | In normal Haskell, we use Storable for data that can be pointed to. When+--   we compile to JS, however, anything can be "pointed" to and nothing needs+--   to be stored.+toPtr :: a -> Ptr a+toPtr = unsafeCoerce++-- | Unwrap a "pointer" to something.+fromPtr :: Ptr a -> a+fromPtr = unsafeCoerce++{-# RULES "toJSS/fromJSS" forall s. toJSStr (fromJSStr s) = s #-}+{-# RULES "fromJSS/toJSS" forall s. fromJSStr (toJSStr s) = s #-}+{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) =+    JSString (JSAny (toPtr (unsafeCoerce# s))) #-}+{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) =+    JSString (JSAny (toPtr (unsafeCoerce# s))) #-}++-- | Convert a 'String' to a 'JSString'.+{-# NOINLINE [1] toJSStr #-}+toJSStr :: String -> JSString+toJSStr = unsafeCoerce# HP.toJSStr++instance IsString JSString where+  fromString = toJSStr++-- | Convert a 'JSString' to a 'String'.+{-# NOINLINE [1] fromJSStr #-}+fromJSStr :: JSString -> String+fromJSStr = unsafeCoerce# HP.fromJSStr++#else++-- | JSStrings are represented as normal strings server-side; should probably+--   be changed to ByteString or Text.+newtype JSString = JSString String++instance IsString JSString where+  fromString = JSString++instance Eq JSString where+  (JSString a) == (JSString b) = a == b++instance Ord JSString where+  (JSString a) `compare` (JSString b) = a `compare` b++instance Show JSString where+  show = fromJSStr++toJSStr :: String -> JSString+toJSStr = JSString++fromJSStr :: JSString -> String+fromJSStr (JSString s) = s++toPtr :: a -> Ptr a+toPtr = error "toPtr used in native code!"++fromPtr :: Ptr a -> a+fromPtr = error "fromPtr used in native code!"++#endif
+ src/Haste/Prim/Any.hs view
@@ -0,0 +1,462 @@+-- For the FFI+{-# LANGUAGE ForeignFunctionInterface, PatternGuards, CPP, BangPatterns #-}++-- For generic default instances+{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances,+             FlexibleContexts, OverloadedStrings, DefaultSignatures #-}++-- For less annoying instances+{-# LANGUAGE TupleSections #-}++-- | Converting to/from JS-native data.+module Haste.Prim.Any (+    ToAny (..), FromAny (..), Generic, JSAny (..),+    Opaque, toOpaque, fromOpaque,+    nullValue, toObject, has, get, index, isUndefined+  ) where+import GHC.Generics+import Control.Exception+import Haste.Prim+import Haste.Prim.JSType+import Data.Int+import Data.Word+import Unsafe.Coerce+import System.IO.Unsafe -- for toObject++#ifdef __HASTE__+foreign import ccall __lst2arr :: Ptr [a] -> JSAny+foreign import ccall __arr2lst :: Int -> JSAny -> Ptr [a]+foreign import ccall "String" jsString :: JSAny -> JSString+foreign import ccall "Number" jsNumber :: JSAny -> Double+foreign import ccall "__isUndef" isUndefined :: JSAny -> Bool+foreign import ccall __jsNull :: IO JSAny+foreign import ccall __new :: IO JSAny+foreign import ccall __set :: JSAny -> JSString -> JSAny -> IO ()+foreign import ccall __get :: JSAny -> JSString -> IO JSAny+foreign import ccall __has :: JSAny -> JSString -> IO Bool+#else+__new :: IO JSAny+__new = return undefined+__get :: JSAny -> JSString -> IO JSAny+__get _ _ = return undefined+__set :: JSAny -> JSString -> JSAny -> IO ()+__set _ _ _ = return ()+__has :: JSAny -> JSString -> IO Bool+__has _ _ = return False+__lst2arr :: Ptr [a] -> JSAny+__lst2arr _ = undefined+__arr2lst :: Int -> JSAny -> Ptr [a]+__arr2lst _ _ = undefined+jsString :: JSAny -> JSString+jsString _ = undefined+jsNumber :: JSAny -> Double+jsNumber _ = undefined+__jsNull :: IO JSAny+__jsNull = undefined+isUndefined :: JSAny -> Bool+isUndefined = undefined+#endif++{-# NOINLINE jsNull #-}+jsNull :: JSAny+jsNull = unsafePerformIO __jsNull++{-+  For theoretical purposes, imagine the following here:+  foreign import ccall __intToAny :: Int -> JSAny+  ...+  In practice, however, we use unsafeCoerce for that to avoid the roundtrip.+-}++-- | The JS value null.+nullValue :: JSAny+nullValue = jsNull++-- | Build a new JS object from a list of key:value pairs.+toObject :: [(JSString, JSAny)] -> JSAny+toObject ps = veryUnsafePerformIO $ do+  o <- __new+  mapM_ (uncurry $ __set o) ps+  return o++-- | Read a member from a JS object. Throws an error if the member can not be+--   marshalled into a value of type @a@.+{-# INLINE get #-}+get :: FromAny a => JSAny -> JSString -> IO a+get o k = __get o k >>= fromAny++{-# INLINE index #-}+-- | Read an element from a JS array. Throws an error if the member can not be+--   marshalled into a value of type @a@.+index :: FromAny a => JSAny -> Int -> IO a+index o k = __get o (unsafeCoerce k) >>= fromAny++-- | Check if a JS object has a particular member.+{-# INLINE has #-}+has :: JSAny -> JSString -> IO Bool+has = __has++-- | Any type that can be converted into a JavaScript value.+class ToAny a where+  -- | Build a JS object from a Haskell value.+  --+  --   The default instance creates an object from any type that derives+  --   'Generic' according to the following rules:+  --+  --   * Records turn into plain JS objects, with record names as field names.+  --+  --   * Non-record product types turn into objects containing a @$data@ field+  --     which contains all of the constructor's unnamed fields.+  --+  --   * Values of enum types turn into strings matching their constructors.+  --+  --   * Non-enum types with more than one constructor gain an extra field,+  --     @$tag@, which contains the name of the constructor used to create the+  --     object.+  --+  toAny :: a -> JSAny+  default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny+  toAny x =+    case gToAny False g of+      Tree x' -> toObject x'+      One  x' -> if isEnum g then x' else toAny [x']+      List x' -> toAny x'+    where g = from x++  listToAny :: [a] -> JSAny+  listToAny = __lst2arr . toPtr . map toAny++-- | Any type that can be converted from a JavaScript value.+class FromAny a where+  -- | Convert a value from JS with a reasonable conversion if an exact match+  --   is not possible. Examples of reasonable conversions would be truncating+  --   floating point numbers to integers, or turning signed integers into+  --   unsigned.+  --+  --   The default instance is the inverse of the default 'ToAny' instance.+  fromAny :: JSAny -> IO a+  default fromAny :: (GToAny (Rep a), GFromAny (Rep a), Generic a)+                  => JSAny -> IO a+  fromAny x = to <$> gFromAny False x++  listFromAny :: JSAny -> IO [a]+  listFromAny = mapM fromAny . fromPtr . __arr2lst 0++-- | The Opaque type is inhabited by values that can be passed to JavaScript+--   using their raw Haskell representation. Opaque values are completely+--   useless to JS code, and should not be inspected. This is useful for,+--   for instance, storing data in some JS-native data structure for later+--   retrieval.+newtype Opaque a = Opaque {fromOpaque :: a}++toOpaque :: a -> Opaque a+toOpaque = Opaque++++-- ToAny instances+instance ToAny JSAny where toAny = unsafeCoerce+instance ToAny (Ptr a) where toAny = unsafeCoerce+instance ToAny JSString where toAny = unsafeCoerce+instance ToAny Int where toAny = unsafeCoerce+instance ToAny Int8 where toAny = unsafeCoerce+instance ToAny Int16 where toAny = unsafeCoerce+instance ToAny Int32 where toAny = unsafeCoerce+instance ToAny Word where toAny = unsafeCoerce+instance ToAny Word8 where toAny = unsafeCoerce+instance ToAny Word16 where toAny = unsafeCoerce+instance ToAny Word32 where toAny = unsafeCoerce+instance ToAny Float where toAny = unsafeCoerce+instance ToAny Double where toAny = unsafeCoerce+instance ToAny Char where+  toAny = unsafeCoerce+  listToAny = toAny . toJSStr+instance ToAny () where+  toAny _ = jsNull+instance ToAny (Opaque a) where+  toAny (Opaque x) = unsafeCoerce $ toPtr x+instance ToAny Bool where+  toAny = unsafeCoerce++-- | Lists are marshalled into arrays, with the exception of 'String'.+instance ToAny a => ToAny [a] where+  toAny = listToAny++-- | Maybe is simply a nullable type. Nothing is equivalent to null, and any+--   non-null value is equivalent to x in Just x.+instance ToAny a => ToAny (Maybe a) where+  toAny Nothing  = jsNull+  toAny (Just x) = toAny x++-- | Tuples are marshalled into arrays.+instance (ToAny a, ToAny b) => ToAny (a, b) where+  toAny (a, b) = toAny [toAny a, toAny b]++instance (ToAny a, ToAny b, ToAny c) => ToAny (a, b, c) where+  toAny (a, b, c) = toAny [toAny a, toAny b, toAny c]++instance (ToAny a, ToAny b, ToAny c, ToAny d) =>+          ToAny (a, b, c, d) where+  toAny (a, b, c, d) = toAny [toAny a, toAny b, toAny c, toAny d]++instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e) =>+          ToAny (a, b, c, d, e) where+  toAny (a, b, c, d, e) = toAny [toAny a,toAny b,toAny c,toAny d,toAny e]++instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,+          ToAny f) => ToAny (a, b, c, d, e, f) where+  toAny (a, b, c, d, e, f) =+    toAny [toAny a, toAny b, toAny c, toAny d, toAny e, toAny f]++instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,+          ToAny f, ToAny g) => ToAny (a, b, c, d, e, f, g) where+  toAny (a, b, c, d, e, f, g) =+    toAny [toAny a,toAny b,toAny c,toAny d,toAny e,toAny f,toAny g]++++instance FromAny JSAny where+  fromAny x = return (unsafeCoerce x)+instance FromAny (Ptr a) where+  fromAny x = return (unsafeCoerce x)+instance FromAny JSString where+  fromAny x = return (jsString x)+instance FromAny Int where+  fromAny x = return (convert (jsNumber x))+instance FromAny Int8 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Int16 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Int32 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word8 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word16 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word32 where+  fromAny x = return (convert (jsNumber x))++-- unsafeCoerce for Float and Double saves a lot on performance, and only+-- differs in semantics if the value in question is a) not a number, and+-- b) passed verbatim back into JS land+instance FromAny Float where+  fromAny x = return (unsafeCoerce x)+instance FromAny Double where+  fromAny x = return (unsafeCoerce x)++instance FromAny Char where+  fromAny x = return (unsafeCoerce (jsNumber x))+  listFromAny x = fromJSStr <$> fromAny x+instance FromAny () where+  fromAny _ = return ()+instance FromAny (Opaque a) where+  fromAny x = Opaque . fromPtr <$> fromAny x+instance FromAny Bool where+  fromAny = return . unsafeCoerce++instance FromAny a => FromAny [a] where+  fromAny = listFromAny++instance FromAny a => FromAny (Maybe a) where+  fromAny x | x == jsNull || isUndefined x = return Nothing+            | otherwise                    = Just <$> fromAny x++instance (FromAny a, FromAny b) => FromAny (a, b) where+  fromAny x = do+    [a,b] <- fromAny x+    (,) <$> fromAny a <*> fromAny b++instance (FromAny a, FromAny b, FromAny c) => FromAny (a, b, c) where+  fromAny x = do+    [a,b,c] <- fromAny x+    (,,) <$> fromAny a <*> fromAny b <*> fromAny c++instance (FromAny a, FromAny b, FromAny c, FromAny d) =>+          FromAny (a, b, c, d) where+  fromAny x = do+    [a,b,c,d] <- fromAny x+    (,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d++instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e) =>+          FromAny (a, b, c, d, e) where+  fromAny x = do+    [a,b,c,d,e] <- fromAny x+    (,,,,) <$> fromAny a <*> fromAny b <*> fromAny c+           <*> fromAny d <*> fromAny e++instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e, FromAny f) =>+          FromAny (a, b, c, d, e, f) where+  fromAny x = do+    [a,b,c,d,e,f] <- fromAny x+    (,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c+            <*> fromAny d <*> fromAny e <*> fromAny f++instance (FromAny a, FromAny b, FromAny c, FromAny d,+          FromAny e, FromAny f, FromAny g) =>+          FromAny (a, b, c, d, e, f, g) where+  fromAny x = do+    [a,b,c,d,e,f,g] <- fromAny x+    (,,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d+             <*> fromAny e <*> fromAny f <*> fromAny g++data Value = One !JSAny | List ![JSAny] | Tree ![(JSString, JSAny)]++-- GToAny instances+class GToAny f where+  gToAny :: Bool -> f a -> Value+  isEnum :: f a -> Bool++instance GToAny U1 where+  gToAny _ U1 = error "U1: unpossible!"+  isEnum _    = True++instance ToAny a => GToAny (K1 i a) where+  gToAny _ (K1 x) = One (toAny x)+  isEnum _ = False++instance (Selector c, GToAny a) => GToAny (M1 S c a) where+  gToAny mcs (M1 x) = do+    case name of+      "" -> One  value+      _  -> Tree [(name, value)]+    where name  = toJSStr (selName (undefined :: M1 S c a ()))+          value =+            case gToAny mcs x of+              Tree x' -> toObject x'+              One  x' -> toAny x'+              List x' -> toAny x'+  isEnum _ = isEnum (undefined :: a ())++instance Constructor c => GToAny (M1 C c U1) where+  gToAny _ _ = One (toAny $ conName (undefined :: M1 C c U1 ()))+  isEnum _ = True++instance {-# OVERLAPPABLE #-} (Constructor c, GToAny a) =>+                               GToAny (M1 C c a) where+  gToAny many_constrs (M1 x)+    | many_constrs =+      case args of+        Tree args' -> Tree (("$tag", toAny tag) : args')+        One  arg   -> Tree [("$tag", toAny tag), ("$data", arg)]+        List args' -> Tree [("$tag", toAny tag), ("$data", toAny args')]+    | otherwise =+      args+    where+      tag  = conName (undefined :: M1 C c a ())+      args = gToAny many_constrs x+  isEnum _ = isEnum (undefined :: a ())++instance GToAny a => GToAny (M1 D c a) where+  gToAny cs (M1 x) = gToAny cs x+  isEnum _ = isEnum (undefined :: a ())++instance (GToAny a, GToAny b) => GToAny (a :*: b) where+  gToAny cs (a :*: b) =+    case (gToAny cs a, gToAny cs b) of+      (One l,   One r)   -> List [l, r]+      (One x,   List xs) -> List (x:xs)+      (List xs, One x)   -> List (xs ++ [x])+      (List l,  List r)  -> List (l ++ r)+      (Tree l,  Tree r)  -> Tree (l ++ r)+      (_,       _)       -> error "Tree :*: non-tree!"+  isEnum _ = False++instance (GToAny a, GToAny b) => GToAny (a :+: b) where+  gToAny _ (L1 x) = gToAny True x+  gToAny _ (R1 x) = gToAny True x+  isEnum _ = isEnum (undefined :: a ()) && isEnum (undefined :: b ())++++++-- GFromAny instances+class GFromAny f where+  gFromAny   :: Bool -> JSAny -> IO (f a)+  isRecord   :: f a -> Bool+  gFromList  :: Int -> JSAny -> IO (f a, Int)+  gFromList = error "gFromList called on non-product!"++instance GFromAny U1 where+  gFromAny _ _ = return U1+  isRecord _ = False++instance (ToAny a, FromAny a) => GFromAny (K1 i a) where+  gFromAny _ x = do+    x' <- fromAny x+    return $ K1 x'+  isRecord _ = False+  gFromList ix x = do+    x' <- x `index` ix+    return (K1 x', ix+1)++instance (Selector c, GFromAny a) => GFromAny (M1 S c a) where+  gFromAny mcs x = do+      exists <- x `has` prop+      if exists+        then M1 <$> (get x prop >>= gFromAny mcs)+        else error $ "No such member: '" ++ sn ++ "'"+    where+      sn   = selName (undefined :: M1 S c a ())+      prop = toJSStr sn+  isRecord _ = not (null $ selName (undefined :: M1 S c a ()))+  gFromList ix x = do+    (x', ix') <- gFromList ix x+    return (M1 x', ix')++instance Constructor c => GFromAny (M1 C c U1) where+  gFromAny _ x = do+      n <- fromAny x+      if (n == cn)+        then return $ M1 U1+        else error $  "Couldn't fromAny constructor: expected " ++ cn+                   ++ " but got " ++ n+    where+      cn = conName (undefined :: M1 C c U1 ())+  isRecord _ = False++instance {-# OVERLAPPABLE #-} (Constructor c, GFromAny a) =>+                               GFromAny (M1 C c a) where+  gFromAny many_constrs x+    | many_constrs = do+        t <- x `get` "$tag"+        if t == tag+          then M1 <$> (x `get` "$data" >>= gFromAny many_constrs)+          else error $  "Couldn't fromAny constructor: expected " ++ tag+                     ++ " but got " ++ t+    | isRecord (undefined :: a ()) = do+        M1 <$> gFromAny many_constrs x+    | otherwise = do+        M1 . fst <$> gFromList 0 x+    where+      tag = conName (undefined :: M1 C c a ())+  isRecord _ = isRecord (undefined :: a ())++instance GFromAny a => GFromAny (M1 D c a) where+  gFromAny cs x = M1 <$> gFromAny cs x+  isRecord _ = isRecord (undefined :: a ())+  gFromList ix x = do+    (x', ix') <- gFromList ix x+    return (M1 x', ix')++instance (GFromAny a, GFromAny b) => GFromAny (a :*: b) where+  gFromAny cs x = do+    a <- gFromAny cs x+    b <- gFromAny cs x+    return (a :*: b)+  isRecord _ = isRecord (undefined :: a ())+  gFromList ix x = do+    (a, ix') <- gFromList ix x+    (b, ix'') <- gFromList ix' x+    return (a :*: b, ix'')++instance (GFromAny a, GFromAny b) => GFromAny (a :+: b) where+  gFromAny _ x = do+    catch (L1 <$> gFromAny True x)+          (withSomeException $ R1 <$> gFromAny True x)+  isRecord _ = isRecord (undefined :: a ()) || isRecord (undefined :: b ())++withSomeException :: IO a -> SomeException -> IO a+withSomeException m _ = m
+ src/Haste/Prim/Foreign.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns, CPP #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | High level JavaScript foreign interface.+module Haste.Prim.Foreign+  ( module Haste.Prim.Any+  , FFI, JSFunc, JSException (..)+  , ffi, constant, export+  , safe_ffi, StaticPtr+  ) where+import Haste.Prim+import Haste.Prim.Any+import GHC.StaticPtr (StaticPtr, deRefStaticPtr)+import Unsafe.Coerce+import Control.Exception+import Data.Typeable++-- | A JS function.+type JSFun = JSAny++#ifdef __HASTE__+foreign import ccall __strict :: JSAny -> JSAny+foreign import ccall "eval" __eval :: JSString -> JSFun+foreign import ccall __apply :: JSFun -> Ptr [JSAny] -> IO JSAny+foreign import ccall __app0  :: JSFun -> IO JSAny+foreign import ccall __app1  :: JSFun -> JSAny -> IO JSAny+foreign import ccall __app2  :: JSFun -> JSAny -> JSAny -> IO JSAny+foreign import ccall __app3  :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny+foreign import ccall __app4  :: JSFun+                             -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny+foreign import ccall __app5  :: JSFun+                             -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny+                             -> IO JSAny+foreign import ccall __createJSFunc :: Int -> JSAny -> IO JSAny+#else+__strict :: JSAny -> JSAny+__strict x = x+__eval :: JSString -> JSFun+__eval _ = undefined+__apply :: JSFun -> Ptr [JSAny] -> IO JSAny+__apply _ _ = return undefined+__app0  :: JSFun -> IO JSAny+__app0 _ = return undefined+__app1  :: JSFun -> JSAny -> IO JSAny+__app1 _ _ = return undefined+__app2  :: JSFun -> JSAny -> JSAny -> IO JSAny+__app2 _ _ _ = return undefined+__app3  :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny+__app3 _ _ _ _ = return undefined+__app4  :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny+__app4 _ _ _ _ _ = return undefined+__app5  :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny+__app5 _ _ _ _ _ _ = return undefined+__createJSFunc :: Int -> JSAny -> IO JSAny+__createJSFunc _ = return undefined+#endif++-- | Any type that can be imported from JavaScript. This means any type which+--   has an instance of 'FromAny', and any function where all argument types+--   has 'ToAny' instances and the return type is in the IO monad and has a+--   'FromAny' instance.+class FFI a where+  __ffi :: JSFun -> [JSAny] -> a++instance FromAny a => FFI (IO a) where+  {-# INLINE __ffi #-}+  __ffi = ffiio++instance (ToAny a, FFI b) => FFI (a -> b) where+  {-# INLINE __ffi #-}+  __ffi f !as !a = __ffi f (a' : as)+    where !a' = toAny a++{-# INLINE [0] ffiio #-}+-- | Apply the result of an FFI call.+ffiio :: FromAny a => JSFun -> [JSAny] -> IO a+ffiio !f !as = __apply f (toPtr as) >>= fromAny++{-# INLINE ffi #-}+-- | Creates a Haskell function from the given string of JavaScript code. If+--   this code is not well typed or is otherwise incorrect, your program may+--   crash or misbehave in mystifying ways. Haste makes a best-effort try to+--   save you from poorly typed JS here, but there are no guarantees.+--+--   For instance, the following WILL cause crazy behavior due to wrong types:+--+--   > ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int+--+--   In other words, this function is as unsafe as the JS it calls on. You+--   have been warned.+--+--   The imported JS is evaluated lazily, unless (a) it is a function object+--   in which case evaluation order does not affect the semantics of the+--   imported code, or if (b) the imported code is explicitly marked as strict:+--+--   > someFunction = ffi "__strict(someJSFunction)"+--+--   Literals which depends on some third party initialization, the existence+--   of a DOM tree or some other condition which is not fulfilled at load time+--   should *not* be marked strict.+ffi :: FFI a => JSString -> a+ffi s = __ffi f []+  where+    {-# NOINLINE f #-}+    f = __eval s++safe_ffi :: FFI a => StaticPtr JSString -> a+safe_ffi = ffi . deRefStaticPtr++-- | Create a Haskell value from a constant JS expression.+constant :: FromAny a => JSString -> a+constant = veryUnsafePerformIO . fromAny . __eval++-- Don't build intermediate list for functions of <= 5 arguments.+{-# RULES+"app0" [1] forall f. ffiio f [] = __app0 f >>= fromAny+"app1" [1] forall f a. ffiio f [a] = __app1 f a >>= fromAny+"app2" [1] forall f a b. ffiio f [b,a] = __app2 f a b >>= fromAny+"app3" [1] forall f a b c. ffiio f [c,b,a] = __app3 f a b c >>= fromAny+"app4" [1] forall f a b c d. ffiio f [d,c,b,a] = __app4 f a b c d >>= fromAny+"app5" [1] forall f a b c d e. ffiio f [e,d,c,b,a] =+                                 __app5 f a b c d e >>= fromAny+  #-}++-- | Export a symbol. That symbol may then be accessed from JavaScript through+--   @Haste.name()@ as a normal function. Remember, however, that if you are+--   using --with-js to include your JS, in conjunction with+--   --opt-minify or any option that implies it, you will instead need+--   to access your exports through @Haste[\'name\']()@, or Closure will mangle+--   your function names.+{-# INLINE export #-}+export :: ToAny a => JSString -> a -> IO ()+export = ffi "(function(s,f){Haste[s] = f;})"++type family JS a where+  JS (a -> b) = JSAny -> JS b+  JS (IO a)   = IO JSAny+  JS a        = JSAny++class JSFunc a where+  mkJSFunc :: a -> JS a+  arity    :: a -> Int++instance {-# OVERLAPPABLE #-} (ToAny a, JS a ~ JSAny) => JSFunc a where+  mkJSFunc = toAny+  arity _  = 0++{-# INLINE strictly #-}+strictly :: a -> a+strictly x = unsafeCoerce (__strict (unsafeCoerce x))++{-# RULES+  "strictly" forall x. __strict x+    = unsafeCoerce x+  #-}++instance ToAny a => JSFunc (IO a) where+  mkJSFunc = fmap toAny+  arity _  = 1++instance (FromAny a, JSFunc b) => JSFunc (a -> b) where+  mkJSFunc f = mkJSFunc . f . strictly . veryUnsafePerformIO . fromAny+  arity f    = 1 + arity (f undefined)++instance (FromAny a, JSFunc b) => ToAny (a -> b) where+  toAny f =+    strictly . veryUnsafePerformIO . __createJSFunc (arity f) . toAny . toOpaque $ mkJSFunc f++instance ToAny a => ToAny (IO a) where+  toAny = strictly . veryUnsafePerformIO . __createJSFunc 0 . toAny . toOpaque . mkJSFunc++instance {-# OVERLAPPABLE #-} FFI a => FromAny a where+  fromAny f = return $ __ffi f []++-- | An exception raised from foreign JavaScript code.+data JSException = JSException JSString+  deriving (Show, Typeable)++instance Exception JSException where+  displayException (JSException e) = "JavaScript exception: " ++ fromJSStr e
+ src/Haste/Prim/JSType.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash, +             TypeSynonymInstances, FlexibleInstances, EmptyDataDecls,+             UnliftedFFITypes, UndecidableInstances, CPP, OverloadedStrings #-}+-- | Efficient conversions to and from JS native types.+module Haste.Prim.JSType (+    JSType (..), JSNum (..), toString, fromString, convert+  ) where+import GHC.Int+import GHC.Word+import Haste.Prim (JSString (..), toJSStr, fromJSStr)+#ifdef __HASTE__+import Haste.Prim (JSAny (..))+import GHC.Prim+import GHC.Integer.GMP.Internals+import GHC.Types (Int (..))+#else+import Data.Char+import GHC.Float+#endif++-- | Any type which can be converted to/from a 'JSString'.+class JSType a where+  toJSString   :: a -> JSString+  fromJSString :: JSString -> Maybe a++-- | (Almost) all numeric types can be efficiently converted to and from+--   Double, which is the internal representation for most of them.+class JSNum a where+  toNumber   :: a -> Double+  fromNumber :: Double -> a++instance JSType JSString where+  toJSString   = id+  fromJSString = Just++#ifdef __HASTE__++foreign import ccall "Number" jsNumber          :: JSString -> Double+foreign import ccall "String" jsString          :: Double -> JSString+foreign import ccall jsTrunc                    :: Double -> Int+foreign import ccall "I_toInt" jsIToInt         :: ByteArray# -> Int+foreign import ccall "I_toString" jsIToString   :: ByteArray# -> JSString+foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray#+foreign import ccall "I_fromNumber" jsNumToI    :: ByteArray# -> ByteArray#++unsafeToJSString :: a -> JSString+unsafeToJSString = unsafeCoerce# jsString++unsafeIntFromJSString :: JSString -> Maybe Int+unsafeIntFromJSString s =+    case jsNumber s of+      d | isNaN d   -> Nothing+        | otherwise -> Just (unsafeCoerce# (jsTrunc d))+++-- JSNum instances++instance JSNum Char where+  fromNumber = unsafeCoerce# jsTrunc+  toNumber = unsafeCoerce#++instance JSNum Int where+  fromNumber = unsafeCoerce# jsTrunc+  toNumber = unsafeCoerce#++instance JSNum Int8 where+  fromNumber n = case fromNumber n of I# n' -> I8# (narrow8Int# n')+  toNumber = unsafeCoerce#++instance JSNum Int16 where+  fromNumber n = case fromNumber n of I# n' -> I16# (narrow16Int# n')+  toNumber = unsafeCoerce#++instance JSNum Int32 where+  fromNumber = unsafeCoerce# jsTrunc+  toNumber = unsafeCoerce#++instance JSNum Word where+  fromNumber n =+    case jsTrunc (unsafeCoerce# n) of+      I# n' -> W# (int2Word# n')+  toNumber = unsafeCoerce#++instance JSNum Word8 where+  fromNumber w = case fromNumber w of W# w' -> W8# (narrow8Word# w')+  toNumber = unsafeCoerce#++instance JSNum Word16 where+  fromNumber w = case fromNumber w of W# w' -> W16# (narrow16Word# w')+  toNumber = unsafeCoerce#++instance JSNum Word32 where+  fromNumber w = case fromNumber w of W# w' -> W32# w'+  toNumber = unsafeCoerce#++instance JSNum Integer where+  toNumber (S# n) = toNumber (I# n)+  toNumber (J# n) = unsafeCoerce# (jsIToInt n)+  fromNumber n    = J# (jsNumToI (unsafeCoerce# n))++instance JSNum Float where+  fromNumber = unsafeCoerce#+  toNumber = unsafeCoerce#++instance JSNum Double where+  fromNumber = id+  toNumber = id++-- JSType instances+instance JSType Bool where+  toJSString True = "true"+  toJSString _    = "false"+  fromJSString "true"  = Just True+  fromJSString "false" = Just False+  fromJSString _       = Nothing+instance JSType Int where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Int8 where+  toJSString = unsafeToJSString+  fromJSString = fmap fromIntegral . unsafeIntFromJSString+instance JSType Int16 where+  toJSString = unsafeToJSString+  fromJSString = fmap fromIntegral . unsafeIntFromJSString+instance JSType Int32 where+  toJSString = unsafeToJSString+  fromJSString = unsafeCoerce# unsafeIntFromJSString+instance JSType Word where+  toJSString = unsafeToJSString+  fromJSString = fmap fromIntegral . unsafeIntFromJSString+instance JSType Word8 where+  toJSString = unsafeToJSString+  fromJSString = fmap fromIntegral . unsafeIntFromJSString+instance JSType Word16 where+  toJSString = unsafeToJSString+  fromJSString = fmap fromIntegral . unsafeIntFromJSString+instance JSType Word32 where+  toJSString = unsafeToJSString+  fromJSString = fmap fromIntegral . unsafeIntFromJSString++instance JSType Float where+  fromJSString s =+    case jsNumber s of+      d | isNaN d   -> Nothing+        | otherwise -> Just (unsafeCoerce# d)+  toJSString = unsafeToJSString++instance JSType Double where+  fromJSString s =+    case jsNumber s of+      d | isNaN d   -> Nothing+        | otherwise -> Just d+  toJSString = unsafeToJSString++-- This is completely insane, but GHC for some reason pukes when we try to+-- use the constructors of the actual integers, so we coerce them into this+-- isomorphic type to work with them instead.+data Dummy = Small Int# | Big ByteArray#++instance JSType Integer where+  toJSString n =+    case unsafeCoerce# n of+      Small n' -> toJSString (I# n')+      Big n'   -> jsIToString n'+  fromJSString s =+    case jsStringToI s of+      n -> Just (unsafeCoerce# (Big n))++instance JSType String where+  toJSString     = toJSStr+  fromJSString   = Just . fromJSStr++instance JSType () where+  toJSString _ = toJSStr "()"+  fromJSString s | s == toJSStr "()" = Just ()+                 | otherwise = Nothing++#else++instance JSNum Char where+  toNumber = fromIntegral . ord+  fromNumber = chr . round++instance JSNum Int where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Int8 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Int16 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Int32 where+  toNumber = fromIntegral+  fromNumber = round++instance JSNum Word where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Word8 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Word16 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Word32 where+  toNumber = fromIntegral+  fromNumber = round++instance JSNum Double where+  toNumber = id+  fromNumber = id+instance JSNum Float where+  toNumber = float2Double+  fromNumber = double2Float++instance JSNum Integer where+  toNumber = fromInteger+  fromNumber = round++mread :: Read a => String -> Maybe a+mread s =+  case reads s of+    [(x, "")] -> x+    _         -> Nothing++instance JSType Int where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Int8 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Int16 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Int32 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Word where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Word8 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Word16 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Word32 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Double where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Float where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Integer where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Bool where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType () where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType String where+  toJSString = toJSStr+  fromJSString = Just . fromJSStr++#endif++-- Derived functions++toString :: JSType a => a -> String+toString = fromJSStr . toJSString++fromString :: JSType a => String -> Maybe a+fromString = fromJSString . toJSStr++convert :: (JSNum a, JSNum b) => a -> b+convert = fromNumber . toNumber