diff --git a/Language/Javascript/JMacro.hs b/Language/Javascript/JMacro.hs --- a/Language/Javascript/JMacro.hs +++ b/Language/Javascript/JMacro.hs @@ -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. diff --git a/Language/Javascript/JMacro/Base.hs b/Language/Javascript/JMacro/Base.hs --- a/Language/Javascript/JMacro/Base.hs +++ b/Language/Javascript/JMacro/Base.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, OverloadedStrings, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables, GADTs #-} +{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances, OverlappingInstances, OverloadedStrings, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables, GADTs + , GeneralizedNewtypeDeriving, LambdaCase #-} ----------------------------------------------------------------------------- {- | @@ -14,7 +15,7 @@ module Language.Javascript.JMacro.Base ( -- * ADT - JStat(..), JExpr(..), JVal(..), Ident(..), IdentSupply(..), + JStat(..), JExpr(..), JVal(..), Ident(..), IdentSupply(..), JsLabel, -- * Generic traversal (via compos) JMacro(..), JMGadt(..), Compos(..), composOp, composOpM, composOpM_, composOpFold, @@ -32,11 +33,12 @@ -- * 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 ((***)) +import Control.Monad (ap, return, liftM2) import Control.Monad.State.Strict import Control.Monad.Identity @@ -47,12 +49,18 @@ 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 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 @@ -85,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") @@ -134,12 +144,16 @@ 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 @@ -160,7 +174,7 @@ -- | Values data JVal = JVar Ident | JList [JExpr] - | JDouble Double + | JDouble SaneDouble | JInt Integer | JStr String | JRegEx String @@ -169,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) @@ -208,14 +235,14 @@ jtoGADT = JMGStat jfromGADT (JMGStat x) = x jfromGADT _ = error "impossible" - + instance JMacro JExpr where jtoGADT = JMGExpr jfromGADT (JMGExpr x) = x jfromGADT _ = error "impossible" instance JMacro JVal where - jtoGADT = JMGVal + jtoGADT = JMGVal jfromGADT (JMGVal x) = x jfromGADT _ = error "impossible" @@ -245,7 +272,7 @@ compos = jmcompos 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 = +jmcompos ret app f' v = case v of JMGId _ -> ret v JMGStat v' -> ret JMGStat `app` case v' of @@ -340,7 +367,7 @@ jsSaturate_ :: (JMacro a) => a -> IdentSupply a jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where + where go :: forall a. JMGadt a -> State [Ident] (JMGadt a) go v = case v of JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) @@ -355,8 +382,8 @@ --doesn't apply to unsaturated bits jsReplace_ :: JMacro a => [(Ident, Ident)] -> a -> a jsReplace_ xs e = jfromGADT $ go (jtoGADT e) - where - go :: forall a. JMGadt a -> JMGadt a + 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 @@ -372,20 +399,34 @@ -- | 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 = 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 = jtoGADT x +-- 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 (jfromGADT <$> go (jtoGADT x)) (newIdentSupply Nothing) @@ -397,25 +438,28 @@ 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)] + _ -> 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 (:) - (JMGStat (ForInStat b (StrI i) e s)) -> do - (newI:st) <- get - put st - 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 <- 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 + (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 @@ -522,7 +566,7 @@ instance JsToDoc JVal where jsToDoc (JVar i) = jsToDoc i jsToDoc (JList xs) = brackets . fillSep . punctuate comma $ map jsToDoc xs - jsToDoc (JDouble d) = double d + jsToDoc (JDouble (SaneDouble d)) = double d jsToDoc (JInt i) = integer i jsToDoc (JStr s) = text . T.pack $ "\""++encodeJson s++"\"" jsToDoc (JRegEx s) = text . T.pack $ "/"++s++"/" @@ -615,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 @@ -628,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] @@ -759,7 +810,11 @@ 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 ------------------------- @@ -784,4 +839,3 @@ | c < '\x1000' = '\\' : 'u' : '0' : hexxs where hexxs = showHex (fromEnum c) "" -- FIXME encodeJsonChar c = [c] - diff --git a/Language/Javascript/JMacro/Prelude.hs b/Language/Javascript/JMacro/Prelude.hs --- a/Language/Javascript/JMacro/Prelude.hs +++ b/Language/Javascript/JMacro/Prelude.hs @@ -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"; diff --git a/Language/Javascript/JMacro/QQ.hs b/Language/Javascript/JMacro/QQ.hs --- a/Language/Javascript/JMacro/QQ.hs +++ b/Language/Javascript/JMacro/QQ.hs @@ -12,10 +12,11 @@ -} ----------------------------------------------------------------------------- -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 Data.Char(digitToInt, toLower, isUpper) import Data.List(isPrefixOf, sort) @@ -105,12 +106,13 @@ 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 @@ -235,9 +237,13 @@ 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 "_$!"} @@ -258,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 @@ -398,6 +404,7 @@ <|> breakStat <|> continueStat <|> antiStat + <|> antiStatSimple "statement" where declStat = do @@ -429,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" @@ -504,8 +511,8 @@ b <- statement return $ jFor' before after p b where threeStat = - liftM3 (,,) (option [] statement <* optional semi) - (optionMaybe expr <* semi) + 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'] @@ -516,6 +523,7 @@ (e1,op) <- try $ liftM2 (,) dotExpr (fmap (take 1) $ rop "=" <|> rop "+=" + <|> rop "-=" <|> rop "*=" <|> rop "/=" <|> rop "%=" @@ -526,10 +534,10 @@ <|> 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 () @@ -564,7 +572,7 @@ labelStat = do lbl <- try $ do - l <- myIdent <* char ':' + l <- myIdent <<* char ':' guard (l /= "default") return l s <- l2s <$> statblock0 @@ -576,6 +584,12 @@ (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 @@ -642,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) @@ -667,6 +681,12 @@ (const (return x)) (parseHSExp x) + 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 str = JStr <$> (myStringLiteral '"' <|> myStringLiteral '\'') @@ -686,19 +706,19 @@ 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 '\'' diff --git a/Language/Javascript/JMacro/TypeCheck.hs b/Language/Javascript/JMacro/TypeCheck.hs --- a/Language/Javascript/JMacro/TypeCheck.hs +++ b/Language/Javascript/JMacro/TypeCheck.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards, RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards, RankNTypes, FlexibleContexts #-} module Language.Javascript.JMacro.TypeCheck where @@ -11,7 +11,7 @@ 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) @@ -28,9 +28,9 @@ -- Utility -isLeft :: Either a b -> Bool -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' @@ -105,7 +105,7 @@ 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 @@ -115,10 +115,10 @@ typecheck :: a -> TMonad JType evalTMonad :: TMonad a -> Either String a -evalTMonad (TMonad x) = evalState (runErrorT x) tcStateEmpty +evalTMonad (TMonad x) = evalState (runExceptT x) tcStateEmpty runTMonad :: TMonad a -> (Either String a, TCState) -runTMonad (TMonad x) = runState (runErrorT x) tcStateEmpty +runTMonad (TMonad x) = runState (runExceptT x) tcStateEmpty withContext :: TMonad a -> TMonad String -> TMonad a withContext act cxt = do @@ -581,13 +581,13 @@ 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 @@ -884,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) diff --git a/jmacro.cabal b/jmacro.cabal --- a/jmacro.cabal +++ b/jmacro.cabal @@ -1,5 +1,5 @@ name: jmacro -version: 0.6.3 +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 category: Language @@ -7,19 +7,34 @@ 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, 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 + 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 @@ -30,17 +45,54 @@ 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