jmacro 0.5.8 → 0.6.2

raw patch · 9 files changed

+367/−353 lines, 9 filesdep +aesondep +criteriondep +textdep −jsondep −prettynew-component:exe:jmacro-benchPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, criterion, text, unordered-containers, vector, wl-pprint-text

Dependencies removed: json, pretty

API changes (from Hackage documentation)

Files

• Language/Javascript/JMacro/Base.hs +176/−151
• Language/Javascript/JMacro/Benchmark.hs +11/−0
• Language/Javascript/JMacro/Executable.hs +10/−5
• Language/Javascript/JMacro/QQ.hs +73/−39
• Language/Javascript/JMacro/Rpc.hs +0/−122
• Language/Javascript/JMacro/TypeCheck.hs +67/−20
• Language/Javascript/JMacro/Types.hs +14/−11
• Language/Javascript/JMacro/Util.hs +1/−1
• jmacro.cabal +15/−4

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, OverloadedStrings, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables, GADTs #-}  ----------------------------------------------------------------------------- {- |@@ -16,7 +16,7 @@   -- * ADT   JStat(..), JExpr(..), JVal(..), Ident(..), IdentSupply(..),   -- * Generic traversal (via compos)-  JMacro(..), MultiComp(..), Compos(..),+  JMacro(..), JMGadt(..), Compos(..),   composOp, composOpM, composOpM_, composOpFold,   -- * Hygienic transformation   withHygiene, scopify,@@ -36,31 +36,43 @@   ) where import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) import Control.Applicative hiding (empty)-import Control.Arrow (second)+import Control.Arrow ((***)) import Control.Monad.State.Strict import Control.Monad.Identity  import Data.Function import Data.Char (toLower,isControl)-import Data.Maybe (fromMaybe)-import qualified Data.Set as S import qualified Data.Map as M+import qualified Data.Text.Lazy as T+import qualified Data.Text as TS import Data.Generics import Data.Monoid(Monoid, mappend, mempty)  import Numeric(showHex) import Safe-import Text.JSON-import Text.PrettyPrint.HughesPJ as PP+import Data.Aeson+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import Text.PrettyPrint.Leijen.Text hiding ((<$>)) +import qualified Text.PrettyPrint.Leijen.Text as PP+ import Language.Javascript.JMacro.Types +-- wl-pprint-text compatibility with pretty+infixl 5 $$, $+$+($+$), ($$), ($$$) :: Doc -> Doc -> Doc+x $+$ y = x PP.<$> y+x $$ y  = align (x $+$ y)+x $$$ y = align (nest 2 $ x $+$ y)+ {--------------------------------------------------------------------   ADTs --------------------------------------------------------------------}  newtype IdentSupply a = IS {runIdentSupply :: State [Ident] a} deriving Typeable +inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b inIdentSupply f x = IS $ f (runIdentSupply x)  instance Data a => Data (IdentSupply a) where@@ -103,8 +115,8 @@ data JStat = DeclStat   Ident (Maybe JLocalType)            | ReturnStat JExpr            | IfStat     JExpr JStat JStat-           | WhileStat  JExpr JStat-           | ForInStat  Bool Ident JExpr JStat+           | WhileStat  Bool JExpr JStat -- bool is "do"+           | ForInStat  Bool Ident JExpr JStat -- bool is "each"            | SwitchStat JExpr [(JExpr, JStat)] JStat            | TryStat    JStat Ident JStat JStat            | BlockStat  [JStat]@@ -114,10 +126,14 @@            | UnsatBlock (IdentSupply JStat)            | AntiStat   String            | ForeignStat Ident JLocalType-           | BreakStat+           | LabelStat JsLabel JStat+           | BreakStat (Maybe JsLabel)+           | ContinueStat (Maybe JsLabel)              deriving (Eq, Ord, Show, Data, Typeable) +type JsLabel = String + instance Monoid JStat where     mempty = BlockStat []     mappend (BlockStat xs) (BlockStat ys) = BlockStat $ xs ++ ys@@ -175,70 +191,68 @@ {--------------------------------------------------------------------   Compos --------------------------------------------------------------------}+-- | Compos and ops for generic traversal as defined over+-- the JMacro ADT.  -- | Utility class to coerce the ADT into a regular structure. class JMacro a where-    toMC :: a -> MultiComp-    fromMC :: MultiComp -> a+    jtoGADT :: a -> JMGadt a+    jfromGADT :: JMGadt a -> a --- | Union type to allow regular traversal by compos.-data MultiComp = MStat JStat | MExpr JExpr | MVal JVal | MIdent Ident deriving Show+instance JMacro Ident where+    jtoGADT = JMGId+    jfromGADT (JMGId x) = x+    jfromGADT _ = error "impossible" +instance JMacro JStat where+    jtoGADT = JMGStat+    jfromGADT (JMGStat x) = x+    jfromGADT _ = error "impossible"+    +instance JMacro JExpr where+    jtoGADT = JMGExpr+    jfromGADT (JMGExpr x) = x+    jfromGADT _ = error "impossible" --- | Compos and ops for generic traversal as defined over--- the JMacro ADT.-class Compos t where-    compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)-           -> (t -> m t) -> t -> m t+instance JMacro JVal where+    jtoGADT = JMGVal +    jfromGADT (JMGVal x) = x+    jfromGADT _ = error "impossible" +-- | Union type to allow regular traversal by compos.+data JMGadt a where+    JMGId   :: Ident -> JMGadt Ident+    JMGStat :: JStat -> JMGadt JStat+    JMGExpr :: JExpr -> JMGadt JExpr+    JMGVal  :: JVal  -> JMGadt JVal -composOp :: Compos t => (t -> t) -> t -> t++composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b composOp f = runIdentity . composOpM (Identity . f)-composOpM :: (Compos t, Monad m) => (t -> m t) -> t -> m t+composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b) composOpM = compos return ap-composOpM_ :: (Compos t, Monad m) => (t -> m ()) -> t -> m ()+composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m () composOpM_ = composOpFold (return ()) (>>)-composOpFold :: Compos t => b -> (b -> b -> b) -> (t -> b) -> t -> b+composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) newtype C b a = C { unC :: b } -instance JMacro Ident where-    toMC = MIdent-    fromMC (MIdent x) = x-    fromMC _ = error "fromMC"--instance JMacro JVal where-    toMC = MVal-    fromMC (MVal x) = x-    fromMC _ = error "fromMC"--instance JMacro JExpr where-    toMC = MExpr-    fromMC (MExpr x) = x-    fromMC _ = error "fromMC"--instance JMacro JStat where-    toMC = MStat-    fromMC (MStat x) = x-    fromMC _ = error "fromMC"--instance JMacro [JStat] where-    toMC = MStat . BlockStat-    fromMC (MStat (BlockStat x)) = x-    fromMC _ = error "fromMC"+class Compos t where+    compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)+           -> (forall a. t a -> m (t a)) -> t c -> m (t c) +instance Compos JMGadt where+    compos = jmcompos -instance Compos MultiComp where-  compos = mcCompos-    where-     mcCompos :: forall m. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (MultiComp -> m MultiComp) -> MultiComp -> m MultiComp-     mcCompos ret app f' v = case v of-        MIdent _ -> ret v-        MStat v' -> ret MStat `app` case v' of+jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c)+jmcompos ret app f' v = +    case v of+     JMGId _ -> ret v+     JMGStat v' -> ret JMGStat `app` case v' of            DeclStat i t -> ret DeclStat `app` f i `app` ret t            ReturnStat i -> ret ReturnStat `app` f i            IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'-           WhileStat e s -> ret WhileStat `app` f e `app` f s+           WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s            ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s            SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d                where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l@@ -250,8 +264,10 @@            UnsatBlock _ -> ret v'            AntiStat _ -> ret v'            ForeignStat i t -> ret ForeignStat `app` f i `app` ret t-           BreakStat -> ret BreakStat-        MExpr v' -> ret MExpr `app` case v' of+           ContinueStat l -> ret (ContinueStat l)+           BreakStat l -> ret (BreakStat l)+           LabelStat l s -> ret (LabelStat l) `app` f s+     JMGExpr v' -> ret JMGExpr `app` case v' of            ValExpr e -> ret ValExpr `app` f e            SelExpr e e' -> ret SelExpr `app` f e `app` f e'            IdxExpr e e' -> ret IdxExpr `app` f e `app` f e'@@ -263,7 +279,7 @@            AntiExpr _ -> ret v'            TypeExpr b e t -> ret (TypeExpr b) `app` f e `app` ret t            UnsatExpr _ -> ret v'-        MVal v' -> ret MVal `app` case v' of+     JMGVal v' -> ret JMGVal `app` case v' of            JVar i -> ret JVar `app` f i            JList xs -> ret JList `app` mapM' f xs            JDouble _ -> ret v'@@ -275,25 +291,12 @@                      m' = ret (M.fromAscList . zip ls) `app` mapM' f vs            JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s            UnsatVal _ -> ret v'-      where-        mapM' :: (a -> m a) -> [a] -> m [a]-        mapM' g = foldr (app . app (ret (:)) . g) (ret [])-        f :: JMacro a => a -> m a-        f x = ret fromMC `app` f' (toMC x) -instance Compos JType where-    compos ret app f v =-        case v of-          JTFunc args body -> ret JTFunc `app` mapM' f args `app` f body-          JTForall vars t -> ret JTForall `app` ret vars `app` f t-          JTList t -> ret JTList `app` f t-          JTMap t -> ret JTMap `app` f t-          JTRecord t m -> ret JTRecord `app` f t `app` m'-              where (ls,ts) = unzip $ M.toList m-                    m' = ret (M.fromAscList . zip ls) `app` mapM' f ts-          x -> ret x-      where-        mapM' g = foldr (app . app (ret (:)) . g) (ret [])+  where+    mapM' :: forall a. (a -> m a) -> [a] -> m [a]+    mapM' g = foldr (app . app (ret (:)) . g) (ret [])+    f :: forall b. JMacro b => b -> m b+    f x = ret jfromGADT `app` f' (jtoGADT x)  {--------------------------------------------------------------------   New Identifiers@@ -336,12 +339,14 @@ jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str)  jsSaturate_ :: (JMacro a) => a -> IdentSupply a-jsSaturate_ e = IS $ fromMC <$> go (toMC e)-    where go v = case v of-                   MStat (UnsatBlock us) -> go =<< (MStat <$> runIdentSupply us)-                   MExpr (UnsatExpr  us) -> go =<< (MExpr <$> runIdentSupply us)-                   MVal  (UnsatVal   us) -> go =<< (MVal  <$> runIdentSupply us)-                   _ -> composOpM go v+jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)+    where +      go :: forall a. JMGadt a -> State [Ident] (JMGadt a)+      go v = case v of+               JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us)+               JMGExpr (UnsatExpr  us) -> go =<< (JMGExpr <$> runIdentSupply us)+               JMGVal  (UnsatVal   us) -> go =<< (JMGVal  <$> runIdentSupply us)+               _ -> composOpM go v  {--------------------------------------------------------------------   Transformation@@ -349,11 +354,13 @@  --doesn't apply to unsaturated bits jsReplace_ :: JMacro a => [(Ident, Ident)] -> a -> a-jsReplace_ xs e = fromMC $ go (toMC e)-    where go v = case v of-                   MIdent i -> maybe v MIdent (M.lookup i mp)+jsReplace_ xs e = jfromGADT $ go (jtoGADT e)+    where +      go :: forall a. JMGadt a -> JMGadt a    +      go v = case v of+                   JMGId i -> maybe v JMGId (M.lookup i mp)                    _ -> composOp go v-          mp = M.fromList xs+      mp = M.fromList xs  --only works on fully saturated things jsUnsat_ :: JMacro a => [Ident] -> a -> IdentSupply a@@ -367,28 +374,24 @@ -- following the transformation. As the transformation preserves -- free variables, it is hygienic. Cannot be used nested. withHygiene:: JMacro a => (a -> a) -> a -> a-withHygiene f x = fromMC $ case mx of-              MStat _  -> toMC $ UnsatBlock (coerceMC <$> jsUnsat_ is' x'')-              MExpr _  -> toMC $ UnsatExpr  (coerceMC <$> jsUnsat_ is' x'')-              MVal  _  -> toMC $ UnsatVal   (coerceMC <$> jsUnsat_ is' x'')-              MIdent _ -> toMC $ f x+withHygiene f x = jfromGADT $ case mx of+              JMGStat _  -> jtoGADT $ UnsatBlock (jsUnsat_ is' x'')+              JMGExpr _  -> jtoGADT $ UnsatExpr  (jsUnsat_ is' x'')+              JMGVal  _  -> jtoGADT $ UnsatVal   (jsUnsat_ is' x'')+              JMGId _ -> jtoGADT $ f x     where (x', (StrI l:_)) = runState (runIdentSupply $ jsSaturate_ x) is           x'' = f x'           is = newIdentSupply (Just "inSat")           lastVal = readNote "inSat" (drop 6 l) :: Int           is' = take lastVal is-          mx = toMC x-          coerceMC :: (JMacro a, JMacro b) => a -> b-          coerceMC = fromMC . toMC---+          mx = jtoGADT x  -- | Takes a fully saturated expression and transforms it to use unique variables that respect scope. scopify :: JStat -> JStat-scopify x = evalState (fromMC <$> go (toMC x)) (newIdentSupply Nothing)-    where go v = case v of-                   (MStat (BlockStat ss)) -> MStat . BlockStat <$>+scopify x = evalState (jfromGADT <$> go (jtoGADT x)) (newIdentSupply Nothing)+    where go :: forall a. JMGadt a -> State [Ident] (JMGadt a)+          go v = case v of+                   (JMGStat (BlockStat ss)) -> JMGStat . BlockStat <$>                                              blocks ss                        where blocks [] = return []                              blocks (DeclStat (StrI i) t : xs) =  case i of@@ -399,26 +402,26 @@                                   put st                                   rest <- blocks xs                                   return $ [DeclStat newI t `mappend` jsReplace_ [(StrI i, newI)] (BlockStat rest)]-                             blocks (x':xs) = (fromMC <$> go (toMC x')) <:> blocks xs+                             blocks (x':xs) = (jfromGADT <$> go (jtoGADT x')) <:> blocks xs                              (<:>) = liftM2 (:)-                   (MStat (ForInStat b (StrI i) e s)) -> do+                   (JMGStat (ForInStat b (StrI i) e s)) -> do                           (newI:st) <- get                           put st-                          rest <- fromMC <$> go (toMC s)-                          return $ MStat . ForInStat b newI e $ jsReplace_ [(StrI i, newI)] rest-                   (MStat (TryStat s (StrI i) s1 s2)) -> do+                          rest <- jfromGADT <$> go (jtoGADT s)+                          return $ JMGStat . ForInStat b newI e $ jsReplace_ [(StrI i, newI)] rest+                   (JMGStat (TryStat s (StrI i) s1 s2)) -> do                           (newI:st) <- get                           put st-                          t <- fromMC <$> go (toMC s)-                          c <- fromMC <$> go (toMC s1)-                          f <- fromMC <$> go (toMC s2)-                          return . MStat . TryStat t newI (jsReplace_ [(StrI i, newI)] c) $ f-                   (MExpr (ValExpr (JFunc is s))) -> do+                          t <- jfromGADT <$> go (jtoGADT s)+                          c <- jfromGADT <$> go (jtoGADT s1)+                          f <- jfromGADT <$> go (jtoGADT s2)+                          return . JMGStat . TryStat t newI (jsReplace_ [(StrI i, newI)] c) $ f+                   (JMGExpr (ValExpr (JFunc is s))) -> do                             st <- get                             let (newIs,newSt) = splitAt (length is) st                             put (newSt)-                            rest <- fromMC <$> go (toMC s)-                            return . MExpr . ValExpr $ JFunc newIs $ (jsReplace_ $ zip is newIs) rest+                            rest <- jfromGADT <$> go (jtoGADT s)+                            return . JMGExpr . ValExpr $ JFunc newIs $ (jsReplace_ $ zip is newIs) rest                    _ -> composOpM go v  {--------------------------------------------------------------------@@ -436,10 +439,10 @@ renderPrefixJs pfx = jsToDoc . jsSaturate (Just $ "jmId_"++pfx)  braceNest :: Doc -> Doc-braceNest x = char '{' $$ nest 2 x $$ char '}'+braceNest x = char '{' <+> nest 2 x $$ char '}'  braceNest' :: Doc -> Doc-braceNest' x = char '{' $+$ nest 2 x $$ char '}'+braceNest' x = nest 2 (char '{' $+$ x) $$ char '}'  class JsToDoc a     where jsToDoc :: a -> Doc@@ -452,17 +455,28 @@         where rest = case t of                        Nothing -> text ""                        Just tp -> text " /* ::" <+> jsToDoc tp <+> text "*/"-    jsToDoc (WhileStat p b)  = text "while" <> parens (jsToDoc p) $$ braceNest' (jsToDoc b)+    jsToDoc (WhileStat False p b)  = text "while" <> parens (jsToDoc p) $$ braceNest' (jsToDoc b)+    jsToDoc (WhileStat True  p b)  = (text "do" $$ braceNest' (jsToDoc b)) $+$ text "while" <+> parens (jsToDoc p)     jsToDoc (UnsatBlock e) = jsToDoc $ sat_ e-    jsToDoc BreakStat = text "break"++    jsToDoc (BreakStat l) = maybe (text "break") (((<+>) `on` text) "break" . T.pack) l+    jsToDoc (ContinueStat l) = maybe (text "continue") (((<+>) `on` text) "continue" . T.pack) l+    jsToDoc (LabelStat l s) = text (T.pack l) <> char ':' $$ printBS s+        where+          printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss+          printBS x = jsToDoc x+          interSemi [x] = [jsToDoc x]+          interSemi [] = []+          interSemi (x:xs) = (jsToDoc x <> semi) : interSemi xs+     jsToDoc (ForInStat each i e b) = text txt <> parens (text "var" <+> jsToDoc i <+> text "in" <+> jsToDoc e) $$ braceNest' (jsToDoc b)         where txt | each = "for each"                   | otherwise = "for"     jsToDoc (SwitchStat e l d) = text "switch" <+> parens (jsToDoc e) $$ braceNest' cases-        where l' = map (\(c,s) -> text "case" <+> parens (jsToDoc c) <> char ':' $$ nest 2 (jsToDoc [s])) l ++ [text "default:" $$ nest 2 (jsToDoc [d])]+        where l' = map (\(c,s) -> (text "case" <+> parens (jsToDoc c) <> char ':') $$$ (jsToDoc s)) l ++ [text "default:" $$$ (jsToDoc d)]               cases = vcat l'     jsToDoc (ReturnStat e) = text "return" <+> jsToDoc e-    jsToDoc (ApplStat e es) = jsToDoc e <> (parens . fsep . punctuate comma $ map jsToDoc es)+    jsToDoc (ApplStat e es) = jsToDoc e <> (parens . fillSep . punctuate comma $ map jsToDoc es)     jsToDoc (TryStat s i s1 s2) = text "try" $$ braceNest' (jsToDoc s) $$ mbCatch $$ mbFinally         where mbCatch | s1 == BlockStat [] = PP.empty                       | otherwise = text "catch" <> parens (jsToDoc i) $$ braceNest' (jsToDoc s1)@@ -470,49 +484,56 @@                         | otherwise = text "finally" $$ braceNest' (jsToDoc s2)     jsToDoc (AssignStat i x) = jsToDoc i <+> char '=' <+> jsToDoc x     jsToDoc (PPostStat isPre op x)-        | isPre = text op <> jsToDoc x-        | otherwise = jsToDoc x <> text op-    jsToDoc (AntiStat s) = text $ "`(" ++ s ++ ")`"+        | isPre = text (T.pack op) <> optParens x+        | otherwise = optParens x <> text (T.pack op)+    jsToDoc (AntiStat s) = text . T.pack $ "`(" ++ s ++ ")`"     jsToDoc (ForeignStat i t) = text "//foriegn" <+> jsToDoc i <+> text "::" <+> jsToDoc t     jsToDoc (BlockStat xs) = jsToDoc (flattenBlocks xs)-        where flattenBlocks (BlockStat y:ys) = flattenBlocks y ++ flattenBlocks ys-              flattenBlocks (y:ys) = y : flattenBlocks ys-              flattenBlocks [] = [] +flattenBlocks :: [JStat] -> [JStat]+flattenBlocks (BlockStat y:ys) = flattenBlocks y ++ flattenBlocks ys+flattenBlocks (y:ys) = y : flattenBlocks ys+flattenBlocks [] = []++optParens :: JExpr -> Doc+optParens x = case x of+                (PPostExpr _ _ _) -> parens (jsToDoc x)+                _ -> jsToDoc x+ instance JsToDoc JExpr where     jsToDoc (ValExpr x) = jsToDoc x     jsToDoc (SelExpr x y) = cat [jsToDoc x <> char '.', jsToDoc y]     jsToDoc (IdxExpr x y) = jsToDoc x <> brackets (jsToDoc y)     jsToDoc (IfExpr x y z) = parens (jsToDoc x <+> char '?' <+> jsToDoc y <+> char ':' <+> jsToDoc z)-    jsToDoc (InfixExpr op x y) = parens $ sep [jsToDoc x, text op', jsToDoc y]+    jsToDoc (InfixExpr op x y) = parens $ sep [jsToDoc x, text (T.pack op'), jsToDoc y]         where op' | op == "++" = "+"                   | otherwise = op      jsToDoc (PPostExpr isPre op x)-        | isPre = text op <> jsToDoc x-        | otherwise = jsToDoc x <> text op+        | isPre = text (T.pack op) <> optParens x+        | otherwise = optParens x <> text (T.pack op) -    jsToDoc (ApplExpr je xs) = jsToDoc je <> (parens . fsep . punctuate comma $ map jsToDoc xs)+    jsToDoc (ApplExpr je xs) = jsToDoc je <> (parens . fillSep . punctuate comma $ map jsToDoc xs)     jsToDoc (NewExpr e) = text "new" <+> jsToDoc e-    jsToDoc (AntiExpr s) = text $ "`(" ++ s ++ ")`"+    jsToDoc (AntiExpr s) = text . T.pack $ "`(" ++ s ++ ")`"     jsToDoc (TypeExpr b e t)  = parens $ jsToDoc e <+> text (if b then "/* ::!" else "/* ::") <+> jsToDoc t <+> text "*/"     jsToDoc (UnsatExpr e) = jsToDoc $ sat_ e  instance JsToDoc JVal where     jsToDoc (JVar i) = jsToDoc i-    jsToDoc (JList xs) = brackets . fsep . punctuate comma $ map jsToDoc xs+    jsToDoc (JList xs) = brackets . fillSep . punctuate comma $ map jsToDoc xs     jsToDoc (JDouble d) = double d     jsToDoc (JInt i) = integer i-    jsToDoc (JStr s) = text ("\""++encodeJson s++"\"")-    jsToDoc (JRegEx s) = text ("/"++s++"/")+    jsToDoc (JStr s) = text . T.pack $ "\""++encodeJson s++"\""+    jsToDoc (JRegEx s) = text . T.pack $ "/"++s++"/"     jsToDoc (JHash m)             | M.null m = text "{}"-            | otherwise = braceNest . fsep . punctuate comma . map (\(x,y) -> quotes (text x) <> colon <+> jsToDoc y) $ M.toList m-    jsToDoc (JFunc is b) = parens $ text "function" <> parens (fsep . punctuate comma . map jsToDoc $ is) $$ braceNest' (jsToDoc b)+            | otherwise = braceNest . fillSep . punctuate comma . map (\(x,y) -> squotes (text (T.pack x)) <> colon <+> jsToDoc y) $ M.toList m+    jsToDoc (JFunc is b) = parens $ text "function" <> parens (fillSep . punctuate comma . map jsToDoc $ is) $$ braceNest' (jsToDoc b)     jsToDoc (UnsatVal f) = jsToDoc $ sat_ f  instance JsToDoc Ident where-    jsToDoc (StrI s) = text s+    jsToDoc (StrI s) = text (T.pack s)  instance JsToDoc [JExpr] where     jsToDoc = vcat . map ((<> semi) . jsToDoc)@@ -526,14 +547,14 @@     jsToDoc JTBool = text "Bool"     jsToDoc JTStat = text "()"     jsToDoc JTImpossible = text "_|_" -- "⊥"-    jsToDoc (JTForall vars t) = text "forall" <+> fsep  (punctuate comma (map ppRef vars)) <> text "." <+> jsToDoc t-    jsToDoc (JTFunc args ret) = fsep . punctuate (text " ->") . map ppType $ args' ++ [ret]+    jsToDoc (JTForall vars t) = text "forall" <+> fillSep  (punctuate comma (map ppRef vars)) <> text "." <+> jsToDoc t+    jsToDoc (JTFunc args ret) = fillSep . punctuate (text " ->") . map ppType $ args' ++ [ret]         where args'                | null args = [JTStat]                | otherwise = args     jsToDoc (JTList t) = brackets $ jsToDoc t     jsToDoc (JTMap t) = text "Map" <+> ppType t-    jsToDoc (JTRecord t mp) = braces (fsep . punctuate comma . map (\(x,y) -> text x <+> text "::" <+> jsToDoc y) $ M.toList mp) <+> text "[" <> jsToDoc t <> text "]"+    jsToDoc (JTRecord t mp) = braces (fillSep . punctuate comma . map (\(x,y) -> text (T.pack x) <+> text "::" <+> jsToDoc y) $ M.toList mp) <+> text "[" <> jsToDoc t <> text "]"     jsToDoc (JTFree ref) = ppRef ref     jsToDoc (JTRigid ref cs) = text "[" <> ppRef ref <> text "]" {-@@ -545,16 +566,19 @@ instance JsToDoc JLocalType where     jsToDoc (cs,t) = maybe (text "") (<+> text "=> ") (ppConstraintList cs) <> jsToDoc t +ppConstraintList :: Show a => [((Maybe String, a), Constraint)] -> Maybe Doc ppConstraintList cs     | null cs = Nothing-    | otherwise = Just . parens . fsep . punctuate comma $ map go cs+    | otherwise = Just . parens . fillSep . punctuate comma $ map go cs     where       go (vr,Sub   t') = ppRef vr   <+> text "<:" <+> jsToDoc t'       go (vr,Super t') = jsToDoc t' <+> text "<:" <+> ppRef vr +ppRef :: Show a => (Maybe String, a) -> Doc+ppRef (Just n,_) = text . T.pack $ n+ppRef (_,i) = text . T.pack $ "t_"++show i -ppRef (Just n,_) = text n-ppRef (_,i) = text $ "t_"++show i+ppType :: JType -> Doc ppType x@(JTFunc _ _) = parens $ jsToDoc x ppType x@(JTMap _) = parens $ jsToDoc x ppType x = jsToDoc x@@ -705,7 +729,7 @@ jsv = ValExpr . JVar . StrI  jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat-jFor before p after b = BlockStat [before, WhileStat (toJExpr p) b']+jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b']     where b' = case toStat b of                  BlockStat xs -> BlockStat $ xs ++ [after]                  x -> BlockStat [x,after]@@ -728,19 +752,20 @@ nullStat :: JStat nullStat = BlockStat [] ---- JSON instance-instance ToJExpr JSValue where-    toJExpr JSNull             = ValExpr $ JVar $ StrI "null"-    toJExpr (JSBool b)         = ValExpr $ JVar $ StrI $ map toLower (show b)-    toJExpr (JSRational b rat) = ValExpr $ JDouble $ realToFrac rat-    toJExpr (JSString s)       = ValExpr $ JStr $ fromJSString s-    toJExpr (JSArray vs)       = ValExpr $ JList $ map toJExpr vs-    toJExpr (JSObject obj)     = ValExpr $ JHash $ M.fromList $ map (second toJExpr) $ fromJSObject obj+-- Aeson instance+instance ToJExpr Value where+    toJExpr Null             = ValExpr $ JVar $ StrI "null"+    toJExpr (Bool b)         = ValExpr $ JVar $ StrI $ map toLower (show b)+    toJExpr (Number n)       = ValExpr $ JDouble $ realToFrac n+    toJExpr (String s)       = ValExpr $ JStr $ TS.unpack s+    toJExpr (Array vs)       = ValExpr $ JList $ map toJExpr $ V.toList vs+    toJExpr (Object obj)     = ValExpr $ JHash $ M.fromList $ map (TS.unpack *** toJExpr) $ HM.toList obj  -------------------------  -- Taken from json package by Sigbjorn Finne.++encodeJson :: String -> String encodeJson = concatMap encodeJsonChar  encodeJsonChar :: Char -> String

