jmacro 0.5.8 → 0.6.18
raw patch · 11 files changed
Files
- Language/Javascript/JMacro.hs +12/−12
- Language/Javascript/JMacro/Base.hs +258/−179
- Language/Javascript/JMacro/Benchmark.hs +11/−0
- Language/Javascript/JMacro/Executable.hs +10/−5
- Language/Javascript/JMacro/Prelude.hs +2/−1
- Language/Javascript/JMacro/QQ.hs +114/−57
- Language/Javascript/JMacro/Rpc.hs +0/−122
- Language/Javascript/JMacro/TypeCheck.hs +77/−30
- Language/Javascript/JMacro/Types.hs +14/−11
- Language/Javascript/JMacro/Util.hs +1/−1
- jmacro.cabal +73/−10
Language/Javascript/JMacro.hs view
@@ -14,53 +14,53 @@ usage: -> renderJs [$jmacro|fun id x -> x|]+> renderJs [jmacro|fun id x -> x|] The above produces the id function at the top level. -> renderJs [$jmacro|var id = \x -> x|]+> renderJs [jmacro|var id = \x -> x;|] So does the above here. However, as id is brought into scope by the keyword var, you do not get a variable named id in the generated javascript, but a variable with an arbitrary unique identifier. -> renderJs [$jmacro|var !id = \x -> x|]+> renderJs [jmacro|var !id = \x -> x;|] The above, by using the bang special form in a var declaration, produces a variable that really is named id. -> renderJs [$jmacro|function id(x) {return x;}|]+> renderJs [jmacro|function id(x) {return x;}|] The above is also id. -> renderJs [$jmacro|function !id(x) {return x;}|]+> renderJs [jmacro|function !id(x) {return x;}|] As is the above (with the correct name). -> renderJs [$jmacro|fun id x {return x;}|]+> renderJs [jmacro|fun id x {return x;}|] As is the above. -> renderJs [$jmacroE|foo(x,y)|]+> renderJs [jmacroE|foo(x,y)|] The above is an expression representing the application of foo to x and y. -> renderJs [$jmacroE|foo x y|]]+> renderJs [jmacroE|foo x y|]] As is the above. -> renderJs [$jmacroE|foo (x,y)|]+> renderJs [jmacroE|foo (x,y)|] While the above is an error. (i.e. standard javascript function application cannot seperate the leading parenthesis of the argument from the function being applied) -> \x -> [$jmacroE|foo `(x)`|]+> \x -> [jmacroE|foo `(x)`|] The above is a haskell expression that provides a function that takes an x, and yields an expression representing the application of foo to the value of x as transformed to a Javascript expression. -> [$jmacroE|\x ->`(foo x)`|]+> [jmacroE|\x ->`(foo x)`|] Meanwhile, the above lambda is in Javascript, and brings the variable into scope both in javascript and in the enclosed antiquotes. The expression is a Javascript function that takes an x, and yields an expression produced by the application of the Haskell function foo as applied to the identifier x (which is of type JExpr -- i.e. a Javascript expression). Other than that, the language is essentially Javascript (1.5). Note however that one must use semicolons in a principled fashion -- i.e. to end statements consistently. Otherwise, the parser will mistake the whitespace for a whitespace application, and odd things will occur. A further gotcha exists in regex literals, whicch cannot begin with a space. @x / 5 / 4@ parses as ((x / 5) / 4). However, @x /5 / 4@ will parse as x(/5 /, 4). Such are the perils of operators used as delimeters in the presence of whitespace application. -Additional features in jmacro (documented on the wiki) include an infix application operator, and an enhanced destructuring bind. +Additional features in jmacro (documented on the wiki) include an infix application operator, and an enhanced destructuring bind. Additional datatypes can be marshalled to Javascript by proper instance declarations for the ToJExpr class.
Language/Javascript/JMacro/Base.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables #-}+{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances, OverlappingInstances, OverloadedStrings, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables, GADTs+ , GeneralizedNewtypeDeriving, LambdaCase #-} ----------------------------------------------------------------------------- {- |@@ -14,9 +15,9 @@ module Language.Javascript.JMacro.Base ( -- * ADT- JStat(..), JExpr(..), JVal(..), Ident(..), IdentSupply(..),+ JStat(..), JExpr(..), JVal(..), Ident(..), IdentSupply(..), JsLabel, -- * Generic traversal (via compos)- JMacro(..), MultiComp(..), Compos(..),+ JMacro(..), JMGadt(..), Compos(..), composOp, composOpM, composOpM_, composOpFold, -- * Hygienic transformation withHygiene, scopify,@@ -32,35 +33,54 @@ -- * Hash combinators jhEmpty, jhSingle, jhAdd, jhFromList, -- * Utility- jsSaturate, jtFromList+ jsSaturate, jtFromList, SaneDouble(..) ) 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 (ap, return, liftM2) 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 Data.Semigroup(Semigroup(..)) import Numeric(showHex) import Safe-import Text.JSON-import Text.PrettyPrint.HughesPJ as PP+import Data.Aeson+import qualified Data.Vector as V+#if MIN_VERSION_aeson (2,0,0)+import qualified Data.Aeson.Key as KM+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as HM+#endif+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@@ -73,9 +93,11 @@ takeOne :: State [Ident] Ident takeOne = do- (x:xs) <- get- put xs- return x+ get >>= \case+ (x:xs) -> do+ put xs+ return x+ _ -> error "not enough elements" newIdentSupply :: Maybe String -> [Ident] newIdentSupply Nothing = newIdentSupply (Just "jmId")@@ -103,8 +125,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,16 +136,24 @@ | 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 Semigroup JStat where+ (<>) (BlockStat xs) (BlockStat ys) = BlockStat $ xs ++ ys+ (<>) (BlockStat xs) ys = BlockStat $ xs ++ [ys]+ (<>) xs (BlockStat ys) = BlockStat $ xs : ys+ (<>) xs ys = BlockStat [xs,ys]++ instance Monoid JStat where mempty = BlockStat []- mappend (BlockStat xs) (BlockStat ys) = BlockStat $ xs ++ ys- mappend (BlockStat xs) ys = BlockStat $ xs ++ [ys]- mappend xs (BlockStat ys) = BlockStat $ xs : ys- mappend xs ys = BlockStat [xs,ys]+ mappend x y = x <> y -- TODO: annotate expressions with type@@ -144,7 +174,7 @@ -- | Values data JVal = JVar Ident | JList [JExpr]- | JDouble Double+ | JDouble SaneDouble | JInt Integer | JStr String | JRegEx String@@ -153,6 +183,19 @@ | UnsatVal (IdentSupply JVal) deriving (Eq, Ord, Show, Data, Typeable) +newtype SaneDouble = SaneDouble Double deriving (Data, Typeable, Fractional, Num)++instance Eq SaneDouble where+ (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)++instance Ord SaneDouble where+ compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)+ where fromNaN z | isNaN z = Nothing+ | otherwise = Just z++instance Show SaneDouble where+ show (SaneDouble x) = show x+ -- | Identifiers newtype Ident = StrI String deriving (Eq, Ord, Show, Data, Typeable) @@ -175,70 +218,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" --- | 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 JExpr where+ jtoGADT = JMGExpr+ jfromGADT (JMGExpr x) = x+ jfromGADT _ = error "impossible" +instance JMacro JVal where+ jtoGADT = JMGVal+ jfromGADT (JMGVal x) = x+ jfromGADT _ = error "impossible" -composOp :: Compos t => (t -> t) -> t -> t+-- | 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 => (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 +291,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 +306,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 +318,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 +366,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 +381,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@@ -365,60 +399,73 @@ -- | Apply a transformation to a fully saturated syntax tree, -- taking care to return any free variables back to their free state -- 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- 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--+-- free variables, it is hygienic.+withHygiene :: JMacro a => (a -> a) -> a -> a+withHygiene f x = jfromGADT $ case jtoGADT x of+ JMGExpr z -> JMGExpr $ UnsatExpr $ inScope z+ JMGStat z -> JMGStat $ UnsatBlock $ inScope z+ JMGVal z -> JMGVal $ UnsatVal $ inScope z+ JMGId _ -> jtoGADT $ f x+ where+ inScope z = IS $ do+ splitAt 1 `fmap` get >>= \case+ ([StrI a], b) -> do+ put b+ return $ withHygiene_ a f z+ _ -> error "Not as string" +withHygiene_ :: JMacro a => String -> (a -> a) -> a -> a+withHygiene_ un f x = jfromGADT $ case jtoGADT x 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+ is' = take lastVal is+ x'' = f x'+ lastVal = readNote ("inSat" ++ un) (reverse . takeWhile (/= '_') . reverse $ l) :: Int+ is = newIdentSupply $ Just ("inSat" ++ un) -- | 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 ('!':'!':i') -> (DeclStat (StrI i') t:) <$> blocks xs ('!':i') -> (DeclStat (StrI i') t:) <$> blocks xs- _ -> do- (newI:st) <- get- 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+ _ -> get >>= \case+ (newI:st) -> do+ put st+ rest <- blocks xs+ return $ [DeclStat newI t `mappend` jsReplace_ [(StrI i, newI)] (BlockStat rest)]+ _ -> error "scopify"+ blocks (x':xs) = (jfromGADT <$> go (jtoGADT x')) <:> blocks xs (<:>) = liftM2 (:)- (MStat (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- (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+ (JMGStat (ForInStat b (StrI i) e s)) -> get >>= \case+ (newI:st) -> do+ put st+ rest <- jfromGADT <$> go (jtoGADT s)+ return $ JMGStat . ForInStat b newI e $ jsReplace_ [(StrI i, newI)] rest+ _ -> error "scopify2"+ (JMGStat (TryStat s (StrI i) s1 s2)) -> get >>= \case+ (newI:st) -> do+ put st+ 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+ _ -> error "scopify3"+ (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 +483,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 +499,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 +528,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 (JDouble d) = double d+ jsToDoc (JList xs) = brackets . fillSep . punctuate comma $ map jsToDoc xs+ jsToDoc (JDouble (SaneDouble 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 +591,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 +610,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@@ -591,7 +659,7 @@ toJExpr = ValExpr . JHash . M.map toJExpr instance ToJExpr Double where- toJExpr = ValExpr . JDouble+ toJExpr = ValExpr . JDouble . SaneDouble instance ToJExpr Int where toJExpr = ValExpr . JInt . fromIntegral@@ -604,6 +672,13 @@ toJExprFromList = ValExpr . JStr -- where escQuotes = tailDef "" . initDef "" . show +instance ToJExpr TS.Text where+ toJExpr t = toJExpr (TS.unpack t)++instance ToJExpr T.Text where+ toJExpr t = toJExpr (T.unpack t)++ instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] @@ -705,7 +780,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 +803,24 @@ 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+#if MIN_VERSION_aeson (2,0,0)+ toJExpr (Object obj) = ValExpr $ JHash $ M.fromList $ map (KM.toString *** toJExpr) $ KM.toList obj+#else+ toJExpr (Object obj) = ValExpr $ JHash $ M.fromList $ map (TS.unpack *** toJExpr) $ HM.toList obj+#endif ------------------------- -- Taken from json package by Sigbjorn Finne.++encodeJson :: String -> String encodeJson = concatMap encodeJsonChar encodeJsonChar :: Char -> String@@ -759,4 +839,3 @@ | c < '\x1000' = '\\' : 'u' : '0' : hexxs where hexxs = showHex (fromEnum c) "" -- FIXME encodeJsonChar c = [c]-
+ Language/Javascript/JMacro/Benchmark.hs view
@@ -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
Language/Javascript/JMacro/Executable.hs view
@@ -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
Language/Javascript/JMacro/Prelude.hs view
@@ -12,10 +12,11 @@ import Language.Javascript.JMacro.Base import Language.Javascript.JMacro.QQ + -- | This provides a set of basic functional programming primitives, a few utility functions -- and, more importantly, a decent sample of idiomatic jmacro code. View the source for details. jmPrelude :: JStat-jmPrelude = [$jmacro|+jmPrelude = [jmacro| fun withHourglass f { document.body.style.cursor="wait";
Language/Javascript/JMacro/QQ.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes, RankNTypes, GADTs #-} ----------------------------------------------------------------------------- {- |@@ -12,12 +12,12 @@ -} ----------------------------------------------------------------------------- -module Language.Javascript.JMacro.QQ(jmacro,jmacroE,parseJM) where+module Language.Javascript.JMacro.QQ(jmacro,jmacroE,parseJM,parseJME) where import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)-import Control.Applicative hiding ((<|>),many,optional,(<*))+import Control.Applicative hiding ((<|>),many,optional) import Control.Arrow(first)+import Control.Monad (ap, return, liftM2, liftM3, when, mzero, guard) 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 +46,7 @@ import System.IO.Unsafe import Numeric(readHex) --- import Web.Encodings----import Debug.Trace+-- import Debug.Trace {-------------------------------------------------------------------- QuasiQuotation@@ -96,23 +94,25 @@ -- 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 antiIdents ss x = foldr antiIdent x ss fixIdent :: String -> String+fixIdent "_" = "_x_" fixIdent css@(c:_) | isUpper c = '_' : escapeDollar css | otherwise = escapeDollar css where escapeDollar = map (\x -> if x =='$' then 'dž' else x)-fixIdent _ = "_"+fixIdent _ = "_x_" jm2th :: Data a => a -> TH.ExpQ@@ -233,13 +233,17 @@ 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.opStart = oneOf "|+-/*%<>&^.?=!~:@",+ P.opLetter = oneOf "|+-/*%<>&^.?=!~:@", P.commentLine = "//", P.commentStart = "/*",- P.commentEnd = "*/"}+ P.commentEnd = "*/",+ P.caseSensitive = True+ } identifierWithBang = P.identifier $ P.makeTokenParser $ jsLang {P.identStart = letter <|> oneOf "_$!"} @@ -260,8 +264,8 @@ lexeme :: JMParser a -> JMParser a lexeme = P.lexeme lexer -(<*) :: Monad m => m b -> m a -> m b-x <* y = do+(<<*) :: Monad m => m b -> m a -> m b+x <<* y = do xr <- x _ <- y return xr@@ -357,6 +361,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,16 +391,20 @@ <|> functionDecl <|> foreignStat <|> returnStat+ <|> labelStat <|> ifStat <|> whileStat <|> switchStat <|> forStat+ <|> doWhileStat <|> braces statblock <|> assignOpStat <|> tryStat <|> applStat <|> breakStat+ <|> continueStat <|> antiStat+ <|> antiStatSimple <?> "statement" where declStat = do@@ -427,12 +436,12 @@ foreignStat = do reserved "foreign"- i <- try $ identdecl <* reservedOp "::"+ i <- try $ identdecl <<* reservedOp "::" t <- runTypeParser return [ForeignStat i t] returnStat =- reserved "return" >> (:[]) . ReturnStat <$> option (ValExpr $ JVar $ StrI "null") expr+ reserved "return" >> (:[]) . ReturnStat <$> option (ValExpr $ JVar $ StrI "undefined") expr ifStat = do reserved "if"@@ -447,9 +456,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 +469,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 +511,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@@ -511,14 +523,21 @@ (e1,op) <- try $ liftM2 (,) dotExpr (fmap (take 1) $ rop "=" <|> rop "+="+ <|> rop "-=" <|> rop "*=" <|> rop "/=" <|> rop "%="+ <|> rop "<<="+ <|> rop ">>="+ <|> rop ">>>="+ <|> rop "&="+ <|> rop "^="+ <|> rop "|=" )- let gofail = fail ("Invalid assignment.")+ let gofail = fail ("Invalid assignment.")+ badList = ["this","true","false","undefined","null"] case e1 of- ValExpr (JVar (StrI "this")) -> gofail- ValExpr (JVar _) -> return ()+ ValExpr (JVar (StrI s)) -> if s `elem` badList then gofail else return () ApplExpr _ _ -> gofail ValExpr _ -> gofail _ -> return ()@@ -541,17 +560,40 @@ 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" ++)) (const (return x)) (parseHSExp x) + antiStatSimple = return . AntiStat <$> do+ x <- (symbol "`" >> anyChar `manyTill` symbol "`")+ either (fail . ("Bad AntiQuotation: \n" ++))+ (const (return x))+ (parseHSExp x)+ --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,23 +619,33 @@ let ans = (IfExpr e t el) addIf ans <|> return ans rawExpr = buildExpressionParser table dotExpr <?> "expression"- table = [[iop "*", iop "/", iop "%"],+ table = [[pop "~", pop "!", negop],+ [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"))+ negop = Prefix (reservedOp "-" >> return negexp)+ negexp (ValExpr (JDouble n)) = ValExpr (JDouble (-n))+ negexp (ValExpr (JInt n)) = ValExpr (JInt (-n))+ negexp x = PPostExpr True "-" x dotExpr :: JMParser JExpr dotExpr = do@@ -604,7 +656,7 @@ _ -> error "exprApp" dotExprOne :: JMParser JExpr-dotExprOne = addNxt =<< valExpr <|> antiExpr <|> parens' expr <|> notExpr <|> newExpr+dotExprOne = addNxt =<< valExpr <|> antiExpr <|> antiExprSimple <|> parens' expr <|> notExpr <|> newExpr where addNxt e = do nxt <- (Just <$> lookAhead anyChar <|> return Nothing)@@ -629,9 +681,14 @@ (const (return x)) (parseHSExp x) - valExpr = ValExpr <$> (num <|> negnum <|> str <|> try regex <|> list <|> hash <|> func <|> var) <?> "value"+ antiExprSimple = AntiExpr <$> do+ x <- (symbol "`" >> anyChar `manyTill` string "`")+ either (fail . ("Bad AntiQuotation: \n" ++))+ (const (return x))+ (parseHSExp x)++ valExpr = ValExpr <$> (num <|> str <|> try regex <|> list <|> hash <|> func <|> var) <?> "value" where num = either JInt JDouble <$> try natFloat- negnum = either (JInt . negate) (JDouble . negate) <$> try (char '-' >> natFloat) str = JStr <$> (myStringLiteral '"' <|> myStringLiteral '\'') regex = do s <- regexLiteral --myStringLiteralNoBr '/'@@ -649,22 +706,22 @@ statOrEblock = try (ReturnStat <$> expr `folBy` '}') <|> (l2s <$> statblock) propPair = liftM2 (,) myIdent (colon >> expr) ---notFolBy a b = a <* notFollowedBy (char b)+--notFolBy a b = a <<* notFollowedBy (char b) folBy :: JMParser a -> Char -> JMParser a-folBy a b = a <* (lookAhead (char b) >>= const (return ()))+folBy a b = a <<* (lookAhead (char b) >>= const (return ())) --Parsers without Lexeme braces', brackets', parens', oxfordBraces :: JMParser a -> JMParser a brackets' = around' '[' ']' braces' = around' '{' '}' parens' = around' '(' ')'-oxfordBraces x = lexeme (reservedOp "{|") >> (lexeme x <* reservedOp "|}")+oxfordBraces x = lexeme (reservedOp "{|") >> (lexeme x <<* reservedOp "|}") around' :: Char -> Char -> JMParser a -> JMParser a-around' a b x = lexeme (char a) >> (lexeme x <* char b)+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 +815,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]
− Language/Javascript/JMacro/Rpc.hs
@@ -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
Language/Javascript/JMacro/TypeCheck.hs view
@@ -1,36 +1,36 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards, RankNTypes, FlexibleContexts #-} 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 Control.Monad.Except 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 (Left _) = True-isLeft _ = False+eitherIsLeft :: Either a b -> Bool+eitherIsLeft (Left _) = True+eitherIsLeft _ = False partitionOut :: (a -> Maybe b) -> [a] -> ([b],[a]) partitionOut f xs' = foldr go ([],[]) xs'@@ -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,9 +102,10 @@ "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)+newtype TMonad a = TMonad (ExceptT String (State TCState) a) deriving (Functor, Monad, MonadState TCState, MonadError String) instance Applicative TMonad where pure = return@@ -85,9 +114,11 @@ class JTypeCheck a where typecheck :: a -> TMonad JType -evalTMonad (TMonad x) = evalState (runErrorT x) tcStateEmpty+evalTMonad :: TMonad a -> Either String a+evalTMonad (TMonad x) = evalState (runExceptT x) tcStateEmpty -runTMonad (TMonad x) = runState (runErrorT x) tcStateEmpty+runTMonad :: TMonad a -> (Either String a, TCState)+runTMonad (TMonad x) = runState (runExceptT x) tcStateEmpty withContext :: TMonad a -> TMonad String -> TMonad a withContext act cxt = do@@ -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,16 +577,17 @@ 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- cTyp = isLeft c+ cTyp = eitherIsLeft c go accum (r:rs)- | either id id r == i && isLeft r == cTyp = Just $ Just (either id id r : accum)+ | either id id r == i && eitherIsLeft r == cTyp = Just $ Just (either id id r : accum) -- i.e. there's a cycle to close | either id id r == i = Just Nothing -- i.e. there's a "dull" cycle- | isLeft r /= cTyp = Nothing -- we stop looking for a cycle because the chain is broken+ | eitherIsLeft r /= cTyp = Nothing -- we stop looking for a cycle because the chain is broken | otherwise = go (either id id r : accum) rs go _ [] = Nothing @@ -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@@ -838,7 +884,7 @@ typecheck (UnsatExpr _) = undefined --saturate (avoiding creation of existing ids) then typecheck- typecheck (AntiExpr s) = fail $ "Antiquoted expression not provided with explicit signature: " ++ show s+ typecheck (AntiExpr s) = error $ "Antiquoted expression not provided with explicit signature: " ++ show s --TODO: if we're typechecking a function, we can assign the types of the args to the given args typecheck (TypeExpr forceType e t)@@ -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))
Language/Javascript/JMacro/Types.hs view
@@ -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
Language/Javascript/JMacro/Util.hs view
@@ -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)
jmacro.cabal view
@@ -1,5 +1,5 @@ name: jmacro-version: 0.5.8+version: 0.6.18 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@@ -7,29 +7,92 @@ license-file: LICENSE author: Gershom Bazerman maintainer: gershomb@gmail.com-Tested-With: GHC == 7.0.2+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2, GHC==9.5.2, GHC==9.6.1 Build-Type: Simple-Cabal-Version: >= 1.6-+Cabal-Version: >= 1.10 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+ default-language: Haskell2010+ build-depends: aeson >= 0.5,+ base >= 4.9 && < 5,+ bytestring >= 0.9,+ containers,+ haskell-src-exts,+ haskell-src-meta,+ mtl > 2.2.1,+ parsec > 3.0,+ regex-posix > 0.9,+ safe >= 0.2,+ syb,+ template-haskell >= 2.3,+ text,+ unordered-containers >= 0.2,+ vector >= 0.8,+ wl-pprint-text 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 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+ default-language: Haskell2010+ build-depends: aeson >= 0.5,+ base >= 4 && < 5,+ bytestring >= 0.9,+ containers,+ haskell-src-exts,+ haskell-src-meta,+ mtl > 1.1 ,+ parseargs,+ parsec > 3.0,+ regex-posix > 0.9,+ safe >= 0.2,+ syb,+ template-haskell >= 2.3,+ text,+ unordered-containers >= 0.2,+ vector >= 0.8,+ wl-pprint-text + main-is: Language/Javascript/JMacro/Executable.hs+ other-modules: Language.Javascript.JMacro.Util+ Language.Javascript.JMacro.TypeCheck+ Language.Javascript.JMacro.Types+ Language.Javascript.JMacro.Prelude+ Language.Javascript.JMacro.Base+ Language.Javascript.JMacro.QQ+ Language.Javascript.JMacro.ParseTH+ Language.Javascript.JMacro+++executable jmacro-bench+ default-language: Haskell2010+ main-is: Language/Javascript/JMacro/Benchmark.hs+ if flag(benchmarks)+ buildable: True+ build-depends: criterion+ other-modules: Language.Javascript.JMacro.Util+ Language.Javascript.JMacro.TypeCheck+ Language.Javascript.JMacro.Types+ Language.Javascript.JMacro.Prelude+ Language.Javascript.JMacro.Base+ Language.Javascript.JMacro.QQ+ Language.Javascript.JMacro.ParseTH+ Language.Javascript.JMacro++ else+ buildable: False+ source-repository head- type: darcs- location: http://patch-tag.com/r/gershomb/jmacro+ type: git+ location: https://github.com/Happstack/jmacro.git