Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Refactors. lots.

  • Loading branch information...
commit d28bdc0acdee6ebf86a20d85b66c00818465ec46 1 parent a07bd06
Sebastiaan Visser authored
View
22 src/Compiler/Compiler.hs
@@ -1,22 +0,0 @@
-module Compiler.Compiler where
-
-import Compiler.CodeGen
-import Compiler.Instantiate
-import Compiler.LambdaLifting
-import Compiler.Renamer
-import Compiler.CSE
-import Control.Arrow
-import Control.Category
-import Lang.JavaScript
-import Prelude hiding ((.), id)
-
-compiler :: Js a -> IO String
-compiler =
- runKleisli
- $ concatDefinitions
- . generateCodeDefinitions
- . renameNamedDefinitions
- . commonSubExpressionElimination
- . liftLambdas
- . instantiateLambas
-
View
20 src/Compiler/Generics.hs
@@ -0,0 +1,20 @@
+module Compiler.Generics where
+
+import Data.Foldable
+import Data.Monoid
+
+newtype FixA a f = In { out :: a f (FixA a f) }
+
+newtype Id f a = Id { unId :: f a }
+
+type Fix f = FixA Id f
+
+foldA :: Functor f => (FixA a f -> f (FixA a f)) -> (f c -> c) -> FixA a f -> c
+foldA un f = f . fmap (foldA un f) . un
+
+foldId :: Functor f => (f c -> c) -> FixA Id f -> c
+foldId = foldA (unId . out)
+
+reduce :: (Monoid a, Foldable f) => (f (Fix f) -> a) -> Fix f -> a
+reduce f = foldMap (\x -> f (unId (out x)) `mappend` reduce f x) . unId . out
+
View
7 src/Compiler/Inliner.hs
@@ -1,7 +0,0 @@
-
--- inliner (vm, x) =
--- let uses = map snd . filter ((<=1) . fst) . map (length &&& head) . group . sort . concatMap toList . Map.elems $ vm :: [String]
--- rep from to x = if x == from then to else x
--- once (f, t) = Map.map (fmap (rep f t))
--- in undefined -- (foldr once vm uses, x)
-
View
34 src/Compiler/Instantiate.hs
@@ -1,18 +1,34 @@
-module Compiler.Instantiate (instantiateLambas) where
+module Compiler.Instantiate (instantiateLambas, anonymousExprPrinter) where
+import Compiler.Generics
import Compiler.Raw
-import Control.Arrow hiding (app)
import Control.Applicative
+import Control.Arrow hiding (app)
import Control.Monad.Reader
+import Data.List (intercalate)
import qualified Lang.Value as V
-instantiateLambas :: Show (V.Primitive l) => Kleisli IO (V.Val l i) Expr
+instantiateLambas :: Arrow (~>) => V.Val l i ~> Expr
instantiateLambas = arr (flip runReader 0 . tr)
+ where
+ tr :: V.Val l i -> Reader Integer Expr
+ tr (V.App f a) = app <$> tr f <*> tr a
+ tr (V.Con c) = pure (con c)
+ tr (V.Prim s vs) = pure (prim s vs)
+ tr (V.Lam f) = local (+1) (ask >>= \r -> let v = 'v':show r in lam [v] <$> tr (f (V.Var v)))
+ tr (V.Var v) = pure (var v)
+ tr (V.Name n e) = def n <$> tr e
+
+anonymousExprPrinter :: Arrow (~>) => Expr ~> String
+anonymousExprPrinter = arr tr
+ where
+ tr (In (Id (App f e))) = tr f ++ "(\n" ++ indent (tr e) ++ ")"
+ tr (In (Id (Con c))) = c
+ tr (In (Id (Prim s vs))) = s ++ " /* free: " ++ intercalate ", " vs ++ " */"
+ tr (In (Id (Lam as e))) = "(function (" ++ intercalate ", " as ++ ")" ++ "\n{\n" ++ indent ("return " ++ tr e ++ ";") ++ "\n})"
+ tr (In (Id (Var v))) = v
+ tr (In (Id (Def n e))) = "/* " ++ n ++ "*/ " ++ tr e
+ tr (In (Id (More es))) = intercalate "\n" (map tr es)
-tr :: Show (V.Primitive l) => V.Val l i -> Reader Integer Expr
-tr (V.App f a) = app <$> tr f <*> tr a
-tr (V.Prim s) = pure (prim (show s))
-tr (V.Lam f) = local (+1) (ask >>= \r -> lam ['v':show r] <$> tr (f (V.Var r)))
-tr (V.Var x) = pure (var ('v':show x))
-tr (V.Name x v) = name x <$> tr v
+ indent = unlines . map (" "++) . lines
View
52 src/Compiler/LiftDefinitions.hs
@@ -0,0 +1,52 @@
+module Compiler.LiftDefinitions
+ ( inlineDefinitions
+ , collectDefinitions
+ , liftDefinitions
+ , definitionsPrinter
+ ) where
+
+import Compiler.Generics
+import Compiler.Raw
+import Data.Map (Map, singleton, empty, elems)
+import Control.Arrow hiding (app)
+import Data.List (intercalate)
+
+-- All named definitions within expression will be replaces by a variables with
+-- the name of the definitions.
+
+inlineDefinitions :: Expr -> Expr
+inlineDefinitions = foldId (In . Id . fmap defs)
+ where
+ defs (In (Id (Def n _))) = var n
+ defs e = e
+
+-- Collect all definitions from an expression tree and return a map with
+-- name/definition pairs. Because of the Map datatype all duplicate definitions
+-- will be joined to a single one.
+
+collectDefinitions :: Expr -> Map String Expr
+collectDefinitions = reduce defs
+ where
+ defs d@(Def n _) = singleton n (In (Id d))
+ defs _ = empty
+
+-- Lift all definitions to the top-level and inline all references to these
+-- definitions.
+
+liftDefinitions :: Arrow (~>) => Expr ~> Expr
+liftDefinitions = arr (\e -> more (elems (collectDefinitions e) ++ [tr e]))
+ where
+ tr d@(In (Id (Def _ _))) = d
+ tr e = inlineDefinitions e
+
+definitionsPrinter :: Arrow (~>) => Expr ~> String
+definitionsPrinter = arr tr
+ where
+ tr (In (Id (App f e))) = tr f ++ "(" ++ tr e ++ ")"
+ tr (In (Id (Con c))) = c
+ tr (In (Id (Prim s _))) = s
+ tr (In (Id (Lam as e))) = "(function (" ++ intercalate ", " as ++ ")" ++ "{ " ++ "return " ++ tr e ++ ";" ++ " })"
+ tr (In (Id (Var v))) = v
+ tr (In (Id (Def n e))) = n ++ " = " ++ tr e
+ tr (In (Id (More es))) = intercalate "\n" (map tr es)
+
View
15 src/Compiler/Pipeline.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE Arrows #-}
+module Compiler.Pipeline where
+
+import Compiler.Instantiate
+import Compiler.LiftDefinitions
+import Control.Arrow
+import Lang.Value
+
+compiler :: Val l i -> IO String
+compiler = runKleisli $ proc i ->
+ do r <- instantiateLambas -< i
+ l <- liftDefinitions -< r
+ p <- definitionsPrinter -< l
+ returnA -< p
+
View
67 src/Compiler/Raw.hs
@@ -1,17 +1,17 @@
{-# LANGUAGE
TypeFamilies
, FlexibleContexts
- , UndecidableInstances
, DeriveFunctor
, DeriveFoldable
, DeriveTraversable
#-}
module Compiler.Raw where
+import Compiler.Generics
import Control.Applicative
import Control.Monad.State
import Data.Foldable hiding (elem, mapM_, concatMap, concat, foldr)
-import Data.Map
+import Data.Map (Map, lookup)
import Data.Maybe
import Data.Monoid
import Data.Traversable hiding (mapM)
@@ -21,47 +21,46 @@ import qualified Data.Set as Set
-- Raw value datatype.
-type Name = String
-
data ExprF f =
App f f
- | Prim String
- | Lam [Name] f
- | Var Name
- | Name Name f
+ | Con String
+ | Prim String [String]
+ | Lam [String] f
+ | Var String
+ | Def String f
| More [f]
- deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
-
-newtype Fix f = In { out :: f (Fix f) }
+ deriving (Eq, Ord, Functor, Foldable, Traversable)
type Expr = Fix ExprF
-- Smart constructors.
app :: Expr -> Expr -> Expr
-app a b = In (App a b )
+app a b = In (Id (App a b))
+
+con :: String -> Expr
+con a = In (Id (Con a))
-prim :: String -> Expr
-prim a = In (Prim a )
+prim :: String -> [String] -> Expr
+prim a as = In (Id (Prim a as))
-lam :: [Name] -> Expr -> Expr
-lam as f = In (Lam as f)
+lam :: [String] -> Expr -> Expr
+lam as f = In (Id (Lam as f))
-var :: Name -> Expr
-var a = In (Var a )
+var :: String -> Expr
+var a = In (Id (Var a))
-name :: Name -> Expr -> Expr
-name a b = In (Name a b )
+def :: String -> Expr -> Expr
+def a b = In (Id (Def a b))
more :: [Expr] -> Expr
-more as = In (More as )
+more as = In (Id (More as))
-instance Show (f (Fix f)) => Show (Fix f) where
- show (In f) = "(" ++ show f ++ ")"
+-- MuRef instances for Data.Reify.
-instance Traversable a => R.MuRef (Fix a) where
- type R.DeRef (Fix a) = a
- mapDeRef f = traverse f . out
+instance Traversable f => R.MuRef (FixA Id f) where
+ type R.DeRef (Fix f) = f
+ mapDeRef f = traverse f . unId . out
data Graph = Graph
{ nodes :: Map String (ExprF String)
@@ -73,22 +72,24 @@ data Graph = Graph
foldGraph
:: (Graph -> [a] -> [a] -> String -> String -> String -> a)
-> (Graph -> String -> String -> a)
+ -> (Graph -> String -> String -> [String] -> a)
-> (Graph -> [a] -> String -> [String] -> String -> a)
-> (Graph -> String -> String -> a)
-> (Graph -> [a] -> String -> String -> String -> a)
-> (Graph -> [[a]] -> String -> [String] -> a)
-> Graph
-> [a]
-foldGraph f0 f1 f2 f3 f4 f5 g@(Graph m r) = evalState (folder (r, r `from` m)) Set.empty
+foldGraph f0 f1 f2 f3 f4 f5 f6 g@(Graph m r) = evalState (folder (r, r `from` m)) Set.empty
where
folder (i, term) =
case term of
- App f b -> rec f >>= \r0 -> rec b >>= \r1 -> pure [f0 g r0 r1 i f b ]
- Prim s -> pure [f1 g i s ]
- Lam v b -> rec b >>= \r0 -> pure [f2 g r0 i v b ]
- Var v -> pure [f3 g i v ]
- More as -> mapM rec as >>= \rs -> pure [f5 g rs i as ]
- Name n b -> rec b >>= \r0 -> pure [f4 g r0 i n b ]
+ App f b -> rec f >>= \r0 -> rec b >>= \r1 -> pure [f0 g r0 r1 i f b ]
+ Con s -> pure [f1 g i s ]
+ Prim s vs -> pure [f2 g i s vs ]
+ Lam v b -> rec b >>= \r0 -> pure [f3 g r0 i v b ]
+ Var v -> pure [f4 g i v ]
+ More as -> mapM rec as >>= \rs -> pure [f6 g rs i as ]
+ Def n b -> rec b >>= \r0 -> pure [f5 g r0 i n b ]
from f = fromMaybe (error "internal error in foldGraph") . lookup f
rec k =
do v <- gets (Set.member k)
View
15 src/Compiler/Unused/CSE.hs
@@ -0,0 +1,15 @@
+module Compiler.CSE (commonSubExpressionElimination, reifyGraphA) where
+
+import Compiler.Raw
+import Control.Arrow
+import Control.Category
+import Data.Reify.Graph.CSE
+import Prelude hiding ((.), id)
+import qualified Data.Reify as R
+
+reifyGraphA :: R.MuRef a => Kleisli IO a (R.Graph (R.DeRef a))
+reifyGraphA = Kleisli R.reifyGraph
+
+commonSubExpressionElimination :: Kleisli IO Expr (R.Graph ExprF)
+commonSubExpressionElimination = arr cse . Kleisli R.reifyGraph
+
View
0  src/Compiler/CodeGen.hs → src/Compiler/Unused/CodeGen.hs
File renamed without changes
View
0  src/Compiler/Dot.hs → src/Compiler/Unused/Dot.hs
File renamed without changes
View
28 src/Compiler/Unused/FreeVars.hs
@@ -0,0 +1,28 @@
+module Compiler.FreeVars (FreeVarA (..), ExprFV, annotateWithFreeVars) where
+
+import Compiler.Raw
+import Control.Arrow hiding (app)
+import Data.Set hiding (map)
+
+data FreeVarA f a = FreeVarA { free :: Set String , expr :: f a }
+
+type ExprFV = FixA FreeVarA ExprF
+
+annotateWithFreeVars :: Arrow (~>) => Expr ~> FixA FreeVarA ExprF
+annotateWithFreeVars = arr (ann . unId . out)
+ where
+
+ -- traversal
+ ann (App l r) = ae (union (fv l') (fv r')) (App l' r') where l' = rec l; r' = rec r
+ ann (Con c) = ae (empty) (Con c )
+ ann (Prim s vs) = ae (fromList vs) (Prim s vs )
+ ann (Lam x e) = ae (difference (fv e') (fromList x)) (Lam x e' ) where e' = rec e
+ ann (Var v) = ae (singleton v) (Var v )
+ ann (Def n e) = ae (fv e') (Def n e' ) where e' = rec e
+ ann (More es) = ae (unions (map fv es')) (More es' ) where es' = map rec es
+
+ -- helpers
+ rec = annotateWithFreeVars
+ ae vs e = In (FreeVarA vs e)
+ fv = free . out
+
View
13 src/Compiler/Unused/Inliner.hs
@@ -0,0 +1,13 @@
+module Compiler.Inliner where
+
+import qualified Data.Map as Map
+import Data.List
+import Compiler.Raw
+import Control.Arrow
+
+inliner (Graph vm x) =
+ let uses = map snd . filter ((<=1) . fst) . map (length &&& head) . group . sort . concatMap undefined . Map.elems $ vm :: [String]
+ rep from to x = if x == from then to else x
+ once (f, t) = Map.map (fmap (rep f t))
+ in Graph (foldr once vm uses) x
+
View
18 src/Compiler/LambdaLifting.lhs → src/Compiler/Unused/LambdaLifting.lhs
@@ -17,7 +17,7 @@ Lambda-lifting gives us a list of definitions. The |Expr| datatype doesn't conta
The |freeVars| function will annotate every expression with its variables. The type of such an annotated expression is:
-> newtype AnnExpr a = AnnExpr {unAnn :: (a, ExprF (AnnExpr a))} deriving Show
+> newtype AnnExpr a = AnnExpr {unAnn :: (a, ExprF (AnnExpr a))} -- deriving Show
These are some smart constructor/destructor functions:
@@ -38,14 +38,14 @@ These are some smart constructor/destructor functions:
> freeVars' (App l r) = let l' = freeVars l
> r' = freeVars r
> in ae (S.union (fv l') (fv r')) (App l' r')
-> freeVars' (Prim s) = ae S.empty (Prim s)
+> freeVars' (Con c) = ae S.empty (Con c)
+> freeVars' (Prim s vs) = ae (S.fromList vs) (Prim s vs)
> freeVars' (Lam x expr) = let expr' = freeVars expr
> in ae (S.difference (fv expr') (S.fromList x)) (Lam x expr')
> freeVars' (Var v) = ae (S.singleton v) (Var v)
> freeVars' (Name nm expr) = mapVal (Name nm) (freeVars expr)
> freeVars' (More _) = error "no idea"
-
> mapVal :: (AnnExpr t -> ExprF (AnnExpr t)) -> AnnExpr t -> AnnExpr t
> mapVal f (AnnExpr (a, e)) = ae a (f (AnnExpr (a, e)))
@@ -56,7 +56,8 @@ abstractions for all free variables in |e| (and an |App| as well).
> abstract = f
> where
> f (AnnExpr (_, (App l r))) = app (abstract l) (abstract r)
-> f (AnnExpr (_, (Prim s))) = prim s
+> f (AnnExpr (_, (Con c))) = con c
+> f (AnnExpr (_, (Prim s vs))) = prim s vs -- TODO ???
> f (AnnExpr (a, (Lam x expr))) = let frees = S.toList a
> in addVars (In $ Lam (frees ++ x) (abstract expr)) frees
> f (AnnExpr (_, (Var v))) = var v
@@ -83,9 +84,12 @@ collectSCs lifts all the lambdas to supercombinators (as described in the paper)
> collectSCs' (App l r) = do l' <- collectSCs' (out l)
> r' <- collectSCs' (out r)
> return (app l' r')
-> collectSCs' (Prim s) = do nm <- freshName -- to indirect
-> write nm (In $ Prim s)
-> return $ In $ Var nm
+> collectSCs' (Con c) = do return (con c) -- nm <- freshName -- to indirect
+> -- write nm (In $ Con c)
+> -- return $ In $ Var nm
+> collectSCs' (Prim s vs) = do return (prim s vs) -- nm <- freshName -- to indirect
+> -- write nm (In $ Prim s)
+> -- return $ In $ Var nm
> collectSCs' (Lam x expr) = do expr' <- collectSCs' (out expr)
> nm <- freshName
> write nm (In $ Lam x expr')
View
0  src/Compiler/Renamer.hs → src/Compiler/Unused/Renamer.hs
File renamed without changes
View
2  src/Generic/Data/Number.hs
@@ -13,7 +13,7 @@ class NumC j where
-- Terrible hack to get number literals working.
-instance Prelude.Show (j Num) where
+instance Prelude.Show (j Num) where show _ = "num"
instance Prelude.Eq (j Num) where
instance NumC j => Prelude.Num (j Num) where
(+) = Prelude.undefined
View
74 src/Lang/JavaScript.hs
@@ -1,28 +1,20 @@
module Lang.JavaScript where
-import Lang.Value
import Generic.Control.Function
import Generic.Data.Bool
import Generic.Data.Either
-import Generic.Data.List
+import Generic.Data.List hiding ((++))
import Generic.Data.Maybe
import Generic.Data.Number
import Generic.Data.Tuple
+import Lang.Value
+import Prelude ((++))
import qualified Prelude
data JavaScript
type Js a = Val JavaScript a
-instance Prelude.Show (Primitive JavaScript) where
- 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` "(" `cc` x `cc` ") { return " `cc` b `cc` " }"
-
--- * JavaScript instances for AwesomePrelude 'data types'
+-- * JavaScript instances for AwesomePrelude datatypes.
instance NameC (Val JavaScript) where
named s a = s `Name` a
@@ -30,50 +22,50 @@ instance NameC (Val JavaScript) where
instance FunC (Val JavaScript) where
lam f = Lam f
app f g = App f g
- fix f = fun1 "fix" ["f", ""] "f(fix(f))" (lam f)
+ fix f = fun1 "fix" (\v -> "fix = arguments.callee, " ++ v ++ "(function (i) { return fix(" ++ v ++ ")(i) })") (lam f)
instance BoolC (Val JavaScript) where
- true = con "true"
- false = con "false"
- bool t e b = fun3 "bool" ["t", "e", "b"] "b ? t : e" t e b
+ true = Con "true"
+ false = Con "false"
+ bool = fun3 "bool" (\t e b -> b ++ " ? " ++ t ++ " : " ++ e)
instance NumC (Val JavaScript) where
- a + b = fun2 "add" ["a", "b"] "a + b" a b
- a - b = fun2 "sub" ["a", "b"] "a - b" a b
- a * b = fun2 "mul" ["a", "b"] "a * b" a b
- a / b = fun2 "div" ["a", "b"] "a / b" a b
- num x = con (Prelude.show x)
-
-instance TupleC (Val JavaScript) where
- mkTuple a b = fun2 "mkTuple" ["a", "b"] "{ fst : a, snd : b}" a b
- tuple f t = fun2 "tuple" ["f", "t"] "f(t.fst, t.snd)" (lam2 f) t
+ (+) = fun2 "add" (\a b -> a ++ " + " ++ b)
+ (-) = fun2 "sub" (\a b -> a ++ " - " ++ b)
+ (*) = fun2 "mul" (\a b -> a ++ " * " ++ b)
+ (/) = fun2 "div" (\a b -> a ++ " / " ++ b)
+ num x = Con (Prelude.show x)
instance MaybeC (Val JavaScript) where
- nothing = con "{ nothing : 1 }"
- just x = fun1 "just" ["x"] "{ just : x }" x
- maybe n j m = fun3 "maybe" ["n", "j", "m"] "m.nothing ? n : j(m.just)" n (lam j) m
+ nothing = Con "{ nothing : 1 }"
+ just = fun1 "just" (\x -> "{ just : " ++ x ++ " }")
+ maybe p q = fun3 "maybe" (\n j m -> m ++ ".nothing ? " ++ n ++ " : " ++ j ++ "(" ++ m ++ ".just)") p (lam q)
+
+instance TupleC (Val JavaScript) where
+ mkTuple = fun2 "mkTuple" (\a b -> "{ fst : " ++ a ++ ", snd : " ++ b ++ "}")
+ tuple p q = fun2 "tuple" (\f t -> f ++ "(" ++ t ++ ".fst, " ++ t ++ ".snd)") (lam2 p) q
instance EitherC (Val JavaScript) where
- left l = fun1 "left" ["l"] "{ left : x }" l
- right r = fun1 "right" ["r"] "{ right : x }" r
- either l r e = fun3 "either" ["l", "r", "e"] "m.left ? l(x.left) : r(x.right)" (lam l) (lam r) e
+ left = fun1 "left" (\l -> "{ left : " ++ l ++ " }")
+ right = fun1 "right" (\r -> "{ right : " ++ r ++ " }")
+ either p q = fun3 "either" (\l r e -> e ++ ".left ? " ++ l ++ "(" ++ e ++ ".left) : " ++ r ++ "(" ++ e ++ ".right)") (lam p) (lam q)
instance ListC (Val JavaScript) where
- nil = con "{ nil : 1 }"
- cons x xs = fun2 "cons" ["x", "xs"] "{ head : x, tail : xs }" x xs
- list b f xs = fun3 "list" ["a", "f", "xs"] "xs.nil ? b : f(x.head, x.tail)" b (lam2 f) xs
+ nil = Con "{ nil : 1 }"
+ cons = fun2 "cons" (\x xs -> "{ head : " ++ x ++ ", tail : " ++ xs ++ " }")
+ list b f = fun3 "list" (\n c xs -> xs ++ ".nil ? " ++ n ++ " : " ++ c ++ "(" ++ xs ++ ".head)(" ++ xs ++ ".tail)") b (lam2 f)
--- * JavaScript instances of AwesomePrelude 'type classes'
+-- * JavaScript instances of AwesomePrelude type classes.
instance Eq (Val JavaScript) Bool where
- a == b = fun2 "eq" ["a", "b"] "a == b" a b
- a /= b = fun2 "neq" ["a", "b"] "a /= b" a b
+ (==) = fun2 "eq" (\a b -> a ++ " == " ++ b)
+ (/=) = fun2 "neq" (\a b -> a ++ " /= " ++ b)
instance (Eq (Val JavaScript) a, Eq (Val JavaScript) b) => Eq (Val JavaScript) (a, b) where
- a == b = fun2 "eq" ["a", "b"] "a == b" a b
- a /= b = fun2 "neq" ["a", "b"] "a /= b" a b
+ (==) = fun2 "eq" (\a b -> a ++ " == " ++ b)
+ (/=) = fun2 "neq" (\a b -> a ++ " /= " ++ b)
instance Eq (Val JavaScript) a => Eq (Val JavaScript) [a] where
- a == b = fun2 "eq" ["a", "b"] "a == b" a b
- a /= b = fun2 "neq" ["a", "b"] "a /= b" a b
+ (==) = fun2 "eq" (\a b -> a ++ " == " ++ b)
+ (/=) = fun2 "neq" (\a b -> a ++ " /= " ++ b)
View
25 src/Lang/Value.hs
@@ -1,30 +1,23 @@
{-# LANGUAGE GADTs #-}
module Lang.Value where
-type Name = String
-type Parameter = String
-type Body = String
-data Primitive l = Fun [Parameter] Body
-
-- Values have an index for the language and an index for the type of value
-- being represented.
data Val l a where
- Prim :: Primitive l -> Val l a
+ Con :: String -> Val l a
+ Prim :: String -> [String] -> Val l a
App :: Val l (a -> b) -> Val l a -> Val l b
Lam :: (Val l a -> Val l b) -> Val l (a -> b)
- Var :: Integer -> Val l a
+ Var :: String -> Val l a
Name :: String -> Val l a -> Val l a
-con :: String -> Val l a
-con = Prim . Fun []
-
-fun1 :: String -> [Parameter] -> Body -> Val l a -> Val l b
-fun1 n p b c = (n `Name` Prim (Fun p b)) `App` c
+fun1 :: String -> (String -> String) -> Val l a -> Val l b
+fun1 n f p = (n `Name` Lam (\(Var v) -> Prim (f v) [v])) `App` p
-fun2 :: String -> [Parameter] -> Body -> Val l a -> Val l b -> Val l c
-fun2 n p b c d = (n `Name` Prim (Fun p b)) `App` c `App` d
+fun2 :: String -> (String -> String -> String) -> Val l a -> Val l b -> Val l c
+fun2 n f p0 p1 = (n `Name` Lam (\(Var v) -> Lam (\(Var w) -> Prim (f v w) [v, w]))) `App` p0 `App` p1
-fun3 :: String -> [Parameter] -> Body -> Val l a -> Val l b -> Val l c -> Val l d
-fun3 n p b c d e = (n `Name` Prim (Fun p b)) `App` c `App` d `App` e
+fun3 :: String -> (String -> String -> String -> String) -> Val l a -> Val l b -> Val l c -> Val l d
+fun3 n f p0 p1 p2 = (n `Name` Lam (\(Var v) -> Lam (\(Var w) -> Lam (\(Var x) -> Prim (f v w x) [v, w, x])))) `App` p0 `App` p1 `App` p2
View
17 src/Main.hs
@@ -1,19 +1,12 @@
module Main where
-import Compiler.Compiler
-import Compiler.Raw
+import Compiler.Pipeline
import Generic.Prelude
import Lang.JavaScript
import qualified Prelude as P
-mylist :: (NumC j, ListC j, FunC j) => j [Num]
-mylist = 1 `cons` (2 `cons` (3 `cons` (4 `cons` nil)))
-
-sumList :: (NumC j, ListC j, FunC j) => j Num
-sumList = sum mylist
-
jsList :: Js [Num]
-jsList = mylist
+jsList = 1 `cons` (2 `cons` (3 `cons` (4 `cons` (5 `cons` (6 `cons` (7 `cons` nil))))))
jsSumList :: Js Num
jsSumList = sum jsList
@@ -21,6 +14,8 @@ jsSumList = sum jsList
jsApp :: Js Num
jsApp = maybe 10 (*2) (just (4 * 3))
-test :: P.IO ()
-test = compiler jsApp P.>>= P.putStrLn
+main :: P.IO ()
+main =
+ do out <- compiler jsSumList
+ P.writeFile "test.js" out
View
1  src/test.html
@@ -0,0 +1 @@
+<script src="test.js"></script>
View
5 src/test.js
@@ -0,0 +1,5 @@
+add = (function (v5){ return (function (v6){ return v5 + v6; }); })
+cons = (function (v1){ return (function (v2){ return { head : v1, tail : v2 }; }); })
+fix = (function (v1){ return fix = arguments.callee, v1(function (i) { return fix(v1)(i) }); })
+list = (function (v3){ return (function (v4){ return (function (v5){ return v5.nil ? v3 : v4(v5.head)(v5.tail); }); }); })
+fix((function (v1){ return (function (v2){ return list(0)((function (v3){ return (function (v4){ return add(v3)(v1(v4)); }); }))(v2); }); }))(cons(1)(cons(2)(cons(3)(cons(4)(cons(5)(cons(6)(cons(7)({ nil : 1 }))))))))
Please sign in to comment.
Something went wrong with that request. Please try again.