jmacro-0.6.8/0000755000000000000000000000000012155151001011155 5ustar0000000000000000jmacro-0.6.8/jmacro.cabal0000644000000000000000000000342212155151001013415 0ustar0000000000000000name: jmacro version: 0.6.8 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 license: BSD3 license-file: LICENSE author: Gershom Bazerman maintainer: gershomb@gmail.com Tested-With: GHC == 7.6.2 Build-Type: Simple Cabal-Version: >= 1.6 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 exposed-modules: Language.Javascript.JMacro Language.Javascript.JMacro.Util Language.Javascript.JMacro.TypeCheck Language.Javascript.JMacro.Types Language.Javascript.JMacro.Prelude other-modules: Language.Javascript.JMacro.Base Language.Javascript.JMacro.QQ Language.Javascript.JMacro.ParseTH ghc-options: -Wall flag benchmarks description: Build the benchmarks default: False executable jmacro build-depends: parseargs main-is: Language/Javascript/JMacro/Executable.hs executable jmacro-bench main-is: Language/Javascript/JMacro/Benchmark.hs if flag(benchmarks) buildable: True build-depends: criterion else buildable: False source-repository head type: darcs location: http://patch-tag.com/r/gershomb/jmacro jmacro-0.6.8/LICENSE0000644000000000000000000000270112155151001012162 0ustar0000000000000000Copyright (c) Gershom Bazerman 2009 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. jmacro-0.6.8/Setup.hs0000644000000000000000000000005612155151001012612 0ustar0000000000000000import Distribution.Simple main = defaultMain jmacro-0.6.8/Language/0000755000000000000000000000000012155151001012700 5ustar0000000000000000jmacro-0.6.8/Language/Javascript/0000755000000000000000000000000012155151001015006 5ustar0000000000000000jmacro-0.6.8/Language/Javascript/JMacro.hs0000644000000000000000000000672612155151001016530 0ustar0000000000000000{- | Module : Language.Javascript.JMacro Copyright : (c) Gershom Bazerman, 2010 License : BSD 3 Clause Maintainer : gershomb@gmail.com Stability : experimental Simple DSL for lightweight (untyped) programmatic generation of Javascript. A number of examples are available in the source of "Language.Javascript.JMacro.Prelude". Functions to generate generic RPC wrappers (using json serialization) are available in "Language.Javascript.JMacro.Rpc". usage: > renderJs [$jmacro|fun id x -> x|] The above produces the id function at the top level. > 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;|] 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;}|] The above is also id. > renderJs [$jmacro|function !id(x) {return x;}|] As is the above (with the correct name). > renderJs [$jmacro|fun id x {return x;}|] As is the above. > renderJs [$jmacroE|foo(x,y)|] The above is an expression representing the application of foo to x and y. > renderJs [$jmacroE|foo x y|]] As is the above. > 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)`|] 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)`|] 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 datatypes can be marshalled to Javascript by proper instance declarations for the ToJExpr class. An experimental typechecker is available in the "Language.Javascript.JMacro.Typed" module. -} module Language.Javascript.JMacro ( module Language.Javascript.JMacro.QQ, module Language.Javascript.JMacro.Base, module Language.Javascript.JMacro.Prelude, module Language.Javascript.JMacro.Types ) where {- import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) -} import Language.Javascript.JMacro.Base hiding (expr2stat) import Language.Javascript.JMacro.QQ import Language.Javascript.JMacro.Prelude import Language.Javascript.JMacro.Types (JType(..)) jmacro-0.6.8/Language/Javascript/JMacro/0000755000000000000000000000000012155151001016161 5ustar0000000000000000jmacro-0.6.8/Language/Javascript/JMacro/Base.hs0000644000000000000000000007616112155151001017402 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, OverloadedStrings, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables, GADTs, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- {- | Module : Language.Javascript.JMacro.Base Copyright : (c) Gershom Bazerman, 2009 License : BSD 3 Clause Maintainer : gershomb@gmail.com Stability : experimental Simple DSL for lightweight (untyped) programmatic generation of Javascript. -} ----------------------------------------------------------------------------- module Language.Javascript.JMacro.Base ( -- * ADT JStat(..), JExpr(..), JVal(..), Ident(..), IdentSupply(..), JsLabel, -- * Generic traversal (via compos) JMacro(..), JMGadt(..), Compos(..), composOp, composOpM, composOpM_, composOpFold, -- * Hygienic transformation withHygiene, scopify, -- * Display/Output renderJs, renderPrefixJs, JsToDoc(..), -- * Ad-hoc data marshalling ToJExpr(..), -- * Literals jsv, -- * Occasionally helpful combinators jLam, jVar, jVarTy, jFor, jForIn, jForEachIn, jTryCatchFinally, expr2stat, ToStat(..), nullStat, -- * Hash combinators jhEmpty, jhSingle, jhAdd, jhFromList, -- * Utility 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.State.Strict import Control.Monad.Identity import Data.Function import Data.Char (toLower,isControl) import qualified Data.Map as M import qualified Data.Text.Lazy as T import qualified Data.Text as TS import Data.Generics import Data.Monoid(Monoid, mappend, mempty) import Numeric(showHex) import Safe import Data.Aeson import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import Text.PrettyPrint.Leijen.Text hiding ((<$>)) import qualified Text.PrettyPrint.Leijen.Text as PP import Language.Javascript.JMacro.Types -- wl-pprint-text compatibility with pretty infixl 5 $$, $+$ ($+$), ($$), ($$$) :: Doc -> Doc -> Doc x $+$ y = x PP.<$> y x $$ y = align (x $+$ y) x $$$ y = align (nest 2 $ x $+$ y) {-------------------------------------------------------------------- ADTs --------------------------------------------------------------------} newtype IdentSupply a = IS {runIdentSupply :: State [Ident] a} deriving Typeable inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b inIdentSupply f x = IS $ f (runIdentSupply x) instance Data a => Data (IdentSupply a) where gunfold _ _ _ = error "gunfold IdentSupply" toConstr _ = error "toConstr IdentSupply" dataTypeOf _ = mkNoRepType "IdentSupply" instance Functor IdentSupply where fmap f x = inIdentSupply (fmap f) x takeOne :: State [Ident] Ident takeOne = do (x:xs) <- get put xs return x newIdentSupply :: Maybe String -> [Ident] newIdentSupply Nothing = newIdentSupply (Just "jmId") newIdentSupply (Just pfx') = [StrI (pfx ++ show x) | x <- [(0::Integer)..]] where pfx = pfx'++['_'] sat_ :: IdentSupply a -> a sat_ x = evalState (runIdentSupply x) $ newIdentSupply (Just "<>") instance Eq a => Eq (IdentSupply a) where (==) = (==) `on` sat_ instance Ord a => Ord (IdentSupply a) where compare = compare `on` sat_ instance Show a => Show (IdentSupply a) where show x = "(" ++ show (sat_ x) ++ ")" --switch --Yield statement? --destructuring/pattern matching functions --pattern matching in lambdas. --array comprehensions/generators? --add postfix stat -- | Statements data JStat = DeclStat Ident (Maybe JLocalType) | ReturnStat JExpr | IfStat JExpr JStat 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] | ApplStat JExpr [JExpr] | PPostStat Bool String JExpr | AssignStat JExpr JExpr | UnsatBlock (IdentSupply JStat) | AntiStat String | ForeignStat Ident JLocalType | LabelStat JsLabel JStat | BreakStat (Maybe JsLabel) | ContinueStat (Maybe JsLabel) deriving (Eq, Ord, Show, Data, Typeable) type JsLabel = String instance Monoid JStat where mempty = BlockStat [] mappend (BlockStat xs) (BlockStat ys) = BlockStat $ xs ++ ys mappend (BlockStat xs) ys = BlockStat $ xs ++ [ys] mappend xs (BlockStat ys) = BlockStat $ xs : ys mappend xs ys = BlockStat [xs,ys] -- TODO: annotate expressions with type -- | Expressions data JExpr = ValExpr JVal | SelExpr JExpr Ident | IdxExpr JExpr JExpr | InfixExpr String JExpr JExpr | PPostExpr Bool String JExpr | IfExpr JExpr JExpr JExpr | NewExpr JExpr | ApplExpr JExpr [JExpr] | UnsatExpr (IdentSupply JExpr) | AntiExpr String | TypeExpr Bool JExpr JLocalType deriving (Eq, Ord, Show, Data, Typeable) -- | Values data JVal = JVar Ident | JList [JExpr] | JDouble SaneDouble | JInt Integer | JStr String | JRegEx String | JHash (M.Map String JExpr) | JFunc [Ident] JStat | 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) --deriving instance Typeable2 (StateT [Ident] Identity) --deriving instance Data (State [Ident] JVal) --deriving instance Data (State [Ident] JExpr) --deriving instance Data (State [Ident] JStat) expr2stat :: JExpr -> JStat expr2stat (ApplExpr x y) = (ApplStat x y) expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) expr2stat (PPostExpr b s x) = PPostStat b s x expr2stat (AntiExpr x) = AntiStat x expr2stat _ = nullStat {-------------------------------------------------------------------- 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 jtoGADT :: a -> JMGadt a jfromGADT :: JMGadt a -> a instance JMacro Ident where jtoGADT = JMGId jfromGADT (JMGId x) = x jfromGADT _ = error "impossible" instance JMacro JStat where jtoGADT = JMGStat jfromGADT (JMGStat x) = x jfromGADT _ = error "impossible" instance JMacro JExpr where jtoGADT = JMGExpr jfromGADT (JMGExpr x) = x jfromGADT _ = error "impossible" instance JMacro JVal where jtoGADT = JMGVal jfromGADT (JMGVal x) = x jfromGADT _ = error "impossible" -- | Union type to allow regular traversal by compos. data JMGadt a where JMGId :: Ident -> JMGadt Ident JMGStat :: JStat -> JMGadt JStat JMGExpr :: JExpr -> JMGadt JExpr JMGVal :: JVal -> JMGadt JVal composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b composOp f = runIdentity . composOpM (Identity . f) 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) => (forall a. t a -> m ()) -> t b -> m () composOpM_ = composOpFold (return ()) (>>) 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 } 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 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 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 BlockStat xs -> ret BlockStat `app` mapM' f xs ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2 PPostStat b o e -> ret (PPostStat b o) `app` f e AssignStat e e' -> ret AssignStat `app` f e `app` f e' UnsatBlock _ -> ret v' AntiStat _ -> ret v' ForeignStat i t -> ret ForeignStat `app` f i `app` ret t 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' InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e' PPostExpr b o e -> ret (PPostExpr b o) `app` f e IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e'' NewExpr e -> ret NewExpr `app` f e ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs AntiExpr _ -> ret v' TypeExpr b e t -> ret (TypeExpr b) `app` f e `app` ret t UnsatExpr _ -> ret v' 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' JInt _ -> ret v' JStr _ -> ret v' JRegEx _ -> ret v' JHash m -> ret JHash `app` m' where (ls, vs) = unzip (M.toList m) 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' :: 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 --------------------------------------------------------------------} class ToSat a where toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident]) instance ToSat [JStat] where toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) instance ToSat JStat where toSat_ f vs = IS $ return $ (f, reverse vs) instance ToSat JExpr where toSat_ f vs = IS $ return $ (expr2stat f, reverse vs) instance ToSat [JExpr] where toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs) instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where toSat_ f vs = IS $ do x <- takeOne runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs) {- splitIdentSupply :: ([Ident] -> ([Ident], [Ident])) splitIdentSupply is = (takeAlt is, takeAlt (drop 1 is)) where takeAlt (x:_:xs) = x : takeAlt xs takeAlt _ = error "splitIdentSupply: stream is not infinite" -} {-------------------------------------------------------------------- Saturation --------------------------------------------------------------------} -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. jsSaturate :: (JMacro a) => Maybe String -> a -> a jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) jsSaturate_ :: (JMacro a) => a -> IdentSupply a 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 --------------------------------------------------------------------} --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 go v = case v of JMGId i -> maybe v JMGId (M.lookup i mp) _ -> composOp go v mp = M.fromList xs --only works on fully saturated things jsUnsat_ :: JMacro a => [Ident] -> a -> IdentSupply a jsUnsat_ xs e = IS $ do (idents,is') <- splitAt (length xs) <$> get put is' return $ jsReplace_ (zip xs idents) e -- | 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. 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 ([StrI a], b) <- splitAt 1 `fmap` get put b return $ withHygiene_ a f z 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) 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) = (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 (JMGExpr (ValExpr (JFunc is s))) -> do st <- get let (newIs,newSt) = splitAt (length is) st put (newSt) rest <- jfromGADT <$> go (jtoGADT s) return . JMGExpr . ValExpr $ JFunc newIs $ (jsReplace_ $ zip is newIs) rest _ -> composOpM go v {-------------------------------------------------------------------- Pretty Printing --------------------------------------------------------------------} -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, -- well formatted String). renderJs :: (JsToDoc a, JMacro a) => a -> Doc renderJs = jsToDoc . jsSaturate Nothing -- | Render a syntax tree as a pretty-printable document, using a given prefix to all generated names. Use this with distinct prefixes to ensure distinct generated names between independent calls to render(Prefix)Js. renderPrefixJs :: (JsToDoc a, JMacro a) => String -> a -> Doc renderPrefixJs pfx = jsToDoc . jsSaturate (Just $ "jmId_"++pfx) braceNest :: Doc -> Doc braceNest x = char '{' <+> nest 2 x $$ char '}' braceNest' :: Doc -> Doc braceNest' x = nest 2 (char '{' $+$ x) $$ char '}' class JsToDoc a where jsToDoc :: a -> Doc instance JsToDoc JStat where jsToDoc (IfStat cond x y) = text "if" <> parens (jsToDoc cond) $$ braceNest' (jsToDoc x) $$ mbElse where mbElse | y == BlockStat [] = PP.empty | otherwise = text "else" $$ braceNest' (jsToDoc y) jsToDoc (DeclStat x t) = text "var" <+> jsToDoc x <> rest where rest = case t of Nothing -> text "" Just tp -> text " /* ::" <+> jsToDoc tp <+> text "*/" 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 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 ':') $$$ (jsToDoc s)) l ++ [text "default:" $$$ (jsToDoc d)] cases = vcat l' jsToDoc (ReturnStat e) = text "return" <+> jsToDoc e 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) mbFinally | s2 == BlockStat [] = PP.empty | otherwise = text "finally" $$ braceNest' (jsToDoc s2) jsToDoc (AssignStat i x) = jsToDoc i <+> char '=' <+> jsToDoc x jsToDoc (PPostStat isPre op x) | 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) 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 (T.pack op'), jsToDoc y] where op' | op == "++" = "+" | otherwise = op jsToDoc (PPostExpr isPre op x) | isPre = text (T.pack op) <> optParens x | otherwise = optParens x <> text (T.pack op) jsToDoc (ApplExpr je xs) = jsToDoc je <> (parens . fillSep . punctuate comma $ map jsToDoc xs) jsToDoc (NewExpr e) = text "new" <+> jsToDoc e 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 . fillSep . punctuate comma $ map jsToDoc xs 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++"/" jsToDoc (JHash m) | M.null m = text "{}" | 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 (T.pack s) instance JsToDoc [JExpr] where jsToDoc = vcat . map ((<> semi) . jsToDoc) instance JsToDoc [JStat] where jsToDoc = vcat . map ((<> semi) . jsToDoc) instance JsToDoc JType where jsToDoc JTNum = text "Num" jsToDoc JTString = text "String" jsToDoc JTBool = text "Bool" jsToDoc JTStat = text "()" jsToDoc JTImpossible = text "_|_" -- "⊥" 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 (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 "]" {- maybe (text "") (text " / " <>) (ppConstraintList . map (\x -> (ref,x)) $ S.toList cs) <> text "]" -} 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 . 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 ppType :: JType -> Doc ppType x@(JTFunc _ _) = parens $ jsToDoc x ppType x@(JTMap _) = parens $ jsToDoc x ppType x = jsToDoc x {-------------------------------------------------------------------- ToJExpr Class --------------------------------------------------------------------} -- | Things that can be marshalled into javascript values. -- Instantiate for any necessary data structures. class ToJExpr a where toJExpr :: a -> JExpr toJExprFromList :: [a] -> JExpr toJExprFromList = ValExpr . JList . map toJExpr instance ToJExpr a => ToJExpr [a] where toJExpr = toJExprFromList instance ToJExpr JExpr where toJExpr = id instance ToJExpr () where toJExpr _ = ValExpr $ JList [] instance ToJExpr Bool where toJExpr True = jsv "true" toJExpr False = jsv "false" instance ToJExpr JVal where toJExpr = ValExpr instance ToJExpr a => ToJExpr (M.Map String a) where toJExpr = ValExpr . JHash . M.map toJExpr instance ToJExpr Double where toJExpr = ValExpr . JDouble . SaneDouble instance ToJExpr Int where toJExpr = ValExpr . JInt . fromIntegral instance ToJExpr Integer where toJExpr = ValExpr . JInt instance ToJExpr Char where toJExpr = ValExpr . JStr . (:[]) toJExprFromList = ValExpr . JStr -- where escQuotes = tailDef "" . initDef "" . show instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c] instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d] instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e] instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] instance Num JExpr where fromInteger = ValExpr . JInt . fromIntegral x + y = InfixExpr "+" x y x - y = InfixExpr "-" x y x * y = InfixExpr "*" x y abs x = ApplExpr (jsv "Math.abs") [x] signum x = IfExpr (InfixExpr ">" x 0) 1 (IfExpr (InfixExpr "==" x 0) 0 (-1)) {-------------------------------------------------------------------- Block Sugar --------------------------------------------------------------------} class ToStat a where toStat :: a -> JStat instance ToStat JStat where toStat = id instance ToStat [JStat] where toStat = BlockStat instance ToStat JExpr where toStat = expr2stat instance ToStat [JExpr] where toStat = BlockStat . map expr2stat {-------------------------------------------------------------------- Combinators --------------------------------------------------------------------} -- | Create a new anonymous function. The result is an expression. -- Usage: -- @jLam $ \ x y -> {JExpr involving x and y}@ jLam :: (ToSat a) => a -> JExpr jLam f = ValExpr . UnsatVal . IS $ do (block,is) <- runIdentSupply $ toSat_ f [] return $ JFunc is block -- | Introduce a new variable into scope for the duration -- of the enclosed expression. The result is a block statement. -- Usage: -- @jVar $ \ x y -> {JExpr involving x and y}@ jVar :: (ToSat a) => a -> JStat jVar f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] let addDecls (BlockStat ss) = BlockStat $ map (\x -> DeclStat x Nothing) is ++ ss addDecls x = x return $ addDecls block -- | Introduce a new variable with optional type into scope for the duration -- of the enclosed expression. The result is a block statement. -- Usage: -- @jVar $ \ x y -> {JExpr involving x and y}@ jVarTy :: (ToSat a) => a -> (Maybe JLocalType) -> JStat jVarTy f t = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] let addDecls (BlockStat ss) = BlockStat $ map (\x -> DeclStat x t) is ++ ss addDecls x = x return $ addDecls block -- | Create a for in statement. -- Usage: -- @jForIn {expression} $ \x -> {block involving x}@ jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat jForIn e f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] return $ ForInStat False (headNote "jForIn" is) e block -- | As with "jForIn" but creating a \"for each in\" statement. jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat jForEachIn e f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] return $ ForInStat True (headNote "jForIn" is) e block jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat jTryCatchFinally s f s2 = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] return $ TryStat s (headNote "jTryCatch" is) block s2 jsv :: String -> JExpr jsv = ValExpr . JVar . StrI jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat 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] jhEmpty :: M.Map String JExpr jhEmpty = M.empty jhSingle :: ToJExpr a => String -> a -> M.Map String JExpr jhSingle k v = jhAdd k v $ jhEmpty jhAdd :: ToJExpr a => String -> a -> M.Map String JExpr -> M.Map String JExpr jhAdd k v m = M.insert k (toJExpr v) m jhFromList :: [(String, JExpr)] -> JVal jhFromList = JHash . M.fromList jtFromList :: JType -> [(String, JType)] -> JType jtFromList t y = JTRecord t $ M.fromList y nullStat :: JStat nullStat = BlockStat [] -- Aeson instance instance ToJExpr Value where toJExpr Null = ValExpr $ JVar $ StrI "null" toJExpr (Bool b) = ValExpr $ JVar $ StrI $ map toLower (show b) toJExpr (Number n) = ValExpr $ JDouble $ realToFrac n toJExpr (String s) = ValExpr $ JStr $ TS.unpack s toJExpr (Array vs) = ValExpr $ JList $ map toJExpr $ V.toList vs toJExpr (Object obj) = ValExpr $ JHash $ M.fromList $ map (TS.unpack *** toJExpr) $ HM.toList obj ------------------------- -- Taken from json package by Sigbjorn Finne. encodeJson :: String -> String encodeJson = concatMap encodeJsonChar encodeJsonChar :: Char -> String encodeJsonChar '/' = "\\/" encodeJsonChar '\b' = "\\b" encodeJsonChar '\f' = "\\f" encodeJsonChar '\n' = "\\n" encodeJsonChar '\r' = "\\r" encodeJsonChar '\t' = "\\t" encodeJsonChar '"' = "\\\"" encodeJsonChar '\\' = "\\\\" encodeJsonChar c | not $ isControl c = [c] | c < '\x10' = '\\' : 'u' : '0' : '0' : '0' : hexxs | c < '\x100' = '\\' : 'u' : '0' : '0' : hexxs | c < '\x1000' = '\\' : 'u' : '0' : hexxs where hexxs = showHex (fromEnum c) "" -- FIXME encodeJsonChar c = [c] jmacro-0.6.8/Language/Javascript/JMacro/Benchmark.hs0000644000000000000000000000055512155151001020414 0ustar0000000000000000{-# 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 jmacro-0.6.8/Language/Javascript/JMacro/Executable.hs0000644000000000000000000000314012155151001020574 0ustar0000000000000000{-# LANGUAGE GADTs, RankNTypes #-} module Main where import Text.PrettyPrint.Leijen.Text (hPutDoc) import Control.Applicative import Control.Monad import Language.Javascript.JMacro import System.Environment import System.Console.ParseArgs import System.IO main = do args <- parseArgsIO ArgsComplete [Arg "Scope" (Just 's') (Just "scope") Nothing "Enforce block scoping through global variable renames.", Arg "Help" (Just 'h') (Just "help") Nothing "", Arg "Infile" Nothing Nothing (argDataOptional "Input file" ArgtypeString) "Input file", Arg "Outfile" Nothing Nothing (argDataOptional "Output file" ArgtypeString) "Output file"] when (gotArg args "Help") $ usageError args "Transforms jmacro code into valid javascript." let s = gotArg args "Scope" infile <- getArgStdio args "Infile" ReadMode outfile <- getArgStdio args "Outfile" WriteMode either (hPrint stderr) (hPutDoc outfile) . parseIt s =<< hGetContents infile where parseIt True = onRight (renderJs . scopify) . parseJM parseIt False = onRight (renderJs . fixIdent) . parseJM onRight :: (a -> b) -> Either c a -> Either c b onRight f (Right x) = Right (f x) onRight _ (Left x) = (Left x) 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 jmacro-0.6.8/Language/Javascript/JMacro/ParseTH.hs0000644000000000000000000000263412155151001020030 0ustar0000000000000000module Language.Javascript.JMacro.ParseTH (parseHSExp) where import Language.Haskell.Meta.Parse import qualified Language.Haskell.TH as TH -- import Language.Haskell.Exts.Translate -- import Language.Haskell.Exts.Parser -- import Language.Haskell.Exts.Extension -- import Language.Haskell.Exts.Annotated.Fixity -- import qualified Language.Haskell.Exts.Syntax as Hs parseHSExp :: String -> Either String TH.Exp --for haskell-src-exts-qq --parseHSExp = fmap toExp . parseResultToEither . parseExpWithMode myDefaultParseMode --for Language.Haskell.Meta parseHSExp = parseExp {- parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a parseResultToEither (ParseFailed loc e) = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) myDefaultParseMode :: ParseMode myDefaultParseMode = ParseMode {parseFilename = [] ,extensions = myDefaultExtensions ,ignoreLanguagePragmas = False ,fixities = baseFixities ,ignoreLinePragmas = False} myDefaultExtensions :: [Extension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax ,PatternSignatures ,MagicHash ,ForeignFunctionInterface ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses ,RecursiveDo] -} jmacro-0.6.8/Language/Javascript/JMacro/Prelude.hs0000644000000000000000000002523012155151001020117 0ustar0000000000000000{- | Module : Language.Javascript.JMacro.Prelude Copyright : (c) Gershom Bazerman, Jeff Polakow 2010 License : BSD 3 Clause Maintainer : gershomb@gmail.com Stability : experimental -} {-# LANGUAGE QuasiQuotes #-} module Language.Javascript.JMacro.Prelude where 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| fun withHourglass f { document.body.style.cursor="wait"; setTimeout(\ { try {f();} catch(e) {console.log(e);} document.body.style.cursor="default";}, 400); }; fun confirmIt n f { var r = confirm("Are you sure you want to " + n + "?"); if(r) { f(); } return false; }; fun memo f { var tbl = {}; return \x { var v0 = tbl[x]; if( v0 == null ) { var v1 = f x; tbl[x] = v1; return v1 } else { return v0 } } }; fun mySplit str xs -> map $.trim (xs.split str); fun unquote open close x { var special = ["[","]","(",")"]; fun escape c -> (elem c special ? "\\" : "") + c; var rgx = new RegExp("^"+escape open+"(.*)"+escape close+"$"), res = x.match(rgx); if( res != null ) {return res[1]} else {return x} }; fun head xs -> xs[0]; fun tail xs -> xs.slice(1); fun init xs {xs.pop(); return xs;}; fun last xs -> xs[xs.length - 1]; fun cons x xs { xs.unshift(x); return xs; }; fun id x -> x; fun konst x -> \_ -> x; fun isEmpty x -> x.length == 0; fun notNull x -> x != null; fun nullDef def x -> x == null ? def : x; fun bindNl x f -> x == null ? null : f x; fun tryNull x notNull isNull -> x != null ? notNull x : isNull(); // -- objFoldl is really just objFold (maps don't have a left and right) // --objFoldlEnumLbl :: (label -> b -> a -> (b,Bool)) -> b -> [a] -> b // --Provides shortcut escape. fun objFoldlEnumLbl f v xs { var acc = v; for( var i in xs ) { if (xs[i] != null) { var res = f i acc xs[i]; acc = res[0]; if( !res[1] ) { break; } }; }; return acc; }; // --objFoldlEnum :: (b -> a -> (b,Bool)) -> b -> [a] -> b fun objFoldlEnum f v xs -> objFoldlEnumLbl (\_ acc x -> f acc x) v xs; // --As above, no shortcut return fun objFoldlLbl f v xs { var acc = v; for( var i in xs) {if (xs[i] != null) {acc = f i acc xs[i]};}; return acc; }; fun objFoldl f v xs -> objFoldlLbl (\_ acc x -> f acc x) v xs; fun mapObjVals f xs -> objFoldlLbl (\lbl acc x {acc[lbl] = f x; return acc}) {} xs fun objLength xs -> objFoldl (\n _ -> n + 1) 0 xs; fun objIter f xs -> objFoldl (\_ x {f x; return null}) null xs; fun objIterLbl f xs -> objFoldlLbl (\l _ v {f l v; return null}) null xs; fun objUnion xs ys { var res = {}; for (var i in xs) {res[i] = xs[i]}; for (var i in ys) {res[i] = ys[i]}; return res; }; // -- as above, but over arrays. fun foldlEnumIdx f v xs { var acc = v; for( var i = 0; i < xs.length; i = i + 1) { var res = f i acc xs[i]; acc = res[0]; if( !res[1] ) { break; } }; return acc; }; fun foldlEnum f v xs -> foldlEnumIdx (\_ acc x -> f acc x) v xs; fun foldl f v xs { // -- foldlEnum (\acc x -> [f acc x, true]) v xs; var acc = v; for( var i = 0; i < xs.length; i++) {acc = f acc xs[i];}; return acc; }; fun foldl2 f v xs ys { var acc = v; for( var i = 0; i < xs.length && i < ys.length; i++) {acc = f acc xs[i] ys[i];}; return acc; }; fun foldr f v xs { var res = v; for( var i = xs.length - 1; i >= 0; i = i - 1) {res = f xs[i] res;}; return res; }; // -- IE doesn't treat strings as arrays fun strFoldr f v xs { var res = v; for (var i = xs.length - 1; i >= 0; i = i - 1) {res = f xs.charAt(i) res}; return res; }; fun max x y -> x > y ? x : y; fun min x y -> x < y ? x : y; fun maximumOrNull xs -> (xs.length == 0) ? null : foldl max (head xs) (tail xs); fun minimumOrNull xs -> (xs.length == 0) ? null : foldl min (head xs) (tail xs); fun sum x -> foldl (\a b -> a + b) 0 x; // -- ['a','b','c'] --> [['a',0], ['b',1], ['c',2]] fun addIndex xs { var res = []; for( var i = 0; i < xs.length; i++) { res.push([xs[i],i]) }; return res; }; // -- cmp x y is true when x > y fun minimumBy cmp xs -> foldl (\x y -> cmp x y ? x : y) (xs[0]) xs.slice(1); fun zipWith f xs ys { var res = [], l = min xs.length ys.length; for(var i = 0; i < l; i++) { res.push(f xs[i] ys[i]); } return res; }; fun zip xs ys -> zipWith (\x y -> [x, y]) xs ys; fun zip3 xs ys zs { var res = [], l = min (min xs.length ys.length) zs.length; for(var i = 0; i < l; i++) { res.push([xs[i], ys[i], zs[i]]); } return res; }; fun getTblHash tbl { var cols = $("th", $(tbl)).map(\_ x -> $(x).text()); return map (\r -> foldl2 (\acc c v {acc[c] = $(v).text(); return acc}) {} cols $("td",$(r))) $("tbody tr", $(tbl)) }; // -- equality test which ignores case for strings fun eq x y { var x1 = typeof(x) == "string" ? x.toLowerCase() : x, y1 = typeof(y) == "string" ? y.toLowerCase() : y; return x1 == y1; }; // -- structural equality fun equals x y { if(x===y) {return true;} if(typeof x != typeof y) {return false;} if($.isArray x && $.isArray y) { for(var n in x) { if (!(equals x[n] y[n])) {return false;} } return true; } return x == y; } fun map f xs -> foldl (\acc x {acc.push(f x); return acc}) [] xs; fun filter p xs -> foldl (\acc x {if (p x) {acc.push(x)}; return acc}) [] xs fun mapFilter p f xs -> foldl (\acc x {if (p x) {acc.push(f x)}; return acc}) [] xs fun concat xs -> foldl (\acc x -> acc.concat(x) ) [] xs fun toList xs -> map id xs; // -- this can turn a jQuery object into a real list fun all p xs -> foldlEnum (\_ x -> [p x, p x]) true xs; fun findWithIdx p xs -> foldlEnumIdx (\i failure x -> p i x ? [x, false] : [failure, true]) null xs; fun findIdx p xs -> foldlEnumIdx (\i failure x -> p x ? [i, false] : [failure, true]) null xs; fun find p xs -> findWithIdx (\_ x -> p x) xs; fun elem x xs -> tryNull (find (\y -> x == y) xs) (konst true) (konst false); fun isPrefixOf x xs -> xs.search(new RegExp("^"+x)) != -1; // -- sortOn :: Ord b => (a -> b) -> [a] -> [a] fun sortOn f arr { fun cmpFun x y { var xv = f x, yv = f y; if (xv == yv) {return 0}; if (xv == null) {return 1}; if (yv == null) {return -1}; return xv > yv ? 1 : -1 }; arr.sort(cmpFun); return arr; } fun hashOn f xs { var hash = {}; fun pushAttr x { var atr = f x; if( atr != null ) { if( hash[atr] == null ) { hash[atr] = [] }; hash[atr].push(x) }; }; map pushAttr xs; return hash; } fun groupOn f xs { var hash = hashOn f xs; return objFoldl (\acc x {acc.push x; return acc;}) [] hash; } fun chunkBy x ys -> x >= ys.length ? [ys] : cons (ys.slice(0,x)) (chunkBy x (ys.slice(x))); fun transpose xxs { if (xxs.length == 0) {return []}; if (xxs[0].length == 0) {return transpose (tail xxs);}; var x = xxs[0][0], xs = xxs[0].slice(1), xss = xxs.slice(1); return cons (cons x (map head xss)) (transpose (cons xs (map tail xss))) // -- (x : map head xss) : transpose (xs : map tail xss) } // -- idxs is an array of (index, sort ascending?) pairs fun multiIdxSortGen idxs cmpFun modFun xs { var f = \x y -> \i acc idxsi { var cmp = cmpFun (modFun x)[i] (modFun y)[i]; return (cmp != 0) ? [idxsi[1] ? cmp : cmp * (-1), false] : [acc, true] }; xs.sort( \x y -> foldlEnumIdx (f x y) 0 idxs ); }; // --A few statistical funcutions. // -- ordinary least squares fun ols xs ys { if (xs.length != ys.length) {return null}; var n = xs.length, sx = sum xs, sx2 = sum (map (\x -> x*x) xs), sy = sum ys, sxy = sum (zipWith (\x y -> x * y) xs ys), bot = n * sx2 - sx * sx, m = (n * sxy - sy*sx) / bot, b = (sy * sx2 - sx * sxy) / bot; return [m,b]; }; // -- Linear regression fun doRegress xs { var xvs = map (\x -> x[0]) xs, yvs = map (\x -> x[1]) xs, regressres = ols xvs yvs, m = regressres[0], b = regressres[1], yvs1 = map (\x -> m*x+b) xvs, ymean = mean yvs, sstot = sum (map (\y -> Math.pow (y - ymean) 2) yvs), sserr = sum (zipWith (\y f -> Math.pow (y - f) 2) yvs yvs1), xsNew = zipWith (\x y -> [x,y,x,y.toPrecision(2),""]) xvs yvs1; return [xsNew, (1 - (sserr/sstot)).toPrecision(4)]; }; fun mean xs { var res = xs[0]; for (var i = 1; i < xs.length; i++) { var x = xs[i]; var delta = x - res; var sweep = i + 1.0; res = res + (delta / sweep); // -- sqsum += delta * delta * (i / sweep); } return res; }; fun stdev xs { // -- Knuth's standard deviation algorithm, returns [stdDev, mean, size] var n = 0, mean = 0, s = 0; for (var i = 0; i < xs.length; i++) { n = n + 1; var delta = xs[i] - mean; mean = mean + delta/n; s = s + delta*(xs[i] - mean); // -- this expression uses the new value of mean }; return [Math.sqrt (s/(n - 1)), mean, n]; }; |]jmacro-0.6.8/Language/Javascript/JMacro/QQ.hs0000644000000000000000000010065512155151001017045 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes, RankNTypes, GADTs #-} ----------------------------------------------------------------------------- {- | Module : Language.Javascript.JMacro Copyright : (c) Gershom Bazerman, 2009 License : BSD 3 Clause Maintainer : gershomb@gmail.com Stability : experimental Simple EDSL for lightweight (untyped) programmatic generation of Javascript. -} ----------------------------------------------------------------------------- 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.Arrow(first) import Control.Monad.State.Strict import Data.Char(digitToInt, toLower, isUpper) import Data.List(isPrefixOf, sort) import Data.Generics(extQ,Data) import Data.Maybe(fromMaybe) import Data.Monoid import qualified Data.Map as M --import Language.Haskell.Meta.Parse import qualified Language.Haskell.TH as TH import Language.Haskell.TH(mkName) --import qualified Language.Haskell.TH.Lib as TH import Language.Haskell.TH.Quote import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Expr import Text.ParserCombinators.Parsec.Error import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(javaStyle) import Text.Regex.Posix.String import Language.Javascript.JMacro.Base import Language.Javascript.JMacro.Types import Language.Javascript.JMacro.ParseTH import System.IO.Unsafe import Numeric(readHex) -- import Debug.Trace {-------------------------------------------------------------------- QuasiQuotation --------------------------------------------------------------------} -- | QuasiQuoter for a block of JMacro statements. jmacro :: QuasiQuoter jmacro = QuasiQuoter {quoteExp = quoteJMExp, quotePat = quoteJMPat} -- | QuasiQuoter for a JMacro expression. jmacroE :: QuasiQuoter jmacroE = QuasiQuoter {quoteExp = quoteJMExpE, quotePat = quoteJMPatE} quoteJMPat :: String -> TH.PatQ quoteJMPat s = case parseJM s of Right x -> dataToPatQ (const Nothing) x Left err -> fail (show err) quoteJMExp :: String -> TH.ExpQ quoteJMExp s = case parseJM s of Right x -> jm2th x Left err -> do (line,_) <- TH.loc_start <$> TH.location let pos = errorPos err let newPos = setSourceLine pos $ line + sourceLine pos - 1 fail (show $ setErrorPos newPos err) quoteJMPatE :: String -> TH.PatQ quoteJMPatE s = case parseJME s of Right x -> dataToPatQ (const Nothing) x Left err -> fail (show err) quoteJMExpE :: String -> TH.ExpQ quoteJMExpE s = case parseJME s of Right x -> jm2th x Left err -> do (line,_) <- TH.loc_start <$> TH.location let pos = errorPos err let newPos = setSourceLine pos $ line + sourceLine pos - 1 fail (show $ setErrorPos newPos err) -- | Traverse a syntax tree, replace an identifier by an -- antiquotation of a free variable. -- Don't replace identifiers on the right hand side of selector -- expressions. antiIdent :: JMacro a => String -> a -> a 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 css@(c:_) | isUpper c = '_' : escapeDollar css | otherwise = escapeDollar css where escapeDollar = map (\x -> if x =='$' then 'dž' else x) fixIdent _ = "_" jm2th :: Data a => a -> TH.ExpQ jm2th v = dataToExpQ (const Nothing `extQ` handleStat `extQ` handleExpr `extQ` handleVal `extQ` handleStr `extQ` handleTyp ) v where handleStat :: JStat -> Maybe (TH.ExpQ) handleStat (BlockStat ss) = Just $ appConstr "BlockStat" $ TH.listE (blocks ss) where blocks :: [JStat] -> [TH.ExpQ] blocks [] = [] blocks (DeclStat (StrI i) t:xs) = case i of ('!':'!':i') -> jm2th (DeclStat (StrI i') t) : blocks xs ('!':i') -> [TH.appE (TH.lamE [TH.varP . mkName . fixIdent $ i'] $ appConstr "BlockStat" (TH.listE . (ds:) . blocks $ xs)) (TH.appE (TH.varE $ mkName "jsv") (TH.litE $ TH.StringL i'))] where ds = TH.appE (TH.appE (TH.conE $ mkName "DeclStat") (TH.appE (TH.conE $ mkName "StrI") (TH.litE $ TH.StringL i'))) (jm2th t) _ -> [TH.appE (TH.appE (TH.varE $ mkName "jVarTy") (TH.lamE [TH.varP . mkName . fixIdent $ i] $ appConstr "BlockStat" (TH.listE $ blocks $ map (antiIdent i) xs))) (jm2th t) ] blocks (x:xs) = jm2th x : blocks xs handleStat (ForInStat b (StrI i) e s) = Just $ appFun (TH.varE $ forFunc) [jm2th e, TH.lamE [TH.varP $ mkName i] (jm2th $ antiIdent i s) ] where forFunc | b = mkName "jForEachIn" | otherwise = mkName "jForIn" handleStat (TryStat s (StrI i) s1 s2) | s1 == BlockStat [] = Nothing | otherwise = Just $ appFun (TH.varE $ mkName "jTryCatchFinally") [jm2th s, TH.lamE [TH.varP $ mkName i] (jm2th $ antiIdent i s1), jm2th s2 ] handleStat (AntiStat s) = case parseHSExp s of Right ans -> Just $ TH.appE (TH.varE (mkName "toStat")) (return ans) Left err -> Just $ fail err handleStat _ = Nothing handleExpr :: JExpr -> Maybe (TH.ExpQ) handleExpr (AntiExpr s) = case parseHSExp s of Right ans -> Just $ TH.appE (TH.varE (mkName "toJExpr")) (return ans) Left err -> Just $ fail err handleExpr (ValExpr (JFunc is' s)) = Just $ TH.appE (TH.varE $ mkName "jLam") (TH.lamE (map (TH.varP . mkName . fixIdent) is) (jm2th $ antiIdents is s)) where is = map (\(StrI i) -> i) is' handleExpr _ = Nothing handleVal :: JVal -> Maybe (TH.ExpQ) handleVal (JHash m) = Just $ TH.appE (TH.varE $ mkName "jhFromList") $ jm2th (M.toList m) handleVal _ = Nothing handleStr :: String -> Maybe (TH.ExpQ) handleStr x = Just $ TH.litE $ TH.StringL x handleTyp :: JType -> Maybe (TH.ExpQ) handleTyp (JTRecord t mp) = Just $ TH.appE (TH.appE (TH.varE $ mkName "jtFromList") (jm2th t)) (jm2th $ M.toList mp) handleTyp _ = Nothing appFun x = foldl (TH.appE) x appConstr n = TH.appE (TH.conE $ mkName n) {-------------------------------------------------------------------- Parsing --------------------------------------------------------------------} type JMParser a = CharParser () a lexer :: P.TokenParser () symbol :: String -> JMParser String parens, braces :: JMParser a -> JMParser a dot, colon, semi, identifier, identifierWithBang :: JMParser String whiteSpace :: JMParser () reserved, reservedOp :: String -> JMParser () commaSep, commaSep1 :: JMParser a -> JMParser [a] lexer = P.makeTokenParser jsLang jsLang :: P.LanguageDef () jsLang = javaStyle { 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 = "*/"} identifierWithBang = P.identifier $ P.makeTokenParser $ jsLang {P.identStart = letter <|> oneOf "_$!"} whiteSpace= P.whiteSpace lexer symbol = P.symbol lexer 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 lexeme :: JMParser a -> JMParser a lexeme = P.lexeme lexer (<*) :: Monad m => m b -> m a -> m b x <* y = do xr <- x _ <- y return xr parseJM :: String -> Either ParseError JStat parseJM s = BlockStat <$> runParser jmacroParser () "" s where jmacroParser = do ans <- statblock eof return ans parseJME :: String -> Either ParseError JExpr parseJME s = runParser jmacroParserE () "" s where jmacroParserE = do ans <- whiteSpace >> expr eof return ans getType :: JMParser (Bool, JLocalType) getType = do isForce <- (reservedOp "::!" >> return True) <|> (reservedOp "::" >> return False) t <- runTypeParser return (isForce, t) addForcedType :: Maybe (Bool, JLocalType) -> JExpr -> JExpr addForcedType (Just (True,t)) e = TypeExpr True e t addForcedType _ e = e --function !foo or function foo or var !x or var x, with optional type varidentdecl :: JMParser (Ident, Maybe (Bool, JLocalType)) varidentdecl = do i <- identifierWithBang when ("jmId_" `isPrefixOf` i || "!jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." when (i=="this" || i=="!this") $ fail "Illegal attempt to name variable 'this'." t <- optionMaybe getType return (StrI i, t) --any other identifier decl identdecl :: JMParser Ident identdecl = do i <- identifier when ("jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." when (i=="this") $ fail "Illegal attempt to name variable 'this'." return (StrI i) cleanIdent :: Ident -> Ident cleanIdent (StrI ('!':x)) = StrI x cleanIdent x = x -- Handle varident decls for type annotations? -- Patterns data PatternTree = PTAs Ident PatternTree | PTCons PatternTree PatternTree | PTList [PatternTree] | PTObj [(String,PatternTree)] | PTVar Ident deriving Show patternTree :: JMParser PatternTree patternTree = toCons <$> (parens patternTree <|> ptList <|> ptObj <|> varOrAs) `sepBy1` reservedOp ":|" where toCons [] = PTVar (StrI "_") toCons [x] = x toCons (x:xs) = PTCons x (toCons xs) ptList = lexeme $ PTList <$> brackets' (commaSep patternTree) ptObj = lexeme $ PTObj <$> oxfordBraces (commaSep $ liftM2 (,) myIdent (colon >> patternTree)) varOrAs = do i <- fst <$> varidentdecl isAs <- option False (reservedOp "@" >> return True) if isAs then PTAs i <$> patternTree else return $ PTVar i --either we have a function from any ident to the constituent parts --OR the top level is named, and hence we have the top ident, plus decls for the constituent parts patternBinding :: JMParser (Either (Ident -> [JStat]) (Ident,[JStat])) patternBinding = do ptree <- patternTree let go path (PTAs asIdent pt) = [DeclStat asIdent Nothing, AssignStat (ValExpr (JVar (cleanIdent asIdent))) path] ++ go path pt go path (PTVar i) | i == (StrI "_") = [] | otherwise = [DeclStat i Nothing, AssignStat (ValExpr (JVar (cleanIdent i))) (path)] go path (PTList pts) = concatMap (uncurry go) $ zip (map addIntToPath [0..]) pts where addIntToPath i = IdxExpr path (ValExpr $ JInt i) go path (PTObj xs) = concatMap (uncurry go) $ map (first fixPath) xs where fixPath lbl = IdxExpr path (ValExpr $ JStr lbl) go path (PTCons x xs) = concat [go (IdxExpr path (ValExpr $ JInt 0)) x, go (ApplExpr (SelExpr path (StrI "slice")) [ValExpr $ JInt 1]) xs] case ptree of PTVar i -> return $ Right (i,[]) PTAs i pt -> return $ Right (i, go (ValExpr $ JVar i) pt) _ -> return $ Left $ \i -> go (ValExpr $ JVar i) ptree 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 reservedOp "=" e <- expr return $ AssignStat (ValExpr (JVar (cleanIdent i))) e : patDecls return $ DeclStat i Nothing : fromMaybe [] optAssignStat where matchVar = StrI "jmId_match_var" statblock :: JMParser [JStat] statblock = concat <$> (sepEndBy1 (whiteSpace >> statement) (semi <|> return "")) statblock0 :: JMParser [JStat] statblock0 = try statblock <|> (whiteSpace >> return []) l2s :: [JStat] -> JStat l2s xs = BlockStat xs statementOrEmpty :: JMParser [JStat] statementOrEmpty = try emptyStat <|> statement where emptyStat = braces (whiteSpace >> return []) -- return either an expression or a statement statement :: JMParser [JStat] statement = declStat <|> funDecl <|> functionDecl <|> foreignStat <|> returnStat <|> labelStat <|> ifStat <|> whileStat <|> switchStat <|> forStat <|> doWhileStat <|> braces statblock <|> assignOpStat <|> tryStat <|> applStat <|> breakStat <|> continueStat <|> antiStat <|> antiStatSimple "statement" where declStat = do reserved "var" res <- concat <$> commaSep1 destructuringDecl _ <- semi return res functionDecl = do reserved "function" (i,mbTyp) <- varidentdecl (as,patDecls) <- fmap (\x -> (x,[])) (try $ parens (commaSep identdecl)) <|> patternBlocks b' <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) let b = BlockStat patDecls `mappend` b' return $ [DeclStat i (fmap snd mbTyp), AssignStat (ValExpr $ JVar (cleanIdent i)) (addForcedType mbTyp $ ValExpr $ JFunc as b)] funDecl = do reserved "fun" n <- identdecl mbTyp <- optionMaybe getType (as, patDecls) <- patternBlocks b' <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) <|> (symbol "->" >> ReturnStat <$> expr) let b = BlockStat patDecls `mappend` b' return $ [DeclStat (addBang n) (fmap snd mbTyp), AssignStat (ValExpr $ JVar n) (addForcedType mbTyp $ ValExpr $ JFunc as b)] where addBang (StrI x) = StrI ('!':'!':x) foreignStat = do reserved "foreign" i <- try $ identdecl <* reservedOp "::" t <- runTypeParser return [ForeignStat i t] returnStat = reserved "return" >> (:[]) . ReturnStat <$> option (ValExpr $ JVar $ StrI "undefined") expr ifStat = do reserved "if" p <- parens expr b <- l2s <$> statementOrEmpty isElse <- (lookAhead (reserved "else") >> return True) <|> return False if isElse then do reserved "else" return . IfStat p b . l2s <$> statementOrEmpty else return $ [IfStat p b nullStat] whileStat = 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 (l,d) <- braces (liftM2 (,) (many caseStat) (option ([]) dfltStat)) return $ [SwitchStat e l (l2s d)] caseStat = reserved "case" >> liftM2 (,) expr (char ':' >> l2s <$> statblock) tryStat = do reserved "try" s <- statement isCatch <- (lookAhead (reserved "catch") >> return True) <|> return False (i,s1) <- if isCatch then do reserved "catch" liftM2 (,) (parens identdecl) statement else return $ (StrI "", []) isFinally <- (lookAhead (reserved "finally") >> return True) <|> return False s2 <- if isFinally then reserved "finally" >> statement else return $ [] return [TryStat (BlockStat s) i (BlockStat s1) (BlockStat s2)] dfltStat = reserved "default" >> char ':' >> whiteSpace >> statblock forStat = reserved "for" >> ((reserved "each" >> inBlock True) <|> try (inBlock False) <|> simpleForStat) inBlock isEach = do char '(' >> whiteSpace >> optional (reserved "var") i <- identdecl reserved "in" e <- expr char ')' >> whiteSpace s <- l2s <$> statement return $ [ForInStat isEach i e s] simpleForStat = do (before,after,p) <- parens threeStat b <- statement return $ jFor' before after p b where threeStat = 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 let rop x = reservedOp x >> return x (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.") badList = ["this","true","false","undefined","null"] case e1 of ValExpr (JVar (StrI s)) -> if s `elem` badList then gofail else return () ApplExpr _ _ -> gofail ValExpr _ -> gofail _ -> return () e2 <- expr return [AssignStat e1 (if op == "=" then e2 else InfixExpr op e1 e2)] applStat = expr2stat' =<< expr --fixme: don't handle ifstats expr2stat' e = case expr2stat e of BlockStat [] -> pzero x -> return [x] {- expr2stat' :: JExpr -> JStat expr2stat' (ApplExpr x y) = return $ (ApplStat x y) expr2stat' (IfExpr x y z) = liftM2 (IfStat x) (expr2stat' y) (expr2stat' z) expr2stat' (PostExpr s x) = return $ PostStat s x expr2stat' (AntiExpr x) = return $ AntiStat x expr2stat' _ = fail "Value expression used as statement" -} 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 expr :: JMParser JExpr expr = do e <- exprWithIf addType e where addType e = do optTyp <- optionMaybe getType case optTyp of (Just (b,t)) -> return $ TypeExpr b e t Nothing -> return e exprWithIf = do e <- rawExpr addIf e <|> return e addIf e = do reservedOp "?" t <- exprWithIf _ <- colon el <- exprWithIf let ans = (IfExpr e t el) addIf ans <|> return ans rawExpr = buildExpressionParser table dotExpr "expression" table = [[pop "~", pop "!", negop], [iop "*", iop "/", iop "%"], [pop "++", pop "--"], [iop "++", iop "+", iop "-", iop "--"], [iop "<<", iop ">>", iop ">>>"], [consOp], [iope "==", iope "!=", iope "<", iope ">", 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 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 e <- many1 (lexeme dotExprOne) "simple expression" case e of [e'] -> return e' (e':es) -> return $ ApplExpr e' es _ -> error "exprApp" dotExprOne :: JMParser JExpr dotExprOne = addNxt =<< valExpr <|> antiExpr <|> antiExprSimple <|> parens' expr <|> notExpr <|> newExpr where addNxt e = do nxt <- (Just <$> lookAhead anyChar <|> return Nothing) case nxt of Just '.' -> addNxt =<< (dot >> (SelExpr e <$> (ident' <|> numIdent))) Just '[' -> addNxt =<< (IdxExpr e <$> brackets' expr) Just '(' -> addNxt =<< (ApplExpr e <$> parens' (commaSep expr)) Just '-' -> try (reservedOp "--" >> return (PPostExpr False "--" e)) <|> return e Just '+' -> try (reservedOp "++" >> return (PPostExpr False "++" e)) <|> return e _ -> return e numIdent = StrI <$> many1 digit notExpr = try (symbol "!" >> dotExpr) >>= \e -> return (ApplExpr (ValExpr (JVar (StrI "!"))) [e]) newExpr = NewExpr <$> (reserved "new" >> dotExpr) antiExpr = AntiExpr <$> do x <- (try (symbol "`(") >> anyChar `manyTill` try (string ")`")) either (fail . ("Bad AntiQuotation: \n" ++)) (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 '\'') regex = do s <- regexLiteral --myStringLiteralNoBr '/' case compileRegex s of Right _ -> return (JRegEx s) Left err -> fail ("Parse error in regexp: " ++ show err) list = JList <$> brackets' (commaSep expr) hash = JHash . M.fromList <$> braces' (commaSep propPair) var = JVar <$> ident' func = do (symbol "\\" >> return ()) <|> reserved "function" (as,patDecls) <- fmap (\x -> (x,[])) (try $ parens (commaSep identdecl)) <|> patternBlocks b' <- (braces' statOrEblock <|> (symbol "->" >> (ReturnStat <$> expr))) return $ JFunc as (BlockStat patDecls `mappend` b') statOrEblock = try (ReturnStat <$> expr `folBy` '}') <|> (l2s <$> statblock) propPair = liftM2 (,) myIdent (colon >> expr) --notFolBy a b = a <* notFollowedBy (char b) folBy :: JMParser a -> Char -> JMParser a 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 "|}") around' :: Char -> Char -> JMParser a -> JMParser a around' a b x = lexeme (char a) >> (lexeme x <* char b) myIdent :: JMParser String myIdent = lexeme $ many1 (alphaNum <|> oneOf "_-!@#$%^&*()") <|> myStringLiteral '\'' ident' :: JMParser Ident ident' = do i <- identifier' when ("jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." return (StrI i) where identifier' = try $ do{ name <- ident'' ; if isReservedName name then unexpected ("reserved word " ++ show name) else return name } ident'' = do{ c <- P.identStart jsLang ; cs <- many (P.identLetter jsLang) ; return (c:cs) } "identifier" isReservedName name = isReserved theReservedNames caseName where caseName | P.caseSensitive jsLang = name | otherwise = map toLower name isReserved names name = scan names where scan [] = False scan (r:rs) = case (compare r name) of LT -> scan rs EQ -> True GT -> False theReservedNames | P.caseSensitive jsLang = sortedNames | otherwise = map (map toLower) sortedNames where sortedNames = sort (P.reservedNames jsLang) natFloat :: Fractional a => JMParser (Either Integer a) natFloat = (char '0' >> zeroNumFloat) <|> decimalFloat "number" where zeroNumFloat = (Left <$> (hexadecimal <|> octal)) <|> decimalFloat <|> fractFloat 0 <|> return (Left 0) decimalFloat = do n <- decimal option (Left n)(fractFloat n) fractFloat n = Right <$> fractExponent n fractExponent n = (do fract <- fraction expo <- option 1.0 exponent' return ((fromInteger n + fract)*expo) ) <|> ((fromInteger n *) <$> exponent') fraction = char '.' >> (foldr op 0.0 <$> many1 digit "fraction") where op d f = (f + fromIntegral (digitToInt d))/10.0 exponent' = do _ <- oneOf "eE" f <- sign power . f <$> decimal where power e | e < 0 = 1.0/power(-e) | otherwise = fromInteger (10^e) sign = (char '-' >> return negate) <|> (char '+' >> return id) <|> return id decimal = number 10 digit hexadecimal = oneOf "xX" >> number 16 hexDigit octal = oneOf "oO" >> number 8 octDigit number base baseDig = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 <$> many1 baseDig myStringLiteral :: Char -> JMParser String myStringLiteral t = do _ <- char t x <- concat <$> many myChar _ <- char t decodeJson x where myChar = do c <- noneOf [t] case c of '\\' -> do c2 <- anyChar return [c,c2] _ -> return [c] -- Taken from json package by Sigbjorn Finne. decodeJson :: String -> JMParser String decodeJson x = parseIt [] x where parseIt rs cs = case cs of '\\' : c : ds -> esc rs c ds c : ds | c >= '\x20' && c <= '\xff' -> parseIt (c:rs) ds | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ x | 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 '\\' -> 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,"")] -> parseIt (toEnum n : rs) cs' 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] --tricky bit to deal with regex literals and comments / / -- if we hit // inside, then we fail, since that isn't ending the regex but introducing a comment, and thus the initial / could not have introduced a regex. regexLiteral :: JMParser String regexLiteral = do _ <- char '/' x <- concat <$> many myChar _ <- char '/' b <- option False (char '/' >> return True) if b then mzero else return x where myChar = do c <- noneOf ['/','\n'] case c of '\\' -> do c2 <- anyChar return [c,c2] _ -> return [c] jmacro-0.6.8/Language/Javascript/JMacro/TypeCheck.hs0000644000000000000000000011641012155151001020377 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, PatternGuards, RankNTypes #-} module Language.Javascript.JMacro.TypeCheck where import Language.Javascript.JMacro.Base import Language.Javascript.JMacro.Types import Control.Applicative import Control.Monad import Control.Monad.Identity import Control.Monad.State import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Error import Data.Either import Data.Map (Map) import Data.Maybe(catMaybes) 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.Leijen.Text hiding ((<$>)) -- Utility eitherIsLeft :: Either a b -> Bool eitherIsLeft (Left _) = True eitherIsLeft _ = False partitionOut :: (a -> Maybe b) -> [a] -> ([b],[a]) partitionOut f xs' = foldr go ([],[]) xs' where go x ~(bs,as) | Just b <- f x = (b:bs,as) | otherwise = (bs,x:as) zipWithOrChange :: (a -> a -> b) -> (a -> b) -> [a] -> [a] -> [b] zipWithOrChange f g xss yss = go xss yss where go (x:xs) (y:ys) = f x y : go xs ys go xs@(_:_) _ = map g xs go _ ys = map g ys zipWithOrIdM :: Monad m => (a -> a -> m a) -> [a] -> [a] -> m [a] zipWithOrIdM f xs ys = sequence $ zipWithOrChange f return xs ys unionWithM :: (Monad m, Ord key) => (val -> val -> m val) -> Map key val -> Map key val -> m (Map key val) unionWithM f m1 m2 = T.sequence $ M.unionWith (\xm ym -> join $ liftM2 f xm ym) (M.map return m1) (M.map return m2) 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) deriving Show {- -- | SVFreshType Int -} data TCState = TCS {tc_env :: [Map Ident JType], tc_vars :: Map Int StoreVal, tc_stack :: [Set Int], tc_frozen :: Set Int, tc_varCt :: Int, tc_context :: [TMonad String]} instance Show TCState where show (TCS env vars stack frozen varCt cxt) = "env: " ++ show env ++ "\n" ++ "vars: " ++ show vars ++ "\n" ++ "stack: " ++ show stack ++ "\n" ++ "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) instance Applicative TMonad where pure = return (<*>) = ap class JTypeCheck a where typecheck :: a -> TMonad JType evalTMonad :: TMonad a -> Either String a evalTMonad (TMonad x) = evalState (runErrorT x) tcStateEmpty runTMonad :: TMonad a -> (Either String a, TCState) runTMonad (TMonad x) = runState (runErrorT x) tcStateEmpty withContext :: TMonad a -> TMonad String -> TMonad a withContext act cxt = do cs <- tc_context <$> get modify (\s -> s {tc_context = cxt : cs}) res <- act modify (\s -> s {tc_context = cs}) return res traversem_ :: (F.Foldable t, Monad f) => (a -> f b) -> t a -> f () traversem_ f = F.foldr ((>>) . f) (return ()) --assums x is resolved freeVarsWithNames :: JType -> TMonad (Map Int String) freeVarsWithNames x = intsToNames . (\(a,_,_) -> a) <$> execStateT (go x) (M.empty, S.empty, 0) where 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 = composOpM1_ go v handleVR (mbName, ref) = do (m,ns,ct) <- get case M.lookup ref m of Just (Left _) -> return () Just (Right _) -> case mbName of Just name -> putName name ref Nothing -> return () Nothing -> do case mbName of Just name -> putName name ref Nothing -> put (M.insert ref (Right ct) m, ns, ct + 1) mapM_ (go . fromC) =<< lift (lookupConstraintsList (mbName, ref)) putName n ref = do (m,ns,ct) <- get 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' where n' | i == 0 = n | otherwise = n ++ show i fromC (Sub t) = t fromC (Super t) = t intsToNames x = fmap (either id go) x where go i = mkUnique (S.fromList $ lefts $ M.elems x) (int2Name i) 0 int2Name i | q == 0 = [letter] | otherwise = letter : show q 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 = composOp1 replaceNames v fixRef (_,ref) = (M.lookup ref names, ref) prettyConstraints ref = map go <$> lookupConstraintsList (Nothing, ref) where myName = case M.lookup ref names of Just n -> n Nothing -> "t_"++show ref go (Sub t) = myName ++ " <: " ++ (show $ jsToDoc $ replaceNames t) go (Super t) = (show $ jsToDoc $ replaceNames t) ++ " <: " ++ myName constraintStrings <- nub . concat <$> mapM prettyConstraints (M.keys names) let constraintStr | null constraintStrings = "" | otherwise = "(" ++ intercalate ", " constraintStrings ++ ") => " return $ constraintStr ++ (show . jsToDoc $ replaceNames xt) tyErr0 :: String -> TMonad a tyErr0 x = throwError x tyErr1 :: String -> JType -> TMonad b tyErr1 s t = do st <- prettyType t throwError $ s ++ ": " ++ st tyErr2ext :: String -> String -> String -> JType -> JType -> TMonad a tyErr2ext s s1 s2 t t' = do st <- prettyType t st' <- prettyType t' throwError $ s ++ ". " ++ s1 ++ ": " ++ st ++ ", " ++ s2 ++ ": " ++ st' tyErr2Sub :: JType -> JType -> TMonad a tyErr2Sub t t' = tyErr2ext "Couldn't apply subtype relation" "Subtype" "Supertype" t t' 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 setFrozen . S.unions . tc_stack =<< get tryCloseFrozenVars return r handler e = do cxt <- tc_context <$> get throwError =<< (unlines . (e:) <$> sequence cxt) -- 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] newVarRef :: TMonad VarRef newVarRef = do v <- tc_varCt <$> get modify (\s -> s {tc_varCt = v + 1, tc_stack = addToStack v (tc_stack s)}) return $ (Nothing, v) newTyVar :: TMonad JType newTyVar = JTFree <$> newVarRef mapConstraint :: (Monad m, Functor m) => (JType -> m JType) -> Constraint -> m Constraint 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 partitionCs (Super t:cs) = (subs,t:sups) where (subs,sups) = partitionCs cs --add mutation lookupConstraintsList :: VarRef -> TMonad [Constraint] lookupConstraintsList vr@(_,ref) = do vars <- tc_vars <$> get case M.lookup ref vars of (Just (SVConstrained cs)) -> filter notLoop . nub <$> mapM (mapConstraint resolveType) (S.toList cs) (Just (SVType t)) -> tyErr1 "lookupConstraints on instantiated type" t Nothing -> return [] where notLoop (Super (JTFree (_,ref'))) | ref == ref' = False notLoop (Sub (JTFree (_,ref'))) | ref == ref' = False notLoop _ = True -- if we instantiate a var to itself, then there's a good chance this results from a looping constraint -- we should be helpful and get rid of any such constraints. instantiateVarRef :: VarRef -> JType -> TMonad () instantiateVarRef vr@(_,ref) (JTFree (_,ref')) | ref == ref' = do cs <- lookupConstraintsList vr let cs' = simplify cs modify (\s -> s {tc_vars = M.insert ref (SVConstrained (S.fromList cs')) (tc_vars s)}) where simplify (Sub (JTFree (_,r)):cs) | r == ref = cs simplify (Super (JTFree (_,r)):cs) | r == ref = cs simplify (c:cs) = c : simplify cs simplify x = x instantiateVarRef vr@(_,ref) t = do occursCheck ref t cs <- lookupConstraintsList vr modify (\s -> s {tc_vars = M.insert ref (SVType t) (tc_vars s)}) checkConstraints t cs occursCheck :: Int -> JType -> TMonad () occursCheck ref (JTFree (_,i)) | i == ref = tyErr1 "Occurs check: cannot construct infinite type" (JTFree (Nothing,i)) occursCheck ref x = composOpM1_ (occursCheck ref) x checkConstraints :: JType -> [Constraint] -> TMonad () checkConstraints t cs = mapM_ go cs where go (Sub t2) = t <: t2 go (Super t2) = t2 <: t addConstraint :: VarRef -> Constraint -> TMonad () addConstraint vr@(_,ref) c = case c of Sub t -> case t of JTFree _ -> addC c JTForall vars t -> normalizeConstraints . (c : ) =<< lookupConstraintsList vr JTFunc args res -> do mapM_ (occursCheck ref) (res:args) normalizeConstraints . (c :) =<< lookupConstraintsList vr JTRecord t m -> occursCheck ref t >> F.mapM_ (occursCheck ref) m >> addRecConstraint (Left (m,t)) JTList t' -> do vr' <- newVarRef addConstraint vr' (Sub t') instantiateVarRef vr (JTList (JTFree vr')) JTMap t' -> do vr' <- newVarRef addConstraint vr' (Sub t') instantiateVarRef vr (JTMap (JTFree vr')) JTRigid _ cs -> do (subs,sups) <- partitionCs <$> lookupConstraintsList vr let (subs1,sups1) = partitionCs $ S.toList cs when ((null sups1 && (not . null) sups) || (null subs1 && (not . null) subs)) $ tyErr2Sub (JTFree vr) t mapM_ (uncurry (<:)) [(x,y) | x <- subs, y <- subs1] mapM_ (uncurry (<:)) [(y,x) | x <- sups, y <- sups1] modify (\s -> s {tc_vars = M.insert ref (SVType t) (tc_vars s)}) --can all this be subsumed by a call to instantiate varref and casing on jtrigid carefully in the <: relationship? -- a polymorphic var is a subtype of another if it is "bigger" on the lattice -- its subtypes are lower and supertypes are higher. sups a > sups b, subs a < subs b _ -> instantiateVarRef vr t Super t -> case t of JTFree _ -> addC c JTForall vars t -> normalizeConstraints . (c : ) =<< lookupConstraintsList vr JTFunc args res -> do mapM_ (occursCheck ref) (res:args) normalizeConstraints . (c :) =<< lookupConstraintsList vr JTRecord t m -> occursCheck ref t >> F.mapM_ (occursCheck ref) m >> addRecConstraint (Right (m,t)) JTList t' -> do vr' <- newVarRef addConstraint vr' (Super t') instantiateVarRef vr (JTList (JTFree vr')) JTMap t' -> do vr' <- newVarRef addConstraint vr' (Super t') instantiateVarRef vr (JTMap (JTFree vr')) JTRigid _ cs -> do (subs,sups) <- partitionCs <$> lookupConstraintsList vr let (subs1,sups1) = partitionCs $ S.toList cs when ((null sups1 && (not . null) sups) || (null subs1 && (not . null) subs)) $ tyErr2Sub (JTFree vr) t mapM_ (uncurry (<:)) [(y,x) | x <- subs, y <- subs1] mapM_ (uncurry (<:)) [(x,y) | x <- sups, y <- sups1] modify (\s -> s {tc_vars = M.insert ref (SVType t) (tc_vars s)}) --can all this be subsumed by a call to instantiate varref and casing on jtrigid carefully in the <: relationship? -- a polymorphic var is a subtype of another if it is "bigger" on the lattice -- its subtypes are lower and supertypes are higher. sups a > sups b, subs a < subs b _ -> instantiateVarRef vr t where putCs cs = modify (\s -> s {tc_vars = M.insert ref (SVConstrained $ S.fromList $ cs) (tc_vars s)}) addC constraint = do cs <- lookupConstraintsList vr modify (\s -> s {tc_vars = M.insert ref (SVConstrained (S.fromList $ constraint:cs)) (tc_vars s)}) findRecordSubs cs = partitionOut go cs where go (Sub (JTRecord t m)) = Just (m,t) go _ = Nothing findRecordSups cs = partitionOut go cs where go (Super (JTRecord t m)) = Just (m,t) go _ = Nothing --left is sub, right is super --There really should be at most one existing sub and sup constraint addRecConstraint eM = do (subs,restCs) <- findRecordSubs <$> lookupConstraintsList vr let (sups,restCs') = findRecordSups restCs mergeSubs [] = return Nothing mergeSubs [m] = return $ Just m mergeSubs (m:ms) = Just <$> foldM (\(mp,t) (mp',t') -> do mp'' <- unionWithM (\x y -> someLowerBound [x,y]) mp mp' t'' <- someLowerBound [t,t'] return (mp'',t'') ) m ms mergeSups [] = return Nothing mergeSups [m] = return $ Just m mergeSups (m:ms) = Just <$> foldM (\(mp,t) (mp',t') -> do mp'' <- intersectionWithM (\x y -> someUpperBound [x,y]) mp mp' t'' <- someUpperBound [t,t'] return (mp'',t'') ) m ms mbSub <- mergeSubs $ case eM of Left mt -> mt : subs _ -> subs mbSup <- mergeSups $ case eM of Right mt -> mt : sups _ -> sups normalizeConstraints =<< case (mbSub, mbSup) of (Just (subm,subt), Just (supm,supt)) -> do when (not $ M.isSubmapOfBy (\_ _ -> True) subm supm) $ tyErr2ext "Incompatible constraints" "Subtype constraint" "Supertype constraint" (JTRecord subt subm) (JTRecord supt supm) _ <- intersectionWithM (\x y -> y <: x) subm supm _ <- supt <: subt return $ Sub (JTRecord subt subm) : Super (JTRecord supt supm) : restCs' (Just (subm,subt), Nothing) -> return $ Sub (JTRecord subt subm) : restCs' (Nothing , Just (supm,supt)) -> return $ Super (JTRecord supt supm) : restCs' _ -> return restCs' --There really should be at most one existing sub and sup constraint normalizeConstraints cl = putCs =<< cannonicalizeConstraints cl cannonicalizeConstraints :: [Constraint] -> TMonad [Constraint] cannonicalizeConstraints constraintList = do -- trace ("ccl: " ++ show constraintList) $ return () let (subs,restCs) = findForallSubs constraintList (sups,restCs') = findForallSups restCs mbSub <- mergeSubs subs mbSup <- mergeSups sups case (mbSub, mbSup) of (Just sub, Just sup) -> do sup <: sub return $ Sub sub : Super sup : restCs' (Just sub, Nothing) -> return $ Sub sub : restCs' (Nothing , Just sup) -> return $ Super sup : restCs' _ -> return restCs' where findForallSubs cs = partitionOut go cs where go (Sub (JTForall vars t)) = Just (vars,t) go (Sub (JTFree _)) = Nothing go (Sub x) = Just ([],x) go _ = Nothing findForallSups cs = partitionOut go cs where go (Super (JTForall vars t)) = Just (vars,t) go (Super (JTFree _)) = Nothing go (Super x) = Just ([],x) go _ = Nothing findFuncs cs = partitionOut go cs where go (JTFunc args ret) = Just (args, ret) go _ = Nothing mergeSubs [] = return Nothing mergeSubs [([],t)] = return $ Just $ t mergeSubs [s] = return $ Just $ uncurry JTForall s mergeSubs ss = do rt <- newTyVar (_,frame) <- withLocalScope $ do instantiatedTypes <- mapM (uncurry instantiateScheme) ss let (funcTypes, otherTypes) = findFuncs instantiatedTypes when (not . null $ funcTypes) $ do let (argss,rets) = unzip funcTypes lft = length funcTypes args' <- mapM someUpperBound $ filter ((== lft) . length) $ transpose argss ret' <- someLowerBound rets rt <: JTFunc args' ret' mapM_ (rt <:) otherTypes -- ((args',ret'):_,o:_) -> tyErr2ext "Incompatible Subtype Constraints" "Subtype constraint" "Subtype constraint" (JTFunc args' ret') o rt' <- resolveType rt case rt' of (JTFunc args res) -> do freeVarsInArgs <- S.unions <$> mapM freeVars args freeVarsInRes <- freeVars res setFrozen $ frame `S.difference` (freeVarsInArgs `S.intersection` freeVarsInRes) _ -> setFrozen frame -- tryCloseFrozenVars Just <$> resolveType (JTForall (frame2VarRefs frame) rt') mergeSups [] = return Nothing mergeSups [([],t)] = return $ Just $ t mergeSups [s] = return $ Just $ uncurry JTForall s mergeSups ss = do rt <- newTyVar (_,frame) <- withLocalScope $ do instantiatedTypes <- mapM (uncurry instantiateScheme) ss let (funcTypes, otherTypes) = findFuncs instantiatedTypes when (not . null $ funcTypes) $ do let (argss,rets) = unzip funcTypes args' <- mapM someLowerBound $ transpose argss ret' <- someUpperBound rets rt <: JTFunc args' ret' mapM_ (<: rt) otherTypes -- ((args',ret'):_,o:_) -> tyErr2ext "Incompatible Supertype Constraints" "Supertype constraint" ("Supertype constraint" ++ show o) (JTFunc args' ret') o rt' <- resolveType rt case rt' of (JTFunc args res) -> do freeVarsInArgs <- S.unions <$> mapM freeVars args freeVarsInRes <- freeVars res setFrozen $ frame `S.difference` (freeVarsInArgs `S.intersection` freeVarsInRes) _ -> setFrozen frame -- tryCloseFrozenVars Just <$> resolveType (JTForall (frame2VarRefs frame) rt') tryCloseFrozenVars :: TMonad () tryCloseFrozenVars = runReaderT (loop . tc_frozen =<< get) [] where loop frozen = do mapM_ go $ S.toList frozen newFrozen <- tc_frozen <$> lift get if S.null (newFrozen `S.difference` frozen) then return () else loop newFrozen go :: Int -> ReaderT [Either Int Int] TMonad () go i = do s <- ask case findLoop i s of -- if no set is returned, then that means we just return (i.e. the constraint is dull) Just Nothing -> return () -- if a set is returned, then all vars in the set should be tied together Just (Just vrs) -> unifyGroup vrs Nothing -> do t <- lift $ resolveTypeShallow (JTFree (Nothing, i)) case t of (JTFree vr) -> do l <- tryClose vr case l of [] -> return () cl -> do mapM_ (go' vr) cl lift (mapM_ (mapConstraint resolveType) cl) -- not clear if we need to call again. if we resolve any constraints, they should point us back upwards... --if cl remains free, recannonicalize it? _ -> return () -- Left is super, right is sub go' (_,ref) (Sub (JTFree (_,i))) | i == ref = return () | otherwise = -- trace (show ("super: " ++ show (ref,i))) $ local (\s -> Left ref : s) $ go i go' (_,ref) (Super (JTFree (_,i))) | i == ref = return () | otherwise = -- trace (show ("sub: " ++ show (ref,i))) $ local (\s -> Right ref : s) $ go i go' _ _ = return () 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 = eitherIsLeft c go accum (r:rs) | 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 | 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 findLoop i [] = Nothing tryClose vr@(_,i) = do cl <- lift$ cannonicalizeConstraints =<< lookupConstraintsList vr -- trace ("tryclose: " ++ show vr) $ trace (show cl) $ return () case partitionCs cl of (_,[s]) -> lift (instantiateVarRef vr s) >> go i >> return [] -- prefer lower bound (supertype constraint) ([s],_) -> lift (instantiateVarRef vr s) >> go i >> return [] _ -> return cl -- Manipulating the environment withLocalScope :: TMonad a -> TMonad (a, Set Int) withLocalScope act = do modify (\s -> s {tc_env = M.empty : tc_env s, tc_stack = S.empty : tc_stack s}) res <- act frame <- head . tc_stack <$> get modify (\s -> s {tc_env = drop 1 $ tc_env s, tc_stack = drop 1 $ tc_stack s}) return (res, frame) setFrozen :: Set Int -> TMonad () setFrozen x = modify (\s -> s {tc_frozen = tc_frozen s `S.union` x}) -- 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 () addEnv ident typ = do envstack <- tc_env <$> get case envstack of (e:es) -> modify (\s -> s {tc_env = M.insert ident typ e : es}) -- we clobber/shadow var names _ -> throwError "empty env stack (this should never happen)" newVarDecl :: Ident -> TMonad JType newVarDecl ident = do v <- newTyVar addEnv ident v return v resolveTypeGen :: ((JType -> TMonad JType) -> JType -> TMonad JType) -> JType -> TMonad JType resolveTypeGen f typ = go typ where go :: JType -> TMonad JType go x@(JTFree (_, ref)) = do vars <- tc_vars <$> get case M.lookup ref vars of Just (SVType t) -> do res <- go t when (res /= t) $ modify (\s -> s {tc_vars = M.insert ref (SVType res) $ tc_vars s}) --mutation, shortcuts pointer chasing return res _ -> return x -- | Eliminates resolved vars from foralls, eliminates empty foralls. go (JTForall refs t) = do refs' <- catMaybes <$> mapM checkRef refs if null refs' then go t else JTForall refs' <$> go t go x = f go x checkRef x@(_, ref) = do vars <- tc_vars <$> get case M.lookup ref vars of Just (SVType t) -> return Nothing _ -> return $ Just x resolveType = resolveTypeGen composOpM1 resolveTypeShallow = resolveTypeGen (const return) --TODO create proper bounds for records integrateLocalType :: JLocalType -> TMonad JType integrateLocalType (env,typ) = do (r, frame) <- withLocalScope $ flip evalStateT M.empty $ do mapM_ integrateEnv env cloneType typ resolveType $ JTForall (frame2VarRefs frame) r where getRef (mbName, ref) = do m <- get case M.lookup ref m of Just newTy -> return newTy Nothing -> do newTy <- (\x -> JTFree (mbName, snd x)) <$> lift newVarRef put $ M.insert ref newTy m return newTy integrateEnv (vr,c) = do newTy <- getRef vr case c of (Sub t) -> lift . (newTy <:) =<< cloneType t (Super t) -> lift . (<: newTy) =<< cloneType t cloneType (JTFree vr) = getRef vr cloneType x = composOpM1 cloneType x lookupEnv :: Ident -> TMonad JType lookupEnv ident = resolveType =<< go . tc_env =<< get where go (e:es) = case M.lookup ident e of Just t -> return t Nothing -> go es go _ = tyErr0 $ "unable to resolve variable name: " ++ (show $ jsToDoc $ ident) freeVars :: JType -> TMonad (Set Int) freeVars t = execWriterT . go =<< resolveType t where go (JTFree (_, ref)) = tell (S.singleton ref) go x = composOpM1_ go x --only works on resolved types instantiateScheme :: [VarRef] -> JType -> TMonad JType instantiateScheme vrs t = evalStateT (go t) M.empty where schemeVars = S.fromList $ map snd vrs go :: JType -> StateT (Map Int JType) TMonad JType go (JTFree vr@(mbName, ref)) | ref `S.member` schemeVars = do m <- get case M.lookup ref m of Just newTy -> return newTy Nothing -> do newRef <- (\x -> (mbName, snd x)) <$> lift newVarRef put $ M.insert ref (JTFree newRef) m mapM_ (lift . addConstraint newRef <=< mapConstraint go) =<< lift (lookupConstraintsList vr) return (JTFree newRef) go x = composOpM1 go x --only works on resolved types instantiateRigidScheme :: [VarRef] -> JType -> TMonad JType instantiateRigidScheme vrs t = evalStateT (go t) M.empty where schemeVars = S.fromList $ map snd vrs go :: JType -> StateT (Map Int JType) TMonad JType go (JTFree vr@(mbName, ref)) | ref `S.member` schemeVars = do m <- get case M.lookup ref m of Just newTy -> return newTy Nothing -> do newRef <- JTRigid vr . S.fromList <$> lift (lookupConstraintsList vr) put $ M.insert ref newRef m return newRef go x = composOpM1 go x --only works on resolved types checkEscapedVars :: [VarRef] -> JType -> TMonad () checkEscapedVars vrs t = go t where vs = S.fromList $ map snd vrs go t@(JTRigid (_,ref) _) | ref `S.member` vs = tyErr1 "Qualified var escapes into environment" t | otherwise = return () go x = composOpM1_ go x -- Subtyping (<:) :: JType -> JType -> TMonad () x <: y = do xt <- resolveTypeShallow x --shallow because subtyping can close yt <- resolveTypeShallow y -- trace ("sub : " ++ show xt ++ ", " ++ show yt) $ return () if xt == yt then return () else go xt yt `withContext` (do xt <- prettyType x yt <- prettyType y return $ "When applying subtype constraint: " ++ xt ++ " <: " ++ yt) where go _ JTStat = return () go JTImpossible _ = return () go xt@(JTFree ref) yt@(JTFree ref2) = addConstraint ref (Sub yt) >> addConstraint ref2 (Super xt) go (JTFree ref) yt = addConstraint ref (Sub yt) go xt (JTFree ref) = addConstraint ref (Super xt) --above or below jtfrees ? -- v <: \/ a. t --> v <: t[a:=x], x not in conclusion go xt yt@(JTForall vars t) = do t' <- instantiateRigidScheme vars t go xt t' checkEscapedVars vars =<< resolveType xt --then check that no fresh types appear in xt -- \/ a. t <: v --> [t] <: v go (JTForall vars t) yt = do t' <- instantiateScheme vars t go t' yt go xt@(JTFunc argsx retx) yt@(JTFunc argsy rety) = do -- TODO: zipWithM_ (<:) (appArgst ++ repeat JTStat) argst -- handle empty args cases when (length argsy < length argsx) $ tyErr2Sub xt yt zipWithM_ (<:) argsy argsx -- functions are contravariant in argument type retx <: rety -- functions are covariant in return type go (JTList xt) (JTList yt) = xt <: yt go (JTMap xt) (JTMap yt) = xt <: yt go (JTRecord xt xm) (JTRecord yt ym) | 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 someUpperBound [] = return JTStat someUpperBound xs = do res <- newTyVar b <- (mapM_ (<: res) xs >> return True) `catchError` \e -> return False if b then return res else return JTStat someLowerBound :: [JType] -> TMonad JType someLowerBound [] = return JTImpossible someLowerBound xs = do res <- newTyVar mapM_ (res <:) xs return res -- 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 return x --todo difft ixing. a[b] --num lookup, a#[b] --string lookup, a.[b] --num literal lookup (i.e. tuple projection) instance JTypeCheck JExpr where typecheck (ValExpr e) = typecheck e typecheck (SelExpr e (StrI i)) = do et <- typecheck e case et of (JTRecord t m) -> case M.lookup i m of Just res -> return res Nothing -> tyErr1 ("Record contains no field named " ++ show i) et -- record extension would go here (JTFree r) -> do res <- newTyVar addConstraint r (Sub (JTRecord res (M.singleton i res))) return res _ -> tyErr1 "Cannot use record selector on this value" et typecheck (IdxExpr e e1) = undefined --this is tricky typecheck (InfixExpr s e e1) | s `elem` ["-","/","*"] = setFixed JTNum >> return JTNum | s == "+" = setFixed JTNum >> return JTNum -- `orElse` setFixed JTStr --TODO: Intersection types | s == "++" = setFixed JTString >> return JTString | s `elem` [">","<"] = setFixed JTNum >> return JTBool | s `elem` ["==","/="] = do et <- typecheck e e1t <- typecheck e1 _ <- et =.= e1t return JTBool | s `elem` ["||","&&"] = setFixed JTBool >> return JTBool | otherwise = throwError $ "Unhandled operator: " ++ s where setFixed t = do typecheck e <<:> return t typecheck e1 <<:> return t typecheck (PPostExpr _ _ e) = case e of (SelExpr _ _) -> go (ValExpr (JVar _)) -> go (IdxExpr _ _) -> go _ -> tyErr1 "Value not compatible with postfix assignment" =<< typecheck e where go = (typecheck e <<:> return JTNum) >> return JTNum typecheck (IfExpr e e1 e2) = do typecheck e <<:> return JTBool join $ liftA2 (\x y -> someUpperBound [x,y]) (typecheck e1) (typecheck e2) typecheck (NewExpr e) = undefined --yipe --when we instantiate a scheme, all the elements of the head --that are not in the tail are henceforth unreachable and can be closed --but that's just an optimization typecheck (ApplExpr e appArgse) = do et <- typecheck e appArgst <- mapM typecheck appArgse let go (JTForall vars t) = go =<< instantiateScheme vars t go (JTFunc argst rett) = do zipWithM_ (<:) (appArgst ++ repeat JTStat) argst return rett go (JTFree vr) = do ret <- newTyVar addConstraint vr (Sub (JTFunc appArgst ret)) return ret go x = tyErr1 "Cannot apply value as function" x go et typecheck (UnsatExpr _) = undefined --saturate (avoiding creation of existing ids) then typecheck typecheck (AntiExpr s) = fail $ "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) | forceType = integrateLocalType t | otherwise = do t1 <- integrateLocalType t typecheck e <<:> return t1 return t1 instance JTypeCheck JVal where typecheck (JVar i) = case i of StrI "true" -> return JTBool StrI "false" -> return JTBool StrI "null" -> newTyVar StrI _ -> lookupEnv i typecheck (JInt _) = return JTNum typecheck (JDouble _) = return JTNum typecheck (JStr _) = return JTString 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 mp' <- T.mapM typecheck mp t <- if M.null mp' then return JTImpossible else someUpperBound $ M.elems mp' return $ JTRecord t mp' typecheck (JFunc args body) = do ((argst',res'), frame) <- withLocalScope $ do argst <- mapM newVarDecl args res <- typecheck body return (argst,res) rt <- resolveType $ JTFunc argst' res' freeVarsInArgs <- S.unions <$> mapM freeVars argst' freeVarsInRes <- freeVars res' setFrozen $ frame `S.difference` (freeVarsInArgs `S.intersection` freeVarsInRes) tryCloseFrozenVars resolveType $ JTForall (frame2VarRefs frame) rt typecheck (UnsatVal _) = undefined --saturate (avoiding creation of existing ids) then typecheck instance JTypeCheck JStat where typecheck (DeclStat ident Nothing) = newVarDecl ident >> return JTStat typecheck (DeclStat ident (Just t)) = integrateLocalType t >>= addEnv ident >> return JTStat typecheck (ReturnStat e) = typecheck e 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 e <<:> return JTBool typecheck s typecheck (ForInStat _ _ _ _) = undefined -- yipe! typecheck (SwitchStat e xs d) = undefined -- check e, unify e with firsts, check seconds, take glb of seconds --oh, hey, add typecase to language!? typecheck (TryStat _ _ _ _) = undefined -- should be easy typecheck (BlockStat xs) = do ts <- mapM typecheckWithBlock xs someUpperBound $ stripStat ts where stripStat (JTStat:ts) = stripStat ts stripStat (t:ts) = t : stripStat ts stripStat t = t typecheck (ApplStat args body) = typecheck (ApplExpr args body) >> return JTStat typecheck (PPostStat b s e) = typecheck (PPostExpr b s e) >> return JTStat typecheck (AssignStat e e1) = do typecheck e1 <<:> typecheck e return JTStat typecheck (UnsatBlock _) = undefined --oyvey typecheck (AntiStat _) = undefined --oyvey typecheck (BreakStat _) = return JTStat typecheck (ForeignStat i t) = integrateLocalType t >>= addEnv i >> return JTStat typecheckWithBlock :: (JsToDoc a, JMacro a, JTypeCheck a) => a -> TMonad JType typecheckWithBlock stat = typecheck stat `withContext` (return $ "In statement: " ++ (T.unpack . displayT . renderCompact $ renderJs stat)) jmacro-0.6.8/Language/Javascript/JMacro/Types.hs0000644000000000000000000001176212155151001017630 0ustar0000000000000000{-# Language StandaloneDeriving, DeriveDataTypeable, FlexibleContexts, UndecidableInstances, FlexibleInstances #-} module Language.Javascript.JMacro.Types ( JType(..), Constraint(..), JLocalType, VarRef, anyType, parseType, runTypeParser ) where import Control.Applicative hiding ((<|>)) import Data.Char import Data.Maybe(fromMaybe) import Text.ParserCombinators.Parsec import Text.Parsec.Prim hiding (runParser, try) import Text.ParserCombinators.Parsec.Language(emptyDef) import qualified Text.ParserCombinators.Parsec.Token as P import qualified Data.Map as M import Data.Map (Map) import Data.Set (Set) import Data.Generics type VarRef = (Maybe String, Int) -- sum types for list/record, map/record data JType = JTNum | JTString | JTBool | JTStat | JTFunc [JType] (JType) | JTList JType | JTMap JType | JTRecord JType (Map String JType) | JTRigid VarRef (Set Constraint) | JTImpossible | JTFree VarRef | JTForall [VarRef] JType deriving (Eq, Ord, Read, Show, Typeable, Data) data Constraint = Sub JType | Super JType deriving (Eq, Ord, Read, Show, Typeable, Data) {- | Choice Constraint Constraint | GLB (Set JType) | LUB (Set JType) -} type JLocalType = ([(VarRef,Constraint)], JType) type TypeParserState = (Int, Map String Int) type TypeParser a = CharParser TypeParserState a typLang :: P.LanguageDef TypeParserState typLang = emptyDef { P.reservedNames = ["()","->"], P.reservedOpNames = ["()","->","::"], P.identLetter = alphaNum <|> oneOf "_$", P.identStart = letter <|> oneOf "_$" } lexer :: P.TokenParser TypeParserState lexer = P.makeTokenParser typLang 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 identifier= P.identifier lexer reservedOp= P.reservedOp lexer commaSep1 = P.commaSep1 lexer commaSep = P.commaSep lexer lexeme = P.lexeme lexer 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 withLocalState initState subParser = mkPT $ \(State input pos otherState) -> fixState otherState <$> runParsecT subParser (State input pos initState) where fixState s res = (fmap . fmap) go res where go (Ok a (State input pos _localState) pe) = Ok a (State input pos s) pe go (Error e) = (Error e) constrainedType :: TypeParser JLocalType constrainedType = do c <- try (Just <$> (constraintHead <* reservedOp "=>")) <|> return Nothing t <- anyType return (fromMaybe [] c, t) --do we need to read supertype constraints, i.e. subtype constraints which have the freevar on the right?? constraintHead :: TypeParser [(VarRef,Constraint)] constraintHead = parens go <|> go where go = commaSep1 constraint constraint = do r <- freeVarRef =<< identifier c <- (reservedOp "<:" >> (return Sub)) <|> (reservedOp ":>" >> (return Super)) t <- anyType return $ (r, c t) anyType :: TypeParser JType anyType = try (parens anyType) <|> funOrAtomType <|> listType <|> recordType funOrAtomType :: TypeParser JType funOrAtomType = do r <- anyNestedType `sepBy1` (lexeme (string "->")) return $ case reverse r of [x] -> x (x:xs) -> JTFunc (reverse xs) x _ -> error "funOrAtomType" listType :: TypeParser JType listType = JTList <$> brackets anyType anyNestedType :: TypeParser JType anyNestedType = nullType <|> parens anyType <|> atomicType <|> listType <|> recordType nullType :: TypeParser JType nullType = reservedOp "()" >> return JTStat atomicType :: TypeParser JType atomicType = do a <- identifier case a of "Num" -> return JTNum "String" -> return JTString "Bool" -> return JTBool (x:_) | isUpper x -> fail $ "Unknown type: " ++ a | otherwise -> JTFree <$> freeVarRef a _ -> error "typeAtom" recordType :: TypeParser JType recordType = braces $ JTRecord JTImpossible . M.fromList <$> commaSep namePair where namePair = do n <- identifier reservedOp "::" t <- anyType return (n, t) freeVarRef :: String -> TypeParser VarRef freeVarRef v = do (i,m) <- getState (\x -> (Just v, x)) <$> maybe (setState (i+1,M.insert v i m) >> return i) return (M.lookup v m) jmacro-0.6.8/Language/Javascript/JMacro/Util.hs0000644000000000000000000000274012155151001017435 0ustar0000000000000000module Language.Javascript.JMacro.Util where import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read, (<), (&&)) import qualified Prelude as P import Language.Javascript.JMacro.Base (.) :: JExpr -> String -> JExpr x . y = SelExpr x (StrI y) (<>) :: (ToJExpr a) => JExpr -> a -> JExpr x <> y = IdxExpr x (toJExpr y) infixl 2 =: (=:) :: ToJExpr a => JExpr -> a -> JStat x =: y = AssignStat x (toJExpr y) ($) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr x $ y = ApplExpr (toJExpr x) (toJExprList y) ($$) :: (ToJExpr a, ToJExpr b) => a -> b -> JStat x $$ y = ApplStat (toJExpr x) (toJExprList y) (==), (!=), (<), (&&) :: JExpr -> JExpr -> JExpr x == y = InfixExpr "==" x y x != y = InfixExpr "!=" x y infix 4 < x < y = InfixExpr "<" x y infixr 3 && x && y = InfixExpr "&&" x y null :: JExpr null = jsv "null" new :: ToJExpr a => a -> JExpr new x = NewExpr (toJExpr x) if' :: (ToJExpr a, ToStat b) => a -> b -> JStat if' x y = IfStat (toJExpr x) (toStat y) (BlockStat []) ifElse :: (ToJExpr a, ToStat b, ToStat c) => a -> b -> c -> JStat ifElse x y z = IfStat (toJExpr x) (toStat y) (toStat z) while :: ToJExpr a => a -> JStat -> JStat while x y = WhileStat False (toJExpr x) y return :: ToJExpr a => a -> JStat return x = ReturnStat (toJExpr x) toJExprList :: ToJExpr a => a -> [JExpr] toJExprList x = case toJExpr x of (ValExpr (JList l)) -> l x' -> [x'] jstr :: P.String -> JExpr jstr = ValExpr P.. JStr