Permalink
Browse files

f's into j's

  • Loading branch information...
1 parent 4a64e7c commit 79a24e3b5c6f8024157b97422baf7a7bc807ba4d Sebastiaan Visser committed Oct 14, 2009
View
@@ -13,6 +13,7 @@ workerJs :: Graph Val -> [String]
workerJs = foldVal
(\_ i f a -> mkAssign i ++ mkId f ++ "(" ++ mkId a ++ ")")
(\_ i s -> mkAssign i ++ s)
+ (\_ i v b -> mkAssign i ++ "function (" ++ v ++ ") { return " ++ mkId b ++ "}")
mkId :: Int -> String
mkId i = '_':show i
View
@@ -19,6 +19,7 @@ import qualified Data.IntSet as Set
data Val f =
App f f
| Prim String
+ | Abs String f
deriving (Eq, Ord, Show)
newtype Fix f = In { out :: f (Fix f) }
@@ -29,14 +30,14 @@ newtype Fix f = In { out :: f (Fix f) }
-- Conversion from type indexed values to raw values.
raw :: Show (Ix.Primitive l) => Ix.Val l i -> Fix Val
-raw v = evalState (tr v) 0
+raw = flip evalState 0 . tr
where
tr :: (Show (Ix.Primitive l), Applicative m, MonadState Integer m)
=> Ix.Val l i -> m (Fix Val)
tr (Ix.App f a) = (\g b -> In (App g b)) <$> tr f <*> tr a
tr (Ix.Prim s) = pure (In (Prim (show s)))
- tr (Ix.Lam f) = modify (+1) >> get >>= \r -> tr (f (Ix.Var r))
- tr (Ix.Var x) = pure (In (Prim (show x)))
+ tr (Ix.Lam f) = modify (+1) >> get >>= \r -> In . Abs ('p':show r) <$> tr (f (Ix.Var r))
+ tr (Ix.Var x) = pure (In (Prim ('p':show x)))
-- Dealing with multiple values.
@@ -48,14 +49,17 @@ fromValues = fmap CSE.cse . reifyGraph . raw
instance Functor Val where
fmap f (App g a) = App (f g) (f a)
fmap _ (Prim s) = Prim s
+ fmap f (Abs p b) = Abs p (f b)
instance Foldable Val where
fold (App f a) = f `mappend` a
fold (Prim _) = mempty
+ fold (Abs _ b) = b
instance Traversable Val where
traverse f (App g a) = App <$> f g <*> f a
traverse _ (Prim s) = pure (Prim s)
+ traverse f (Abs p b) = Abs p <$> f b
instance Traversable a => MuRef (Fix a) where
type DeRef (Fix a) = a
@@ -71,9 +75,10 @@ from f = fromMaybe (error "internal error in foldVal") . Map.lookup f
foldVal
:: (Nodes -> Int -> Int -> Int -> a)
-> (Nodes -> Int -> String -> a)
+ -> (Nodes -> Int -> String -> Int -> a)
-> Graph Val
-> [a]
-foldVal f0 f1 (Graph xs r) = evalState (folder (r, r `from` m)) Set.empty
+foldVal f0 f1 f2 (Graph xs r) = evalState (folder (r, r `from` m)) Set.empty
where
m = Map.fromList xs
folder (i, term) =
@@ -82,6 +87,7 @@ foldVal f0 f1 (Graph xs r) = evalState (folder (r, r `from` m)) Set.empty
in case term of
App f a -> (\x y z -> x ++ y ++ z) <$> rec f <*> rec a <*> pure [f0 m i f a]
Prim s -> pure [f1 m i s]
+ Abs v b -> (++) <$> rec b <*> pure [f2 m i v b]
mboolM :: (Monad m, Monoid a) => m a -> Bool -> m a
mboolM a b = if b then a else return mempty
@@ -5,32 +5,35 @@ import qualified Prelude
undefined :: a
undefined = Prelude.undefined
-class FunC f where
- lam :: (f a -> f b) -> f (a -> b)
- app :: f (a -> b) -> f a -> f b
- fix :: (f a -> f a) -> f a
+class FunC j where
+ lam :: (j a -> j b) -> j (a -> b)
+ app :: j (a -> b) -> j a -> j b
+ fix :: (j a -> j a) -> j a
-id :: FunC f => f a -> f a
+id :: FunC j => j a -> j a
id a = lam (\i -> i) `app` a
+const :: FunC j => j a -> j b -> j a
+const a b = lam2 (\c _ -> c) `app` a `app` b
+
infixr 9 .
infixr 0 $
-($) :: FunC f => (f a -> f b) -> f a -> f b
+($) :: FunC j => (j a -> j b) -> j a -> j b
($) f a = lam f `app` a
-(.) :: (FunC f) => (f b -> f c) -> (f a -> f b) -> f a -> f c
+(.) :: (FunC j) => (j b -> j c) -> (j a -> j b) -> j a -> j c
(.) f g a = lam f `app` (lam g `app` a)
-lam2 :: FunC f => (f a -> f b -> f c) -> f (a -> b -> c)
+lam2 :: FunC j => (j a -> j b -> j c) -> j (a -> b -> c)
lam2 f = lam (\a -> lam (f a))
-lam3 :: FunC f => (f a -> f b -> f c -> f d) -> f (a -> b -> c -> d)
+lam3 :: FunC j => (j a -> j b -> j c -> j d) -> j (a -> b -> c -> d)
lam3 f = lam (\a -> lam2 (f a))
-app2 :: FunC f => f (a -> b -> c) -> f a -> f b -> f c
+app2 :: FunC j => j (a -> b -> c) -> j a -> j b -> j c
app2 f x y = (f `app` x) `app` y
-app3 :: FunC f => f (a -> b -> c -> d) -> f a -> f b -> f c -> f d
+app3 :: FunC j => j (a -> b -> c -> d) -> j a -> j b -> j c -> j d
app3 f x y z = app2 f x y `app` z
View
@@ -3,21 +3,21 @@ module Generic.Data.Bool where
import Prelude ()
data Bool
-class BoolC f where
- true :: f Bool
- false :: f Bool
- bool :: f a -> f a -> f Bool -> f a
+class BoolC j where
+ true :: j Bool
+ false :: j Bool
+ bool :: j a -> j a -> j Bool -> j a
-not :: BoolC f => f Bool -> f Bool
+not :: BoolC j => j Bool -> j Bool
not = bool false true
-and :: BoolC f => f Bool -> f Bool -> f Bool
+and :: BoolC j => j Bool -> j Bool -> j Bool
and a b = bool b false a
-or :: BoolC f => f Bool -> f Bool -> f Bool
+or :: BoolC j => j Bool -> j Bool -> j Bool
or a b = bool true b a
-class Eq f a where
- (==) :: f a -> f a -> f Bool
- (/=) :: f a -> f a -> f Bool
+class Eq j a where
+ (==) :: j a -> j a -> j Bool
+ (/=) :: j a -> j a -> j Bool
@@ -3,8 +3,8 @@ module Generic.Data.Either where
import Prelude ()
data Either a b
-class EitherC f where
- left :: f a -> f (Either a b)
- right :: f b -> f (Either a b)
- either :: (f a -> f r) -> (f b -> f r) -> f (Either a b) -> f r
+class EitherC j where
+ left :: j a -> j (Either a b)
+ right :: j b -> j (Either a b)
+ either :: (j a -> j r) -> (j b -> j r) -> j (Either a b) -> j r
View
@@ -5,26 +5,29 @@ import Generic.Data.Number
import Generic.Data.Bool
import Generic.Control.Function
-class ListC f where
- nil :: f [a]
- cons :: f a -> f [a] -> f [a]
- list :: f r -> (f a -> f [a] -> f r) -> f [a] -> f r
+class ListC j where
+ nil :: j [a]
+ cons :: j a -> j [a] -> j [a]
+ list :: j r -> (j a -> j [a] -> j r) -> j [a] -> j r
-singleton :: ListC f => f a -> f [a]
+singleton :: ListC j => j a -> j [a]
singleton a = cons a nil
-(++) :: ListC f => f [a] -> f [a] -> f [a]
+(++) :: ListC j => j [a] -> j [a] -> j [a]
xs ++ ys = list ys cons xs
-foldr :: (FunC f, ListC f) => (f a -> f b -> f b) -> f b -> f [a] -> f b
+foldr :: (FunC j, ListC j) => (j a -> j b -> j b) -> j b -> j [a] -> j b
foldr f b xs = fix (\r -> lam (list b (\y ys -> f y (r `app` ys)))) `app` xs
-sum :: (FunC f, NumC f, ListC f) => f [Num] -> f Num
+length :: (FunC j, NumC j, ListC j) => j [a] -> j Num
+length = foldr (\_ -> (+1)) 0
+
+sum :: (FunC j, NumC j, ListC j) => j [Num] -> j Num
sum = foldr (+) 0
-map :: (ListC f, FunC f) => (f a -> f b) -> f [a] -> f [b]
+map :: (ListC j, FunC j) => (j a -> j b) -> j [a] -> j [b]
map f = foldr (\a r -> f a `cons` r) nil
-filter :: (ListC f, BoolC f, FunC f) => (f a -> f Bool) -> f [a] -> f [a]
+filter :: (ListC j, BoolC j, FunC j) => (j a -> j Bool) -> j [a] -> j [a]
filter p = foldr (\x xs -> bool xs (x `cons` xs) (p x)) nil
View
@@ -5,14 +5,14 @@ import Generic.Data.List
import Generic.Control.Function
data Maybe a
-class MaybeC f where
- nothing :: f (Maybe a)
- just :: f a -> f (Maybe a)
- maybe :: f r -> (f a -> f r) -> f (Maybe a) -> f r
+class MaybeC j where
+ nothing :: j (Maybe a)
+ just :: j a -> j (Maybe a)
+ maybe :: j r -> (j a -> j r) -> j (Maybe a) -> j r
-fromMaybe :: MaybeC f => f a -> f (Maybe a) -> f a
+fromMaybe :: MaybeC j => j a -> j (Maybe a) -> j a
fromMaybe d m = maybe d (\a -> a) m
-catMaybes :: (FunC f, ListC f, MaybeC f) => f [Maybe a] -> f [a]
+catMaybes :: (FunC j, ListC j, MaybeC j) => j [Maybe a] -> j [a]
catMaybes = foldr (\a b -> maybe nil singleton a ++ b) nil
View
@@ -4,18 +4,18 @@ import Prelude ()
import qualified Prelude
data Num
-class NumC f where
- (+) :: f Num -> f Num -> f Num
- (-) :: f Num -> f Num -> f Num
- (*) :: f Num -> f Num -> f Num
- (/) :: f Num -> f Num -> f Num
- num :: Prelude.Integer -> f Num
+class NumC j where
+ (+) :: j Num -> j Num -> j Num
+ (-) :: j Num -> j Num -> j Num
+ (*) :: j Num -> j Num -> j Num
+ (/) :: j Num -> j Num -> j Num
+ num :: Prelude.Integer -> j Num
-- Terrible hack to get number literals working.
-instance Prelude.Show (f Num) where
-instance Prelude.Eq (f Num) where
-instance NumC f => Prelude.Num (f Num) where
+instance Prelude.Show (j Num) where
+instance Prelude.Eq (j Num) where
+instance NumC j => Prelude.Num (j Num) where
(+) = Prelude.undefined
(*) = Prelude.undefined
abs = Prelude.undefined
@@ -2,10 +2,10 @@ module Generic.Data.Tuple where
import Prelude ()
-class TupleC f where
- mkTuple :: f a -> f b -> f (a, b)
- tuple :: (f a -> f b -> f r) -> f (a, b) -> f r
+class TupleC j where
+ mkTuple :: j a -> j b -> j (a, b)
+ tuple :: (j a -> j b -> j r) -> j (a, b) -> j r
-swap :: TupleC f => f (a, b) -> f (b, a)
+swap :: TupleC j => j (a, b) -> j (b, a)
swap = tuple (\a b -> mkTuple b a)
View
@@ -14,15 +14,13 @@ data JavaScript
type Js a = Val JavaScript a
instance Prelude.Show (Primitive JavaScript) where
- show = showJsPrim
-
-cc :: [a] -> [a] -> [a]
-cc = (Prelude.++)
-
-showJsPrim :: Primitive JavaScript -> Prelude.String
-showJsPrim (Fun [] body) = body
-showJsPrim (Fun (x:xs) body) = "function (" `cc` x `cc` ") { return " `cc` b `cc` "}"
- where b = if Prelude.null xs then body else showJsPrim (Fun xs body)
+ show (Fun ys body) =
+ case ys of
+ [] -> body
+ x:xs ->
+ let b = if Prelude.null xs then body else Prelude.show (Fun xs body :: Primitive JavaScript)
+ cc = (Prelude.++)
+ in "function (" `cc` x `cc` ") { return " `cc` b `cc` "}"
-- * JavaScript instances for AwesomePrelude 'data types'
View
@@ -7,15 +7,18 @@ import Generic.Data.Number
import Lang.JavaScript
import qualified Prelude as P
-mylist :: (NumC f, ListC f) => f [Num]
+mylist :: (NumC j, ListC j) => j [Num]
mylist = 1 `cons` (2 `cons` (3 `cons` (4 `cons` nil)))
-sumList :: (NumC f, ListC f, FunC f) => f Num
+sumList :: (NumC j, ListC j, FunC j) => j Num
sumList = sum mylist
-jsList :: Js Num
-jsList = sumList
+jsList :: Js [Num]
+jsList = mylist
+
+jsApp :: Js Num
+jsApp = id 4
test :: P.IO ()
-test = compiler jsList P.>>= P.putStrLn
+test = compiler jsApp P.>>= P.putStrLn

0 comments on commit 79a24e3

Please sign in to comment.