spockz/Main.hs

## Main.hs
{-# LANGUAGE StandaloneDeriving #-}
module Main where

import           Language.UHC.JS.Assorted                ( alert )
import           Language.UHC.JS.Primitives              ( JSPtr, mkAnonObj, setAttr )

import           Language.UHC.JS.ECMA.String as JSString ( JSString, stringToJSString )

import           UHC.Generics

data Book = Book { title   :: String
                 , author  :: String
                 , jsauthor :: JSString
                 , pages   :: Int}
            deriving (Show)

-- instance Representable0 Book Maybe where
data ObjResult a b = Obj (JSPtr b)
                   | Val a

-- | Generic ToObj derived from the example |GShow| in the paper.
class ToObj a c where
  toobjs :: a -> ObjResult c b -> IO (ObjResult c b)

  toobj :: a -> IO (ObjResult c b)
  toobj a = do
    obj <- mkAnonObj
    toobjs a (Obj obj)

instance ToObj Int Int where
  toobj = return . (Val :: Int -> ObjResult Int x)

instance ToObj String JSString where
  toobj str = return $ Val $ (stringToJSString str)

instance ToObj JSString JSString where
  toobj = return . (Val :: JSString -> ObjResult JSString x)

class ToObj1 t where
  toobjs1 :: t x -> ObjResult y a -> IO (ObjResult y a)

instance (ToObj1 t) => ToObj1 (D1 g t) where
  toobjs1 (M1 a) obj = toobjs1 a obj

instance (ToObj1 l, ToObj1 r) => ToObj1 (l :+: r) where
  toobjs1 (L1 x) obj = toobjs1 x obj
  toobjs1 (R1 x) obj = error "Multiple constructors not yet supported"

instance ToObj1 U1 where
  toobjs1 U1 = return

instance (ToObj1 f, Constructor g) => ToObj1 (M1 C g f) where
  toobjs1 c@(M1 a) obj  | conIsRecord c  = toobjs1 a obj
                        | otherwise      = error "Only record fields supported"

instance (ToObj a a, Selector g) => ToObj1 (M1 S g (K1 i a)) where
  toobjs1 s@(M1 (K1 a)) (Obj obj) | null (selName s) = error "Only record fields supported"
                                  | otherwise        = fmap Obj $ setAttr (selName s) a obj

instance (ToObj1 l, ToObj1 r) => ToObj1 (l :*: r) where
  toobjs1 (l :*: r) obj = toobjs1 l obj >>= toobjs1 r

instance ToObj Book Book

toobjsdefault :: (Representable0 a t, ToObj1 t)
              => t x -> a -> ObjResult a b -> IO (ObjResult a b)
toobjsdefault rep x = toobjs1 (from0 x `asTypeOf` rep)

main = do
  putStrLn "hi"
  test

test :: IO (JSPtr a)
test = do
  let book = Book "HString" "HString" (stringToJSString "jsstring") 400
  (Obj obj) <- toobj book :: IO (ObjResult Book a)
  return obj

foreign export js "test"
  test :: IO (JSPtr a)

foreign import js "tester"
  tester :: JSPtr a -> IO ()

## makefile
# COMPILER = ${UHC} --import-path=${UHC_JSCRIPT} --import-path=${UHC_NANOPROLOG} --import-path=${UHC_UU_TC} -tjs --no-recomp --no-hi-check -O,2 # --dump-core-stages=1
#COMPILER = ${UHC} --import-path=/Users/alessandro/Documents/Uni/uhcgtoobj/lib/uhc-js/uhc-js/src #-tjs -O,2 # --no-recomp --no-hi-check --dump-core-stages=1

COMPILER = /Users/alessandro/sources/uhc/EHC/install/101/bin/ehc --import-path=/Users/alessandro/Documents/Uni/uhcgtoobj/lib/uhc-js/uhc-js/src -tjs -O,2

all: build

build:
	${COMPILER} main.hs

.PHONY clean:
	rm `find . -d -name "*.core*"`
	rm `find . -d -name "*.hi*"`
  # rm `find ${LANGUAGE_DIR} -d -name "*.core*"`

## Test.html

<!DOCTYPE html><html><head><title>Main</title>

</head>
<body>
<p>To be used with -O,2, otherwise copy the code below to your own generated HTML file.</p>
<script type="text/javascript" >
function tester(inp) {
  console.log(inp);
}
</script>
<script type="text/javascript" >
primThrowException = function(x) {
  console.log(x);
}
</script>

<script type="text/javascript" src="main.js"></script>
</body>
</html>
	{-# LANGUAGE StandaloneDeriving #-}
	module Main where

	import Language.UHC.JS.Assorted ( alert )
	import Language.UHC.JS.Primitives ( JSPtr, mkAnonObj, setAttr )

	import Language.UHC.JS.ECMA.String as JSString ( JSString, stringToJSString )

	import UHC.Generics

	data Book = Book { title :: String
	, author :: String
	, jsauthor :: JSString
	, pages :: Int}
	deriving (Show)

	-- instance Representable0 Book Maybe where
	data ObjResult a b = Obj (JSPtr b)
	\| Val a

	-- \| Generic ToObj derived from the example \|GShow\| in the paper.
	class ToObj a c where
	toobjs :: a -> ObjResult c b -> IO (ObjResult c b)

	toobj :: a -> IO (ObjResult c b)
	toobj a = do
	obj <- mkAnonObj
	toobjs a (Obj obj)

	instance ToObj Int Int where
	toobj = return . (Val :: Int -> ObjResult Int x)

	instance ToObj String JSString where
	toobj str = return $ Val $ (stringToJSString str)

	instance ToObj JSString JSString where
	toobj = return . (Val :: JSString -> ObjResult JSString x)

	class ToObj1 t where
	toobjs1 :: t x -> ObjResult y a -> IO (ObjResult y a)

	instance (ToObj1 t) => ToObj1 (D1 g t) where
	toobjs1 (M1 a) obj = toobjs1 a obj

	instance (ToObj1 l, ToObj1 r) => ToObj1 (l :+: r) where
	toobjs1 (L1 x) obj = toobjs1 x obj
	toobjs1 (R1 x) obj = error "Multiple constructors not yet supported"

	instance ToObj1 U1 where
	toobjs1 U1 = return

	instance (ToObj1 f, Constructor g) => ToObj1 (M1 C g f) where
	toobjs1 c@(M1 a) obj \| conIsRecord c = toobjs1 a obj
	\| otherwise = error "Only record fields supported"

	instance (ToObj a a, Selector g) => ToObj1 (M1 S g (K1 i a)) where
	toobjs1 s@(M1 (K1 a)) (Obj obj) \| null (selName s) = error "Only record fields supported"
	\| otherwise = fmap Obj $ setAttr (selName s) a obj

	instance (ToObj1 l, ToObj1 r) => ToObj1 (l :*: r) where
	toobjs1 (l :*: r) obj = toobjs1 l obj >>= toobjs1 r

	instance ToObj Book Book

	toobjsdefault :: (Representable0 a t, ToObj1 t)
	=> t x -> a -> ObjResult a b -> IO (ObjResult a b)
	toobjsdefault rep x = toobjs1 (from0 x `asTypeOf` rep)

	main = do
	putStrLn "hi"
	test

	test :: IO (JSPtr a)
	test = do
	let book = Book "HString" "HString" (stringToJSString "jsstring") 400
	(Obj obj) <- toobj book :: IO (ObjResult Book a)
	return obj

	foreign export js "test"
	test :: IO (JSPtr a)

	foreign import js "tester"
	tester :: JSPtr a -> IO ()
	# COMPILER = ${UHC} --import-path=${UHC_JSCRIPT} --import-path=${UHC_NANOPROLOG} --import-path=${UHC_UU_TC} -tjs --no-recomp --no-hi-check -O,2 # --dump-core-stages=1
	#COMPILER = ${UHC} --import-path=/Users/alessandro/Documents/Uni/uhcgtoobj/lib/uhc-js/uhc-js/src #-tjs -O,2 # --no-recomp --no-hi-check --dump-core-stages=1

	COMPILER = /Users/alessandro/sources/uhc/EHC/install/101/bin/ehc --import-path=/Users/alessandro/Documents/Uni/uhcgtoobj/lib/uhc-js/uhc-js/src -tjs -O,2

	all: build

	build:
	${COMPILER} main.hs

	.PHONY clean:
	rm `find . -d -name ".core"`
	rm `find . -d -name ".hi"`
	# rm `find ${LANGUAGE_DIR} -d -name ".core"`

	<!DOCTYPE html><html><head><title>Main</title>

	</head>
	<body>
	<p>To be used with -O,2, otherwise copy the code below to your own generated HTML file.</p>
	<script type="text/javascript" >
	function tester(inp) {
	console.log(inp);
	}
	</script>
	<script type="text/javascript" >
	primThrowException = function(x) {
	console.log(x);
	}
	</script>

	<script type="text/javascript" src="main.js"></script>
	</body>
	</html>