@@ -0,0 +1,11 @@+{-# LANGUAGE QuasiQuotes #-}++import Criterion.Main+import Language.Javascript.JMacro+import Text.PrettyPrint.Leijen.Text (renderPretty, renderCompact, displayT)++main = defaultMain [pretty, compact]++pretty = bench "pretty" $ nf (displayT . renderPretty 0.4 100 . renderJs) jmPrelude++compact = bench "compact" $ nf (displayT . renderCompact . renderJs) jmPrelude

@@ -1,5 +1,8 @@+{-# LANGUAGE GADTs, RankNTypes #-}+ module Main where +import Text.PrettyPrint.Leijen.Text (hPutDoc) import Control.Applicative import Control.Monad import Language.Javascript.JMacro@@ -17,7 +20,7 @@    let s = gotArg args "Scope"    infile <- getArgStdio args "Infile" ReadMode    outfile <- getArgStdio args "Outfile" WriteMode-   either (hPrint stderr) (hPrint outfile) . parseIt s =<< hGetContents infile+   either (hPrint stderr) (hPutDoc outfile) . parseIt s =<< hGetContents infile   where     parseIt True  = onRight (renderJs . scopify)  . parseJM     parseIt False = onRight (renderJs . fixIdent) . parseJM@@ -25,8 +28,10 @@     onRight f (Right x) = Right (f x)     onRight _ (Left x) = (Left x) -    fixIdent x = fromMC $ composOp go (toMC x) :: JStat-        where go v = case v of-                       (MStat (DeclStat (StrI ('!':'!':i')) t)) -> MStat (DeclStat (StrI i') t)-                       (MStat (DeclStat (StrI ('!':i')) t)) -> MStat (DeclStat (StrI i') t)+    fixIdent x = jfromGADT $ composOp go (jtoGADT x) :: JStat+        where+          go :: forall a. JMGadt a -> JMGadt a+          go v = case v of+                       (JMGStat (DeclStat (StrI ('!':'!':i')) t)) -> JMGStat (DeclStat (StrI i') t)+                       (JMGStat (DeclStat (StrI ('!':i')) t)) -> JMGStat (DeclStat (StrI i') t)                        _ -> composOp go v

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes, RankNTypes, GADTs #-}  ----------------------------------------------------------------------------- {- |@@ -17,7 +17,6 @@ import Control.Applicative hiding ((<|>),many,optional,(<*)) import Control.Arrow(first) import Control.Monad.State.Strict-import qualified Data.ByteString.Char8 as BS import Data.Char(digitToInt, toLower, isUpper) import Data.List(isPrefixOf, sort) import Data.Generics(extQ,Data)@@ -46,9 +45,7 @@ import System.IO.Unsafe import Numeric(readHex) --- import Web.Encodings----import Debug.Trace+-- import Debug.Trace  {--------------------------------------------------------------------   QuasiQuotation@@ -96,11 +93,12 @@ -- Don't replace identifiers on the right hand side of selector -- expressions. antiIdent :: JMacro a => String -> a -> a-antiIdent s e = fromMC $ go (toMC e)-    where go (MExpr (ValExpr (JVar (StrI s'))))-             | s == s' = MExpr (AntiExpr $ fixIdent s)-          go (MExpr (SelExpr x i)) =-              MExpr (SelExpr (antiIdent s x) i)+antiIdent s e = jfromGADT $ go (jtoGADT e)+    where go :: forall a. JMGadt a -> JMGadt a+          go (JMGExpr (ValExpr (JVar (StrI s'))))+             | s == s' = JMGExpr (AntiExpr $ fixIdent s)+          go (JMGExpr (SelExpr x i)) =+              JMGExpr (SelExpr (antiIdent s x) i)           go x = composOp go x  antiIdents :: JMacro a => [String] -> a -> a@@ -233,8 +231,8 @@  jsLang :: P.LanguageDef () jsLang = javaStyle {-           P.reservedNames = ["var","return","if","else","while","for","in","break","new","function","switch","case","default","fun","try","catch","finally","foreign"],-           P.reservedOpNames = ["|>","<|","+=","-=","*=","/=","%=","--","*","/","+","-",".","%","?","=","==","!=","<",">","&&","||","++","===",">=","<=","->","::","::!",":|","@"],+           P.reservedNames = ["var","return","if","else","while","for","in","break","continue","new","function","switch","case","default","fun","try","catch","finally","foreign","do"],+           P.reservedOpNames = ["|>","<|","+=","-=","*=","/=","%=","<<=", ">>=", ">>>=", "&=", "^=", "|=", "--","*","/","+","-",".","%","?","=","==","!=","<",">","&&","||","&", "^", "|", "++","===","!==", ">=","<=","!", "~", "<<", ">>", ">>>", "->","::","::!",":|","@"],            P.identLetter = alphaNum <|> oneOf "_$",            P.identStart  = letter <|> oneOf "_$",            P.commentLine = "//",@@ -357,6 +355,7 @@ patternBlocks :: JMParser ([Ident],[JStat]) patternBlocks = fmap concat . unzip . zipWith (\i efr -> either (\f -> (i, f i)) id efr) (map (StrI . ("jmId_match_" ++) . show) [(1::Int)..]) <$> many patternBinding +destructuringDecl :: JMParser [JStat] destructuringDecl = do     (i,patDecls) <- either (\f -> (matchVar, f matchVar)) id <$> patternBinding     optAssignStat <- optionMaybe $ do@@ -386,15 +385,18 @@             <|> functionDecl             <|> foreignStat             <|> returnStat+            <|> labelStat             <|> ifStat             <|> whileStat             <|> switchStat             <|> forStat+            <|> doWhileStat             <|> braces statblock             <|> assignOpStat             <|> tryStat             <|> applStat             <|> breakStat+            <|> continueStat             <|> antiStat           <?> "statement"     where@@ -447,9 +449,12 @@           else return $ [IfStat p b nullStat]        whileStat =-          reserved "while" >> liftM2 (\e b -> [WhileStat e (l2s b)])+          reserved "while" >> liftM2 (\e b -> [WhileStat False e (l2s b)])                               (parens expr) statementOrEmpty +      doWhileStat = reserved "do" >> liftM2 (\b e -> [WhileStat True e (l2s b)])+                    statementOrEmpty (reserved "while" *> parens expr)+       switchStat = do         reserved "switch"         e <- parens $ expr@@ -457,7 +462,7 @@         return $ [SwitchStat e l (l2s d)]        caseStat =-        reserved "case" >> liftM2 (,) expr (char ':' >> l2s <$> statblock0)+        reserved "case" >> liftM2 (,) expr (char ':' >> l2s <$> statblock)        tryStat = do         reserved "try"@@ -499,11 +504,11 @@         b <- statement         return $ jFor' before after p b           where threeStat =-                    liftM3 (,,) (statement)-                                (expr)-                                (semi >> statement)-                jFor' :: (ToJExpr a) => [JStat] -> a -> [JStat] -> [JStat] -> [JStat]-                jFor' before p after bs = before ++ [WhileStat (toJExpr p) b']+                    liftM3 (,,) (option [] statement <* optional semi)+                                (optionMaybe expr <* semi)+                                (option [] statement)+                jFor' :: [JStat] -> Maybe JExpr -> [JStat]-> [JStat] -> [JStat]+                jFor' before p after bs = before ++ [WhileStat False (fromMaybe (jsv "true") p) b']                     where b' = BlockStat $ bs ++ after        assignOpStat = do@@ -514,6 +519,12 @@                                                <|> rop "*="                                                <|> rop "/="                                                <|> rop "%="+                                               <|> rop "<<="+                                               <|> rop ">>="+                                               <|> rop ">>>="+                                               <|> rop "&="+                                               <|> rop "^="+                                               <|> rop "|="                                               )           let gofail = fail ("Invalid assignment.")           case e1 of@@ -541,8 +552,24 @@       expr2stat' _ = fail "Value expression used as statement" -} -      breakStat = reserved "break" >> return [BreakStat]+      breakStat = do+        reserved "break"+        l <- optionMaybe myIdent+        return [BreakStat l] +      continueStat = do+        reserved "continue"+        l <- optionMaybe myIdent+        return [ContinueStat l]++      labelStat = do+        lbl <- try $ do+                    l <- myIdent <* char ':'+                    guard (l /= "default")+                    return l+        s <- l2s <$> statblock0+        return [LabelStat lbl s]+       antiStat  = return . AntiStat <$> do         x <- (try (symbol "`(") >> anyChar `manyTill` try (symbol ")`"))         either (fail . ("Bad AntiQuotation: \n" ++))@@ -552,6 +579,7 @@ --args :: JMParser [JExpr] --args = parens $ commaSep expr +compileRegex :: String -> Either WrapError Regex compileRegex s = unsafePerformIO $ compile co eo s     where co = compExtended           eo = execBlank@@ -577,20 +605,26 @@           let ans = (IfExpr e t el)           addIf ans <|> return ans     rawExpr = buildExpressionParser table dotExpr <?> "expression"-    table = [[iop "*", iop "/", iop "%"],+    table = [[pop "~", pop "!"],+             [iop "*", iop "/", iop "%"],              [pop "++", pop "--"],              [iop "++", iop "+", iop "-", iop "--"],+             [iop "<<", iop ">>", iop ">>>"],              [consOp],              [iope "==", iope "!=", iope "<", iope ">",-              iope ">=", iope "<=", iope "==="],-             [iop "&&", iop "||"],+              iope ">=", iope "<=", iope "===", iope "!=="],+             [iop "&"],+             [iop "^"],+             [iop "|"],+             [iop "&&"],+             [iop "||"],              [applOp, applOpRev]             ]     pop  s  = Prefix (reservedOp s >> return (PPostExpr True s))     iop  s  = Infix (reservedOp s >> return (InfixExpr s)) AssocLeft     iope s  = Infix (reservedOp s >> return (InfixExpr s)) AssocNone     applOp  = Infix (reservedOp "<|" >> return (\x y -> ApplExpr x [y])) AssocRight-    applOpRev  = Infix (reservedOp "|>" >> return (\x y -> ApplExpr y [x])) AssocLeft+    applOpRev = Infix (reservedOp "|>" >> return (\x y -> ApplExpr y [x])) AssocLeft     consOp  = Infix (reservedOp ":|" >> return consAct) AssocRight     consAct x y = ApplExpr (ValExpr (JFunc [StrI "x",StrI "y"] (BlockStat [BlockStat [DeclStat (StrI "tmp") Nothing, AssignStat tmpVar (ApplExpr (SelExpr (ValExpr (JVar (StrI "x"))) (StrI "slice")) [ValExpr (JInt 0)]),ApplStat (SelExpr tmpVar (StrI "unshift")) [ValExpr (JVar (StrI "y"))],ReturnStat tmpVar]]))) [x,y]         where tmpVar = ValExpr (JVar (StrI "tmp"))@@ -664,7 +698,7 @@ around' a b x = lexeme (char a) >> (lexeme x <* char b)  myIdent :: JMParser String-myIdent = lexeme $ many1 (alphaNum <|> oneOf "_-!@#$%^&*();") <|> myStringLiteral '\''+myIdent = lexeme $ many1 (alphaNum <|> oneOf "_-!@#$%^&*()") <|> myStringLiteral '\''  ident' :: JMParser Ident ident' = do@@ -758,35 +792,35 @@  -- Taken from json package by Sigbjorn Finne. decodeJson :: String -> JMParser String-decodeJson x = parse [] x+decodeJson x = parseIt [] x  where-  parse rs cs =+  parseIt rs cs =     case cs of       '\\' : c : ds -> esc rs c ds       c    : ds-       | c >= '\x20' && c <= '\xff'    -> parse (c:rs) ds+       | c >= '\x20' && c <= '\xff'    -> parseIt (c:rs) ds        | c < '\x20'     -> fail $ "Illegal unescaped character in string: " ++ x-       | i <= 0x10ffff  -> parse (c:rs) ds+       | i <= 0x10ffff  -> parseIt (c:rs) ds        | otherwise -> fail $ "Illegal unescaped character in string: " ++ x        where         i = (fromIntegral (fromEnum c) :: Integer)       [] -> return $ reverse rs    esc rs c cs = case c of-   '\\' -> parse ('\\' : rs) cs-   '"'  -> parse ('"'  : rs) cs-   'n'  -> parse ('\n' : rs) cs-   'r'  -> parse ('\r' : rs) cs-   't'  -> parse ('\t' : rs) cs-   'f'  -> parse ('\f' : rs) cs-   'b'  -> parse ('\b' : rs) cs-   '/'  -> parse ('/'  : rs) cs+   '\\' -> parseIt ('\\' : rs) cs+   '"'  -> parseIt ('"'  : rs) cs+   'n'  -> parseIt ('\n' : rs) cs+   'r'  -> parseIt ('\r' : rs) cs+   't'  -> parseIt ('\t' : rs) cs+   'f'  -> parseIt ('\f' : rs) cs+   'b'  -> parseIt ('\b' : rs) cs+   '/'  -> parseIt ('/'  : rs) cs    'u'  -> case cs of              d1 : d2 : d3 : d4 : cs' ->                case readHex [d1,d2,d3,d4] of-                 [(n,"")] -> parse (toEnum n : rs) cs'+                 [(n,"")] -> parseIt (toEnum n : rs) cs' -                 x -> fail $ "Unable to parse JSON String: invalid hex: " ++ (show x)+                 badHex -> fail $ "Unable to parse JSON String: invalid hex: " ++ show badHex              _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ cs    _ ->  fail $ "Unable to parse JSON String: invalid escape char: " ++ [c] 

@@ -1,122 +0,0 @@-{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}--{- |-Module      :  Language.Javascript.JMacro.Rpc-Copyright   :  (c) Gershom Bazerman, 2010-License     :  BSD 3 Clause-Maintainer  :  gershomb@gmail.com-Stability   :  experimental--Allows for the creation of rpc server/client pairs from monomorphic functions.-The server portion-is a function from a json-encoded list of parameters to a json-response. A list of server functions are expected to be wrapped by a-dispatch function in the server framework of your choice.--The client-portion generated from a function of arity n is a function from a-string identifying a server or a subdirectory on a server to an arity-n function from javascript expressions (of type-'Language.Javascript.JMacro.Base.JExpr') to a single javascript-expression. This expression, when evaluated on the client side, will-call back to the provided server with json-serialized arguments and yield-the result (deserialized from json). This client function is expected to be embedded-via antiquotation into a larger block of jmacro code.--Client portions must unfortunately be given explicit type signatures.--The following example is a server/client pair providing an ajax call to add integers.--> testRPCCall :: String -> JExpr -> JExpr -> JExpr-> (testRPC, testRPCCall) = mkWebRPC "test" $ \x y -> asIO $ return (x + (y::Int))--This code uses a simple request/response type based on strings to be as agnostic as possible about choice of web service stack. It can be used as is, or used as a model for code which targets a particular web stack (Happstack, Snap, FastCGI, etc.).--The jQuery Javascript library is used to handle ajax requests, and hence pages which embed RPC calls must have the jQuery javascript library loaded.---}--module Language.Javascript.JMacro.Rpc (-  -- * API-  mkWebRPC, asIO, Request, Response(..), WebRPCDesc,-  -- * Helper Classes-  CallWebRPC(..),ToWebRPC(..)-) where--import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)---import Language.Javascript.JMacro.Base-import Language.Javascript.JMacro.QQ--import Text.JSON-import Text.JSON.String--type WebRPCDesc = (String, Request -> IO Response)---- | A String containing a json representation of function arguments encoded as a list of parameters. Generally would be passed as part of an HTTP request.-type Request = String---- | Either a success or failure (with code). Generally would be turned back into a proper HTTP response.-data Response = GoodResponse String-              | BadResponse Int String--returnResp :: JSON a => a -> IO Response-returnResp r = return $ GoodResponse (encode r)-respCode c e = BadResponse c e-badData e = return $ respCode 400 ("Bad Data format: " ++ e)--class ToWebRPC a where-    toWebRPC_ :: a -> ([JSValue] -> IO Response)--instance (JSON b) => ToWebRPC (IO b) where-    toWebRPC_ f _ =  returnResp =<< f--instance (JSON a, ToWebRPC b) => ToWebRPC (a -> b) where-    toWebRPC_ f (x:xs) = case readJSON x of-                           Ok v -> toWebRPC_ (f v) xs-                           Error s -> badData s-    toWebRPC_ _ _ = badData "missing parameter"--toWebRPC :: ToWebRPC a => a -> Request -> IO Response-toWebRPC f = \req -> case runGetJSON readJSArray req of-                       (Right (JSArray xs)) ->f' xs-                       (Left e) -> badData e-                       _ -> badData "toWebRPC error"-    where f' = toWebRPC_ f--class CallWebRPC a b | a -> b where-    callWebRPC_ :: [JExpr] -> String -> a -> b--instance CallWebRPC (IO b) JExpr where-    callWebRPC_ xs serverLoc _ =-        [$jmacroE|-         (\() { var res;-//                $.post(`(serverLoc)`, { args : JSON.stringify `(reverse xs)` }, \(d) {res = d}, "json");-                $.ajax({type    : "POST",-                        url     : `(serverLoc)`,-                        data    : { args : JSON.stringify `(reverse xs)` },-                        success : \d {res = d},-                        dataType: "json",-                        async   : false-                      });-                return res;-               }())|]--instance (CallWebRPC b c, ToJExpr d) => CallWebRPC (a -> b) (d -> c) where-    callWebRPC_ xs serverLoc f = \x -> callWebRPC_ (toJExpr x : xs) serverLoc (f undefined)--callWebRPC :: (CallWebRPC a b) => String -> a -> b-callWebRPC s f = callWebRPC_ [] s f---- | Produce a pair of (ServerFunction, ClientFunction) from a function in IO-mkWebRPC :: (ToWebRPC a, CallWebRPC a b) => String -> a -> (WebRPCDesc, String -> b)-mkWebRPC name rpcFun = ((name,toWebRPC rpcFun), \server -> callWebRPC (server ++ "/" ++ name) rpcFun)---testRPCCall :: String -> JExpr -> JExpr -> JExpr-(testRPC, testRPCCall) = mkWebRPC "test" $ \x y -> asIO $ return (x + (y::Int))---- | id with a helpful type.-asIO :: IO a -> IO a-asIO = id

@@ -1,34 +1,34 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards, RankNTypes #-}  module Language.Javascript.JMacro.TypeCheck where  import Language.Javascript.JMacro.Base import Language.Javascript.JMacro.Types-import Language.Javascript.JMacro.QQ  import Control.Applicative-import Control.Arrow((&&&)) import Control.Monad+import Control.Monad.Identity import Control.Monad.State import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Error import Data.Either import Data.Map (Map)-import Data.Maybe(catMaybes, fromMaybe)+import Data.Maybe(catMaybes) import Data.List(intercalate, nub, transpose) import qualified Data.Traversable as T import qualified Data.Foldable as F import qualified Data.Map as M+import qualified Data.Text.Lazy as T import Data.Set(Set) import qualified Data.Set as S -import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint.Leijen.Text hiding ((<$>)) -import Debug.Trace  -- Utility +isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft _ = False @@ -53,6 +53,34 @@ intersectionWithM :: (Monad m, Ord key) => (val -> val -> m b) -> Map key val -> Map key val -> m (Map key b) intersectionWithM f m1 m2 = T.sequence $ M.intersectionWith f m1 m2 +class Compos1 t where+    compos1 :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)+           -> (t -> m t) -> t -> m t++instance Compos1 JType where+    compos1 ret app f v =+        case v of+          JTFunc args body -> ret JTFunc `app` mapM' f args `app` f body+          JTForall vars t -> ret JTForall `app` ret vars `app` f t+          JTList t -> ret JTList `app` f t+          JTMap t -> ret JTMap `app` f t+          JTRecord t m -> ret JTRecord `app` f t `app` m'+              where (ls,ts) = unzip $ M.toList m+                    m' = ret (M.fromAscList . zip ls) `app` mapM' f ts+          x -> ret x+      where+        mapM' g = foldr (app . app (ret (:)) . g) (ret [])++composOp1 :: Compos1 t => (t -> t) -> t -> t+composOp1 f = runIdentity . composOpM1 (Identity . f)+composOpM1 :: (Compos1 t, Monad m) => (t -> m t) -> t -> m t+composOpM1 = compos1 return ap+composOpM1_ :: (Compos1 t, Monad m) => (t -> m ()) -> t -> m ()+composOpM1_ = composOpFold1 (return ()) (>>)+composOpFold1 :: Compos1 t => b -> (b -> b -> b) -> (t -> b) -> t -> b+composOpFold1 z c f = unC . compos1 (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)+newtype C b a = C { unC :: b }+ -- Basic Types and TMonad data StoreVal = SVType JType               | SVConstrained (Set Constraint)@@ -74,6 +102,7 @@         "frozen: " ++ show frozen ++ "\n" ++         "varCt: " ++ show varCt +tcStateEmpty :: TCState tcStateEmpty = TCS [M.empty] M.empty [S.empty] S.empty 0 []  newtype TMonad a = TMonad (ErrorT String (State TCState) a) deriving (Functor, Monad, MonadState TCState, MonadError String)@@ -85,8 +114,10 @@ class JTypeCheck a where     typecheck :: a -> TMonad JType +evalTMonad :: TMonad a -> Either String a evalTMonad (TMonad x) = evalState (runErrorT x) tcStateEmpty +runTMonad :: TMonad a -> (Either String a, TCState) runTMonad (TMonad x) = runState (runErrorT x) tcStateEmpty  withContext :: TMonad a -> TMonad String -> TMonad a@@ -109,7 +140,7 @@       go :: JType -> StateT (Map Int (Either String Int), Set String, Int) TMonad ()       go (JTFree vr) = handleVR vr       go (JTRigid vr cs) = handleVR vr >> traversem_ (go . fromC) cs-      go v = composOpM_ go v+      go v = composOpM1_ go v        handleVR (mbName, ref) = do         (m,ns,ct) <- get@@ -129,6 +160,7 @@         let n' = mkUnique ns n 0         put (M.insert ref (Left n') m, S.insert n' ns, ct) +      mkUnique :: Set String -> String -> Int -> String       mkUnique ns n i           | n' `S.member` ns = mkUnique ns n (i + 1)           | otherwise = n'@@ -145,12 +177,14 @@                     where (q,r) = divMod i 26                           letter = toEnum (fromEnum 'a' + r) ++prettyType :: JType -> TMonad String prettyType x = do   xt <- resolveType x   names <- freeVarsWithNames xt   let replaceNames (JTFree ref) = JTFree $ fixRef ref       replaceNames (JTForall refs t) = JTForall (map fixRef refs) $ replaceNames t-      replaceNames v = composOp replaceNames v+      replaceNames v = composOp1 replaceNames v        fixRef (_,ref) = (M.lookup ref names, ref) @@ -190,20 +224,25 @@ prettyEnv :: TMonad [Map Ident String] prettyEnv = mapM (T.mapM prettyType) . tc_env =<< get +runTypecheckRaw :: JTypeCheck a => a -> (Either String JType, TCState) runTypecheckRaw x = runTMonad (typecheckMain x) +runTypecheckFull :: JTypeCheck a => a -> (Either String (String, [Map Ident String]), TCState) runTypecheckFull x = runTMonad $ do                        r <- prettyType =<< typecheckMain x                        e <- prettyEnv                        return (r,e) +runTypecheck :: JTypeCheck a => a -> Either String String runTypecheck x = evalTMonad $ prettyType =<< typecheckMain x +evalTypecheck :: JTypeCheck a => a -> Either String [Map Ident String] evalTypecheck x = evalTMonad $ do                     _ <- typecheckMain x                     e <- prettyEnv                     return e +typecheckMain :: JTypeCheck a => a -> TMonad JType typecheckMain x = go `catchError` handler     where go = do             r <- typecheck x@@ -216,6 +255,7 @@  -- Manipulating VarRefs and Constraints +addToStack :: Ord a => a -> [Set a] -> [Set a] addToStack v (s:ss) = S.insert v s : ss addToStack _ _ = error "addToStack: no sets" --[S.singleton v] @@ -233,6 +273,7 @@ mapConstraint f (Sub t) = Sub <$> f t mapConstraint f (Super t) = Super <$> f t +partitionCs :: [Constraint] -> ([JType],[JType]) partitionCs [] = ([],[]) partitionCs (Sub t:cs) = (t:subs,sups)     where (subs,sups) = partitionCs cs@@ -273,7 +314,7 @@ occursCheck :: Int -> JType -> TMonad () occursCheck ref (JTFree (_,i))   | i == ref = tyErr1 "Occurs check: cannot construct infinite type" (JTFree (Nothing,i))-occursCheck ref x = composOpM_ (occursCheck ref) x+occursCheck ref x = composOpM1_ (occursCheck ref) x  checkConstraints :: JType -> [Constraint] -> TMonad () checkConstraints t cs = mapM_ go cs@@ -408,6 +449,7 @@       normalizeConstraints cl = putCs =<< cannonicalizeConstraints cl  +cannonicalizeConstraints :: [Constraint] -> TMonad [Constraint] cannonicalizeConstraints constraintList = do         -- trace ("ccl: " ++ show constraintList) $ return ()         let (subs,restCs)  = findForallSubs constraintList@@ -535,6 +577,7 @@        unifyGroup :: [Int] -> ReaderT [Either Int Int] TMonad ()       unifyGroup (vr:vrs) = lift $ mapM_ (\x -> instantiateVarRef (Nothing, x) (JTFree (Nothing,vr))) vrs+      unifyGroup [] = return ()        findLoop i cs@(c:_) = go [] cs           where@@ -574,6 +617,7 @@  -- addRefsToStack x = modify (\s -> s {tc_stack = F.foldr addToStack (tc_stack s) x }) +frame2VarRefs :: Set t -> [(Maybe a, t)] frame2VarRefs frame = (\x -> (Nothing,x)) <$> S.toList frame  addEnv :: Ident -> JType -> TMonad ()@@ -616,7 +660,7 @@           Just (SVType t) -> return Nothing           _ -> return $ Just x -resolveType = resolveTypeGen composOpM+resolveType = resolveTypeGen composOpM1 resolveTypeShallow = resolveTypeGen (const return)  --TODO create proper bounds for records@@ -643,7 +687,7 @@           (Super t) -> lift . (<: newTy) =<< cloneType t        cloneType (JTFree vr) = getRef vr-      cloneType x = composOpM cloneType x+      cloneType x = composOpM1 cloneType x  lookupEnv :: Ident -> TMonad JType lookupEnv ident = resolveType =<< go . tc_env =<< get@@ -656,7 +700,7 @@ freeVars :: JType -> TMonad (Set Int) freeVars t = execWriterT . go =<< resolveType t     where go (JTFree (_, ref)) = tell (S.singleton ref)-          go x = composOpM_ go x+          go x = composOpM1_ go x  --only works on resolved types instantiateScheme :: [VarRef] -> JType -> TMonad JType@@ -674,7 +718,7 @@                            put $ M.insert ref (JTFree newRef) m                            mapM_ (lift . addConstraint newRef <=< mapConstraint go) =<< lift (lookupConstraintsList vr)                            return (JTFree newRef)-      go x = composOpM go x+      go x = composOpM1 go x  --only works on resolved types instantiateRigidScheme :: [VarRef] -> JType -> TMonad JType@@ -691,7 +735,7 @@                            newRef <- JTRigid vr . S.fromList <$> lift (lookupConstraintsList vr)                            put $ M.insert ref newRef m                            return newRef-      go x = composOpM go x+      go x = composOpM1 go x  --only works on resolved types checkEscapedVars :: [VarRef] -> JType -> TMonad ()@@ -701,7 +745,7 @@       go t@(JTRigid (_,ref) _)           | ref `S.member` vs = tyErr1 "Qualified var escapes into environment" t           | otherwise = return ()-      go x = composOpM_ go x+      go x = composOpM1_ go x  -- Subtyping (<:) :: JType -> JType -> TMonad ()@@ -751,6 +795,7 @@         | M.isSubmapOfBy (\_ _ -> True) ym xm = xt <: yt >> intersectionWithM (<:) xm ym >> return () --TODO not right?     go xt yt = tyErr2Sub xt yt +(<<:>) :: TMonad JType -> TMonad JType -> TMonad () x <<:> y = join $ liftA2 (<:) x y  someUpperBound :: [JType] -> TMonad JType@@ -769,6 +814,7 @@ --  b <- (mapM_ (res <:) xs >> return True) `catchError` \e -> return False --  if b then return res else return JTImpossible +(=.=) :: JType -> JType -> TMonad JType x =.= y = do       x <: y       y <: x@@ -798,7 +844,7 @@         | s `elem` ["==","/="] = do                             et <- typecheck e                             e1t <- typecheck e1-                            et =.= e1t+                            _ <- et =.= e1t                             return JTBool         | s `elem` ["||","&&"] = setFixed JTBool >> return JTBool         | otherwise = throwError $ "Unhandled operator: " ++ s@@ -859,7 +905,7 @@     typecheck (JInt _) = return JTNum     typecheck (JDouble _) = return JTNum     typecheck (JStr _) = return JTString-    typecheck (JList xs) = typecheck (JHash $ M.fromList $ zip (map show [0..]) xs)+    typecheck (JList xs) = typecheck (JHash $ M.fromList $ zip (map show [(0::Int)..]) xs)                            -- fmap JTList . someUpperBound =<< mapM typecheck xs     typecheck (JRegEx _) = undefined --regex object     typecheck (JHash mp) = do@@ -889,7 +935,7 @@     typecheck (IfStat e s s1) = do                             typecheck e <<:> return JTBool                             join $ liftA2 (\x y -> someUpperBound [x,y]) (typecheck s) (typecheck s1)-    typecheck (WhileStat e s) = do+    typecheck (WhileStat _ e s) = do                             typecheck e <<:> return JTBool                             typecheck s     typecheck (ForInStat _ _ _ _) = undefined -- yipe!@@ -909,7 +955,8 @@       return JTStat     typecheck (UnsatBlock _) = undefined --oyvey     typecheck (AntiStat _) = undefined --oyvey-    typecheck BreakStat = return JTStat+    typecheck (BreakStat _) = return JTStat     typecheck (ForeignStat i t) = integrateLocalType t >>= addEnv i >> return JTStat -typecheckWithBlock stat = typecheck stat `withContext` (return $ "In statement: " ++ renderStyle (style {mode = OneLineMode}) (renderJs stat))+typecheckWithBlock :: (JsToDoc a, JMacro a, JTypeCheck a) => a -> TMonad JType+typecheckWithBlock stat = typecheck stat `withContext` (return $ "In statement: " ++ (T.unpack . displayT . renderCompact $ renderJs stat))

@@ -48,6 +48,8 @@  type TypeParserState = (Int, Map String Int) +type TypeParser a = CharParser TypeParserState a+ typLang :: P.LanguageDef TypeParserState typLang = emptyDef {            P.reservedNames = ["()","->"],@@ -56,18 +58,17 @@            P.identStart  = letter <|> oneOf "_$"           } +lexer :: P.TokenParser TypeParserState lexer = P.makeTokenParser typLang -whiteSpace= P.whiteSpace lexer-symbol    = P.symbol lexer+reservedOp :: String -> TypeParser ()+parens, braces, brackets, lexeme :: TypeParser a -> TypeParser a+identifier :: TypeParser String+commaSep, commaSep1 :: TypeParser a -> TypeParser [a] parens    = P.parens lexer braces    = P.braces lexer brackets  = P.brackets lexer-dot       = P.dot lexer-colon     = P.colon lexer-semi      = P.semi lexer identifier= P.identifier lexer-reserved  = P.reserved lexer reservedOp= P.reservedOp lexer commaSep1 = P.commaSep1 lexer commaSep  = P.commaSep  lexer@@ -77,8 +78,10 @@ parseType :: String -> Either ParseError JType parseType s = runParser anyType (0,M.empty) "" s +parseConstrainedType :: String -> Either ParseError JLocalType parseConstrainedType s = runParser constrainedType (0,M.empty) "" s +runTypeParser :: CharParser a JLocalType runTypeParser = withLocalState (0,M.empty) (try (parens constrainedType) <|> constrainedType) -- anyType  withLocalState :: (Functor m, Monad m) => st -> ParsecT s st m a -> ParsecT s st' m a@@ -90,7 +93,6 @@                   go (Error e) = (Error e)  -type TypeParser a = CharParser TypeParserState a  constrainedType :: TypeParser JLocalType constrainedType = do@@ -115,9 +117,9 @@ funOrAtomType :: TypeParser JType funOrAtomType = do   r <- anyNestedType `sepBy1` (lexeme (string "->"))-  return $ case r of+  return $ case reverse r of     [x] -> x-    (x:xs) -> JTFunc (init r) (last r)+    (x:xs) -> JTFunc (reverse xs) x     _ -> error "funOrAtomType"  listType :: TypeParser JType@@ -126,6 +128,7 @@ anyNestedType :: TypeParser JType anyNestedType = nullType <|> parens anyType <|> atomicType <|> listType <|> recordType +nullType :: TypeParser JType nullType = reservedOp "()" >> return JTStat  atomicType :: TypeParser JType@@ -135,8 +138,8 @@     "Num" -> return JTNum     "String" -> return JTString     "Bool" -> return JTBool-    (x:xs) | isUpper x -> fail $ "Unknown type: " ++ a-           | otherwise -> JTFree <$> freeVarRef a+    (x:_) | isUpper x -> fail $ "Unknown type: " ++ a+          | otherwise -> JTFree <$> freeVarRef a     _ -> error "typeAtom"  recordType :: TypeParser JType

@@ -43,7 +43,7 @@ ifElse x y z = IfStat (toJExpr x) (toStat y) (toStat z)  while :: ToJExpr a => a -> JStat -> JStat-while x y = WhileStat (toJExpr x) y+while x y = WhileStat False (toJExpr x) y  return :: ToJExpr a => a -> JStat return x = ReturnStat (toJExpr x)

@@ -1,5 +1,5 @@ name:                jmacro-version:             0.5.8+version:             0.6.2 synopsis:            QuasiQuotation library for programmatic generation of Javascript code. description:         Javascript syntax, functional syntax, hygienic names, compile-time guarantees of syntactic correctness, limited typechecking. Additional documentation available at <http://www.haskell.org/haskellwiki/Jmacro> category:            Language@@ -11,24 +11,35 @@ Build-Type:          Simple Cabal-Version:       >= 1.6 - library-  build-depends:     base >= 4, base < 5, containers, pretty, safe >= 0.2, parsec > 3.0, template-haskell >= 2.3, mtl > 1.1 , haskell-src-exts, haskell-src-meta, bytestring >= 0.9, syb, json, regex-posix > 0.9+  build-depends:     base >= 4, base < 5, containers, wl-pprint-text, text, safe >= 0.2, parsec > 3.0, template-haskell >= 2.3, mtl > 1.1 , haskell-src-exts, haskell-src-meta, bytestring >= 0.9, syb, aeson >= 0.5 , regex-posix > 0.9, vector >= 0.8, unordered-containers >= 0.2    exposed-modules:   Language.Javascript.JMacro                      Language.Javascript.JMacro.Util                      Language.Javascript.JMacro.TypeCheck                      Language.Javascript.JMacro.Types                      Language.Javascript.JMacro.Prelude-                     Language.Javascript.JMacro.Rpc+                     -- Language.Javascript.JMacro.Rpc   other-modules:     Language.Javascript.JMacro.Base                      Language.Javascript.JMacro.QQ                      Language.Javascript.JMacro.ParseTH   ghc-options:       -Wall +flag benchmarks+  description: Build the benchmarks+  default: False+ executable jmacro   build-depends: parseargs   main-is: Language/Javascript/JMacro/Executable.hs++executable jmacro-bench+  main-is: Language/Javascript/JMacro/Benchmark.hs+  if flag(benchmarks)+    buildable: True+    build-depends: criterion+  else+    buildable: False  source-repository head   type:      darcs