jmacro (empty) → 0.1
raw patch · 8 files changed
+2667/−0 lines, 8 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, haskell-src-meta, mtl, parsec, pretty, safe, template-haskell
Files
- LICENSE +27/−0
- Language/Javascript/JMacro.hs +74/−0
- Language/Javascript/JMacro/Base.hs +547/−0
- Language/Javascript/JMacro/QQ.hs +584/−0
- Language/Javascript/JMacro/Typed.hs +1342/−0
- Language/Javascript/JMacro/Util.hs +63/−0
- Setup.hs +2/−0
- jmacro.cabal +28/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (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.
+ Language/Javascript/JMacro.hs view
@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+{- |+Module : Language.Javascript.JMacro+Copyright : (c) Gershom Bazerman, 2009+License : BSD 3 Clause+Maintainer : gershomb@gmail.com+Stability : experimental++Simple DSL for lightweight (untyped) programmatic generation of Javascript.++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++> \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.++Additional datatypes can be marshalled to Javascript by proper instance declarations for the ToJExpr class.++An experimental typechecker is available in the Typed module.++-}+-----------------------------------------------------------------------------++module Language.Javascript.JMacro (+ module Language.Javascript.JMacro.Base,+ module Language.Javascript.JMacro.QQ+ ) 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
+ Language/Javascript/JMacro/Base.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, RankNTypes, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts #-}++-----------------------------------------------------------------------------+{- |+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(..),+ -- * Generic traversal (via compos)+ JMacro(..), MultiComp(..), Compos(..),+ composOp, composOpM, composOpM_, composOpFold,+ -- * Hygienic transformation+ withHygiene,+ -- * Display/Output+ renderJs, JsToDoc(..),+ -- * ad-hoc data marshalling+ ToJExpr(..),+ -- * helpful combinators+ jLam, jVar, jFor, jForIn, jForEachIn,+ expr2stat, ToStat(..), nullStat,+ -- * hash combinators+ jhEmpty, jhSingle, jhAdd, jhFromList,+ -- * utility+ jsSaturate+ ) where+import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)+import Control.Applicative hiding (empty)+import Data.Function+import qualified Data.Map as M+import Text.PrettyPrint.HughesPJ+import Control.Monad.State.Strict+import Safe+import Control.Monad.Identity+import Data.Generics++{--------------------------------------------------------------------+ ADTs+--------------------------------------------------------------------}++--switch+--Yield statement?+--destructuring/pattern matching functions --pattern matching in lambdas.+--array comprehensions/generators?+--add postfix stat++-- | Statements+data JStat = DeclStat Ident+ | ReturnStat JExpr+ | IfStat JExpr JStat JStat+ | WhileStat JExpr JStat+ | ForInStat Bool Ident JExpr JStat+ | SwitchStat JExpr [(JExpr, JStat)] JStat+ | BlockStat [JStat]+ | ApplStat JExpr [JExpr]+ | PostStat String JExpr+ | AssignStat JExpr JExpr+ | UnsatBlock (State [Ident] JStat)+ | AntiStat String+ | BreakStat+ deriving (Eq, Ord, Show, Data, Typeable)++-- | Expressions+data JExpr = ValExpr JVal+ | SelExpr JExpr Ident+ | IdxExpr JExpr JExpr+ | InfixExpr String JExpr JExpr+ | PostExpr String JExpr+ | IfExpr JExpr JExpr JExpr+ | NewExpr JExpr+ | ApplExpr JExpr [JExpr]+ | UnsatExpr (State [Ident] JExpr)+ | AntiExpr String+ deriving (Eq, Ord, Show, Data, Typeable)++-- | Values+data JVal = JVar Ident+ | JList [JExpr]+ | JDouble Double+ | JInt Integer+ | JStr String+ | JRegEx String+ | JHash (M.Map String JExpr)+ | JFunc [Ident] JStat+ | UnsatVal (State [Ident] JVal)+ deriving (Eq, Ord, Show, Data, Typeable)++-- | Identifiers+newtype Ident = StrI String deriving (Eq, Ord, Show, Data, Typeable)+++deriving instance Typeable2 State+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 (PostExpr s x) = PostStat s x+expr2stat (AntiExpr x) = AntiStat x+expr2stat _ = nullStat++{--------------------------------------------------------------------+ Compos+--------------------------------------------------------------------}++-- | Utility class to coerce the ADT into a regular structure.+class JMacro a where+ toMC :: a -> MultiComp+ fromMC :: MultiComp -> a++-- | Union type to allow regular traversal by compos.+data MultiComp = MStat JStat | MExpr JExpr | MVal JVal | MIdent Ident deriving Show+++-- | Compos and ops for generic traversal as defined over+-- the JMacro ADT.+class Compos t where+ compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)+ -> (t -> m t) -> t -> m t+++composOp :: Compos t => (t -> t) -> t -> t+composOp f = runIdentity . composOpM (Identity . f)+composOpM :: (Compos t, Monad m) => (t -> m t) -> t -> m t+composOpM = compos return ap+composOpM_ :: (Compos t, Monad m) => (t -> m ()) -> t -> m ()+composOpM_ = composOpFold (return ()) (>>)+composOpFold :: Compos t => b -> (b -> b -> b) -> (t -> b) -> t -> b+composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)+newtype C b a = C { unC :: b }++++instance JMacro Ident where+ toMC = MIdent+ fromMC (MIdent x) = x+ fromMC _ = error "fromMC"++instance JMacro JVal where+ toMC = MVal+ fromMC (MVal x) = x+ fromMC _ = error "fromMC"++instance JMacro JExpr where+ toMC = MExpr+ fromMC (MExpr x) = x+ fromMC _ = error "fromMC"++instance JMacro JStat where+ toMC = MStat+ fromMC (MStat x) = x+ fromMC _ = error "fromMC"++instance JMacro [JStat] where+ toMC = MStat . BlockStat+ fromMC (MStat (BlockStat x)) = x+ fromMC _ = error "fromMC"++instance Compos MultiComp where+ compos ret app f' v = case v of+ MIdent _ -> ret v+ MStat v' -> ret MStat `app` case v' of+ DeclStat i -> ret DeclStat `app` f i+ ReturnStat i -> ret ReturnStat `app` f i+ IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'+ WhileStat e s -> ret WhileStat `app` f e `app` f s+ 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+ PostStat o e -> ret (PostStat o) `app` f e+ AssignStat e e' -> ret AssignStat `app` f e `app` f e'+ UnsatBlock _ -> ret v'+ AntiStat _ -> ret v'+ BreakStat -> ret BreakStat+ MExpr v' -> ret MExpr `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'+ PostExpr o e -> ret (PostExpr 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'+ UnsatExpr _ -> ret v'+ MVal v' -> ret MVal `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' g = foldr (app . app (ret (:)) . g) (ret [])+ f x = ret fromMC `app` f' (toMC x)+++{--------------------------------------------------------------------+ New Identifiers+--------------------------------------------------------------------}++sat_ :: State [Ident] a -> a+sat_ x = evalState x $ newIdentSupply (Just "<<unsatId>>")++instance Eq a => Eq (State [Ident] a) where+ (==) = (==) `on` sat_+instance Ord a => Ord (State [Ident] a) where+ compare = compare `on` sat_+instance Show a => Show (State [Ident] a) where+ show x = "(" ++ show (sat_ x) ++ ")"++class ToSat a where+ toSat_ :: a -> [Ident] -> State [Ident] (JStat, [Ident])++instance ToSat [JStat] where+ toSat_ f vs = return $ (BlockStat f, reverse vs)++instance ToSat JStat where+ toSat_ f vs = return $ (f, reverse vs)++instance ToSat JExpr where+ toSat_ f vs = return $ (expr2stat f, reverse vs)++instance ToSat [JExpr] where+ toSat_ f vs = return $ (BlockStat $ map expr2stat f, reverse vs)++instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where+ toSat_ f vs = do+ x <- takeOne+ toSat_ (f (ValExpr $ JVar x)) (x:vs)++takeOne :: (Monad m, MonadState [b] m) => m b+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'++['_']++{-+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+--------------------------------------------------------------------}++jsSaturate :: (JMacro a) => Maybe String -> a -> a+jsSaturate str x = evalState (jsSaturate_ x) (newIdentSupply str)++jsSaturate_ :: (JMacro a) => a -> State [Ident] a+jsSaturate_ e = fromMC <$> go (toMC e)+ where go v = case v of+ MStat (UnsatBlock us) -> composOpM go =<< (MStat <$> us)+ MExpr (UnsatExpr us) -> composOpM go =<< (MExpr <$> us)+ MVal (UnsatVal us) -> composOpM go =<< (MVal <$> us)+ _ -> composOpM go v++{--------------------------------------------------------------------+ Transformation+--------------------------------------------------------------------}++--doesn't apply to unsaturated bits+jsReplace_ :: JMacro a => [(Ident, Ident)] -> a -> a+jsReplace_ xs e = fromMC $ composOp go (toMC e)+ where go v = case v of+ MIdent i -> maybe v MIdent (M.lookup i mp)+ _ -> composOp go v+ mp = M.fromList xs++--only works on fully saturated things+jsUnsat_ :: JMacro a => [Ident] -> a -> State [Ident] a+jsUnsat_ xs e = 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 = fromMC $ case mx of+ MStat _ -> toMC $ UnsatBlock (coerceMC <$> jsUnsat_ is' x'')+ MExpr _ -> toMC $ UnsatExpr (coerceMC <$> jsUnsat_ is' x'')+ MVal _ -> toMC $ UnsatVal (coerceMC <$> jsUnsat_ is' x'')+ MIdent _ -> toMC $ f x+ where (x', (StrI l:_)) = runState (jsSaturate_ x) is+ x'' = f x'+ is = newIdentSupply (Just "inSat")+ lastVal = readNote "inSat" (drop 6 l) :: Int+ is' = take lastVal is+ mx = toMC x+ coerceMC :: (JMacro a, JMacro b) => a -> b+ coerceMC = fromMC . toMC++{-+jsReplace :: JMacro a => [(Ident, Ident)] -> a -> a+jsReplace xs = withHygiene (jsReplace_ xs)+-}++{--------------------------------------------------------------------+ 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++braceNest :: Doc -> Doc+braceNest x = char '{' $$ nest 2 x $$ char '}'++braceNest' :: Doc -> Doc+braceNest' x = char '{' $+$ nest 2 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 [] = empty+ | otherwise = text "else" $$ braceNest' (jsToDoc y)+ jsToDoc (DeclStat x) = text "var" <+> jsToDoc x+ jsToDoc (WhileStat p b) = text "while" <> parens (jsToDoc p) $$ braceNest' (jsToDoc b)+ jsToDoc (UnsatBlock e) = jsToDoc $ sat_ e+ jsToDoc BreakStat = text "break"+ jsToDoc (ForInStat each i e b) = text txt <> parens (text "var" <+> jsToDoc i <+> text "in" <+> jsToDoc e) $$ braceNest' (jsToDoc b)+ where txt | each = "for each"+ | otherwise = "for"+ jsToDoc (SwitchStat e l d) = text "switch" <+> parens (jsToDoc e) $$ braceNest' cases+ where l' = map (\(c,s) -> text "case" <+> parens (jsToDoc c) <> char ':' $$ nest 2 (jsToDoc [s])) l ++ [text "default:" $$ nest 2 (jsToDoc [d])]+ cases = vcat l'+ jsToDoc (ReturnStat e) = text "return" <+> jsToDoc e+ jsToDoc (ApplStat e es) = jsToDoc e <> (parens . fsep . punctuate comma $ map jsToDoc es)+ jsToDoc (AssignStat i x) = jsToDoc i <+> char '=' <+> jsToDoc x+ jsToDoc (PostStat op x) = jsToDoc x <> text op+ jsToDoc (AntiStat s) = text $ "`(" ++ s ++ ")`"+ jsToDoc (BlockStat xs) = jsToDoc (flattenBlocks xs)+ where flattenBlocks (BlockStat y:ys) = flattenBlocks y ++ flattenBlocks ys+ flattenBlocks (y:ys) = y : flattenBlocks ys+ flattenBlocks [] = []++instance JsToDoc JExpr where+ jsToDoc (ValExpr x) = jsToDoc x+ jsToDoc (SelExpr x y) = cat [jsToDoc x <> char '.', jsToDoc y]+ jsToDoc (IdxExpr x y) = jsToDoc x <> brackets (jsToDoc y)+ jsToDoc (IfExpr x y z) = parens (jsToDoc x <+> char '?' <+> jsToDoc y <+> char ':' <+> jsToDoc z)+ jsToDoc (InfixExpr op x y) = parens $ sep [jsToDoc x, text op, jsToDoc y]+ jsToDoc (PostExpr op x) = jsToDoc x <> text op+ jsToDoc (ApplExpr je xs) = jsToDoc je <> (parens . fsep . punctuate comma $ map jsToDoc xs)+ jsToDoc (NewExpr e) = text "new" <+> jsToDoc e+ jsToDoc (AntiExpr s) = text $ "`(" ++ s ++ ")`"+ jsToDoc (UnsatExpr e) = jsToDoc $ sat_ e++instance JsToDoc JVal where+ jsToDoc (JVar i) = jsToDoc i+ jsToDoc (JList xs) = brackets . fsep . punctuate comma $ map jsToDoc xs+ jsToDoc (JDouble d) = double d+ jsToDoc (JInt i) = integer i+ jsToDoc (JStr s) = text ("\""++s++"\"")+ jsToDoc (JRegEx s) = text ("/"++s++"/")+ jsToDoc (JHash m) = braceNest . fsep . punctuate comma . map (\(x,y) -> quotes (text x) <> colon <+> jsToDoc y) $ M.toList m+ jsToDoc (JFunc is b) = parens $ text "function" <> parens (fsep . punctuate comma . map jsToDoc $ is) $$ braceNest' (jsToDoc b)+ jsToDoc (UnsatVal f) = jsToDoc $ sat_ f++instance JsToDoc Ident where+ jsToDoc (StrI s) = text s++instance JsToDoc [JExpr] where+ jsToDoc = vcat . map ((<> semi) . jsToDoc)++instance JsToDoc [JStat] where+ jsToDoc = vcat . map ((<> semi) . jsToDoc)++{--------------------------------------------------------------------+ 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++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 . escQuotes+ 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 $ do+ (block,is) <- 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 $ do+ (block, is) <- toSat_ f []+ let addDecls (BlockStat ss) =+ BlockStat $ map DeclStat 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 $ do+ (block, is) <- 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 $ do+ (block, is) <- toSat_ f []+ return $ ForInStat True (headNote "jForIn" is) e block++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 (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++nullStat :: JStat+nullStat = BlockStat []
+ Language/Javascript/JMacro/QQ.hs view
@@ -0,0 +1,584 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TemplateHaskell, QuasiQuotes #-}++-----------------------------------------------------------------------------+{- |+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) where+import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)+import Control.Applicative hiding ((<|>),many,optional,(<*))+import Control.Monad.State.Strict+import qualified Data.ByteString.Char8 as BS+import Data.Char(digitToInt, toLower)+import Data.List(isPrefixOf, sort)+import Data.Generics(extQ,Data)+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.PCRE.Light (compileM)++import Language.Javascript.JMacro.Base++-- import Debug.Trace++compileM _ _ = Right "hack"++{--------------------------------------------------------------------+ QuasiQuotation+--------------------------------------------------------------------}++-- | QuasiQuoter for a block of JMacro statements.+jmacro :: QuasiQuoter+jmacro = QuasiQuoter quoteJMExp quoteJMPat++-- | QuasiQuoter for a JMacro expression.+jmacroE :: QuasiQuoter+jmacroE = QuasiQuoter quoteJMExpE 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 = fromMC $ go (toMC e)+ where go (MExpr (ValExpr (JVar (StrI s'))))+ | s == s' = MExpr (AntiExpr s)+ go (MExpr (SelExpr x i)) =+ MExpr (SelExpr (antiIdent s x) i)+ go x = composOp go x++antiIdents :: JMacro a => [String] -> a -> a+antiIdents ss x = foldr antiIdent x ss+++jm2th :: Data a => a -> TH.ExpQ+jm2th v = dataToExpQ (const Nothing+ `extQ` handleStat+ `extQ` handleExpr+ `extQ` handleVal+ ) 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):xs) = case i of+ ('!':i') -> jm2th (DeclStat (StrI i')) : blocks xs+ _ ->+ [TH.appE (TH.varE $ mkName "jVar")+ (TH.lamE [TH.varP . mkName $ i] $+ appConstr "BlockStat"+ (TH.listE $ blocks $ map (antiIdent i) xs))]++ 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 (AntiStat s) = case parseExp 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 parseExp 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) 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++ 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","new","function","switch","case","default","fun"],+ P.reservedOpNames = ["--","*","/","+","-",".","?","=","==","!=","<",">","&&","||","++","===",">=","<=","->"],+ P.identLetter = alphaNum <|> oneOf "_$",+ P.identStart = letter <|> 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++{-+ident :: JMParser Ident+ident = do+ i <- identifier+ when ("jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name."+ return (StrI i)+-}++varidentdecl :: JMParser Ident+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'."+ return (StrI i)+++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)++identAssignDecl :: JMParser [JStat]+identAssignDecl = varidentdecl >>= \i ->+ (do+ reservedOp "="+ e <- expr+ return [DeclStat i, AssignStat (ValExpr (JVar (clean i))) e]+ )+ <|> return [DeclStat i]+ where clean (StrI ('!':x)) = StrI x+ clean x = x++statblock :: JMParser [JStat]+statblock = concat <$> (sepEndBy1 (whiteSpace >> statement) (semi <|> return ""))++l2s :: [JStat] -> JStat+l2s xs = BlockStat xs+++-- return either an expression or a statement+statement :: JMParser [JStat]+statement = declStat+ <|> funDecl+ <|> functionDecl+ <|> returnStat+ <|> ifStat+ <|> whileStat+ <|> switchStat+ <|> forStat+ <|> braces statblock+ <|> assignStat+ <|> applStat+ <|> breakStat+ <|> antiStat+ <?> "statement"+ where+ declStat =+ reserved "var" >> concat <$> commaSep1 identAssignDecl+ -- take assignment++ functionDecl = do+ reserved "function"+ n <- varidentdecl+ as <- parens (commaSep identdecl) <|> many1 identdecl+ b <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement)+ return $ [DeclStat n, AssignStat (ValExpr $ JVar (clean n)) (ValExpr $ JFunc as b)]+ where clean (StrI ('!':x)) = StrI x+ clean x = x++ funDecl = do+ reserved "fun"+ n <- identdecl+ as <- many identdecl+ b <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) <|> (symbol "->" >> ReturnStat <$> expr)+ return $ [DeclStat (addBang n), AssignStat (ValExpr $ JVar n) (ValExpr $ JFunc as b)]+ where addBang (StrI x) = StrI ('!':x)++ returnStat =+ reserved "return" >> (:[]) . ReturnStat <$> expr++ ifStat = do+ reserved "if"+ p <- parens expr+ b <- l2s <$> statement+ isElse <- (lookAhead (reserved "else") >> return True)+ <|> return False+ if isElse+ then do+ reserved "else"+ return . IfStat p b . l2s <$> statement+ else return $ [IfStat p b nullStat]++ whileStat =+ reserved "while" >> liftM2 (\e b -> [WhileStat e (l2s b)])+ (parens expr) statement++ 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)++ dfltStat =+ reserved "default:" >> 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 (,,) (statement)+ (semi >> expr)+ (semi >> statement)+ jFor' :: (ToJExpr a) => [JStat] -> a -> [JStat] -> [JStat] -> [JStat]+ jFor' before p after bs = before ++ [WhileStat (toJExpr p) b']+ where b' = BlockStat $ bs ++ after+++ assignStat = do+ e1 <- try $ dotExpr <* reservedOp "="+ let gofail = fail ("Invalid assignment.")+ case e1 of+ ValExpr (JVar (StrI "this")) -> gofail+ ValExpr (JVar _) -> return ()+ ValExpr _ -> gofail+ _ -> return ()+ e2 <- expr+ return [AssignStat 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 = reserved "break" >> return [BreakStat]++ antiStat = return . AntiStat <$> do+ x <- (try (symbol "`(") >> anyChar `manyTill` try (symbol ")`"))+ either (fail . ("Bad AntiQuotation: \n" ++))+ (const (return x))+ (parseExp x)++--args :: JMParser [JExpr]+--args = parens $ commaSep expr++expr :: JMParser JExpr+expr = do+ e <- expr'+ addIf e <|> return e+ where addIf e = do+ symbol "?"+ t <- expr+ colon+ el <- expr+ let ans = (IfExpr e t el)+ addIf ans <|> return ans++ expr' = buildExpressionParser table dotExpr <?> "expression"++ table = [[iop "*", iop "/"],+ [iop "+", iop "-"],+ [iope "==", iope "!=", iope "<", iope ">",+ iope ">=", iope "<=", iope "==="],+ [iop "&&", iop "||"]+ ]+ iop s = Infix (reservedOp s >> return (InfixExpr s)) AssocLeft+ iope s = Infix (reservedOp s >> return (InfixExpr s)) AssocNone++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 <|> parens' expr <|> notExpr <|> newExpr+ where+ addNxt e = do+ nxt <- (Just <$> lookAhead anyChar <|> return Nothing)+ case nxt of+ Just '.' -> addNxt =<< (dot >> (SelExpr e <$> ident'))+ Just '[' -> addNxt =<< (IdxExpr e <$> brackets' expr)+ Just '(' -> addNxt =<< (ApplExpr e <$> args')+ Just '-' -> try (reservedOp "--" >> return (PostExpr "--" e)) <|> return e+ Just '+' -> try (reservedOp "++" >> return (PostExpr "++" e)) <|> return e+ _ -> return e++ 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))+ (parseExp x)++ valExpr = ValExpr <$> (num <|> negnum <|> str <|> regex <|> list <|> hash <|> func <|> var) <?> "value"+ where num = either JInt JDouble <$> try natFloat+ negnum = either (JInt . negate) (JDouble . negate) <$> try (char '-' >> natFloat)+ str = JStr <$> (myStringLiteral '"' <|> myStringLiteral '\'')+ regex = do+ s <- myStringLiteral '/'+ case compileM (BS.pack s) [] of+ Right _ -> return (JRegEx s)+ Left err -> fail ("Parse error in regexp: " ++ err)+ list = JList <$> brackets' (commaSep expr)+ hash = JHash . M.fromList <$> braces' (commaSep propPair)+ var = JVar <$> ident'+ func = do+ (symbol "\\" >> return ()) <|> reserved "function"+ liftM2 JFunc (parens (commaSep identdecl) <|> many identdecl)+ (braces' statOrEblock <|>+ (symbol "->" >> (ReturnStat <$> expr)))+ 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 ()))+args' :: JMParser [JExpr]+args' = parens $ commaSep expr++--Parsers without Lexeme++braces', brackets', parens' :: JMParser a -> JMParser a+brackets' = around' '[' ']'+braces' = around' '{' '}'+parens' = around' '(' ')'++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+ return x+ where myChar = do+ c <- noneOf [t]+ case c of+ '\\' -> do+ c2 <- anyChar+ return [c,c2]+ '\n' -> return "\\n"+ _ -> return [c]
+ Language/Javascript/JMacro/Typed.hs view
@@ -0,0 +1,1342 @@+{-# LANGUAGE QuasiQuotes, FlexibleInstances #-}+module Language.Javascript.JMacro.Typed where++import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)++import Language.Javascript.JMacro.Base+import Language.Javascript.JMacro.QQ+import Control.Monad+import Control.Monad.State+import Control.Monad.Error+import Control.Applicative+import Data.List (intercalate, deleteFirstsBy, find)+import Data.Function(on)+import qualified Data.Map as M+import Data.Map(Map)+import Data.Maybe+import qualified Data.Set as S+import Data.Set(Set)+import Text.PrettyPrint.HughesPJ+import Debug.Trace+++--todo: collect errors+--pretty types, bump down variable nums+--infer missing vs. assert missing+--type parser+--intersection types+--lists, new/this, extensible records+--flag to automatically introduce new things into environment+--seperate resAtoms function++{--------------------------------------------------------------------+ Main Interface+--------------------------------------------------------------------}++runTypecheck :: JTypeCheck a => a -> IO ()+runTypecheck x = either putStrLn print $ evalState (runErrorT go) tcStateEmpty+ where go = do+ res <- typecheck x+ showenv <- do+ (env:topenv:_) <- tc_env <$> get+ r@(JTRec i) <- newRec+ putRec i (M.toList env)+ r'@(JTRec i') <- newRec+ putRec i' (M.toList topenv)+-- killSats+ s <- showType r+ s' <- prettyType' r'+ pres <- showType res+ return (pres,s,s')+ return showenv++{--------------------------------------------------------------------+ Types+--------------------------------------------------------------------}++data JType = JTNum+ | JTStr+ | JTBool+ | JTRec Int+ | JTFunc [JType] JType+ | JTList (Maybe Int) (Maybe JType) --can be multityped, monotyped, or neither+ --jtint is an index into a record+ | JTStat+ | JTSat Int+ | BotOf JType+ | JTVar Int deriving (Show, Eq)++data JConstr = Sub JType | Super JType deriving Show++--canextend needs scoping, to deal with inner lambdas. oyvey. things can only be extended in the scope that they are introduced in. this scoping should be introduced in a scopedRecs thang+data TCState = TCS {tc_env :: [Map Ident JType],+ tc_vars :: Map Int JType,+ tc_constrs :: Map Int [JConstr],+ tc_recs :: Map Int [(Ident, JType)],+ tc_scopedSat :: [Set Int],+ tc_varCt :: Int,+ tc_strictnull :: Bool,+ tc_canextend :: Bool,+ tc_debug :: Bool,+ tc_expandFree :: Bool} deriving Show++tcStateEmpty :: TCState+tcStateEmpty = TCS [M.empty,M.empty] M.empty M.empty M.empty [S.empty] 0 True True True True+++type JMonad a = ErrorT String (State TCState) a++orElse :: JMonad a -> JMonad a -> JMonad a+x `orElse` y = do+ st <- get+ x `catchError` \e1 -> do+ put st+ y `catchError` \e2 -> do+ throwError $ e1 ++ ",\n" ++ e2++{--------------------------------------------------------------------+ Env utilities+--------------------------------------------------------------------}++--fix to maybe do it, or insert top level+lookupEnvErr :: Ident -> JMonad JType+lookupEnvErr i@(StrI s) = do+ ans <- msum . map (M.lookup i) . tc_env <$> get+ case ans of+ Just x -> return x+ Nothing -> do+ b <- tc_expandFree <$> get+ if b+ then do+ ns <- newTopSat+ addTopEnv i ns+ return ns+ else throwError $ "Variable not in scope: " ++ s++--puts idents in scope, as constrained free variables+withLocalScope :: [Ident] -> JMonad a -> JMonad a+withLocalScope args act = do+ env <- tc_env <$> get+ sats <- tc_scopedSat <$> get+ modify (\tcs -> tcs {tc_scopedSat = S.empty : sats, tc_env = M.empty : env})+ mapM (addNewSat) args+ res <- act+ (_:restSats) <- tc_scopedSat <$> get+ (_:restEnv) <- tc_env <$> get+ modify (\tcs -> tcs {tc_env = restEnv, tc_scopedSat = restSats})+ return res++--puts idents in scope, as normal free variables+withLocalScope' :: [Ident] -> JMonad a -> JMonad a+withLocalScope' args act = do+ env <- tc_env <$> get+ modify (\tcs -> tcs {tc_env = M.empty : env})+ mapM (addNewVar) args+ res <- act+ (_:restEnv) <- tc_env <$> get+ modify (\tcs -> tcs {tc_env = restEnv})+ return res++inConditional :: JMonad a -> JMonad a+inConditional act = do+ oldCE <- tc_canextend <$> get+ modify (\tcs -> tcs {tc_canextend = False})+ res <- act+ modify (\tcs -> tcs {tc_canextend = oldCE})+ return res++addEnv :: Ident -> JType -> JMonad ()+addEnv i t = do+ (env:envs) <- tc_env <$> get+ modify (\tcs -> tcs {tc_env = M.insert i t env : envs})++addTopEnv :: Ident -> JType -> JMonad ()+addTopEnv i t = do+ (env:envs) <- reverse . tc_env <$> get+ modify (\tcs -> tcs {tc_env = reverse $ M.insert i t env : envs})++newV :: JMonad Int+newV = do+ x <- tc_varCt <$> get+ modify (\tcs -> tcs {tc_varCt = x + 1})+ return x++newVar :: JMonad JType+newVar = JTVar <$> newV++newSat :: JMonad JType+newSat = do+ x <- newV+ (sat:sats) <- tc_scopedSat <$> get+ modify (\tcs -> tcs {tc_scopedSat = S.insert x sat : sats})+ return (JTSat x)++addNewSat :: Ident -> JMonad ()+addNewSat i = addEnv i =<< newSat++addNewVar :: Ident -> JMonad ()+addNewVar i = addEnv i =<< newVar++newTopSat :: JMonad JType+newTopSat = do+ x <- newV+ (sat:sats) <- reverse . tc_scopedSat <$> get+ modify (\tcs -> tcs {tc_scopedSat = reverse $ S.insert x sat : sats})+ return (JTSat x)++killSats :: JMonad ()+killSats = modify (\tcs -> tcs {tc_scopedSat = [S.empty]})++newSatAtScope :: [Int] -> JMonad JType+newSatAtScope is = do+ x <- newV+ let go (s:ss) = if any (flip S.member s) is+ then S.insert x s : ss+ else s : go ss+ go [] = []+ modify (\tcs -> tcs {tc_scopedSat = reverse $ go $ reverse (tc_scopedSat tcs)})+-- trace ("nsas: " ++ show is ++ ", " ++ show x) $ return ()+ return (JTSat x)++satInScope :: Int -> JMonad Bool+satInScope i = any (S.member i) . tc_scopedSat <$> get++incScope :: Int -> Int -> JMonad ()+incScope i ni = do --move i up to scope of ni+ let go (s:ss) = if S.member ni s && not (S.member i s)+ then S.insert i s : ss+ else s : go ss+ go [] = []+ modify (\tcs -> tcs {tc_scopedSat = reverse $ go $ reverse (tc_scopedSat tcs)})+++bumpScope :: Int -> JType -> JMonad ()+bumpScope i x@(JTVar _) = do+ xt <- resolveType x+ case xt of+ (JTVar _) -> return ()+ _ -> bumpScope i xt++--bump constraints?+bumpScope i (JTSat i') = incScope i' i++bumpScope i (JTFunc args ret) = do+ mapM (bumpScope i) args+ bumpScope i ret++bumpScope i(JTRec i') = mapM_ go =<< getRec i'+ where go (_,v) = bumpScope i v+bumpScope _ _ = return ()+++{--------------------------------------------------------------------+ Record utilities+--------------------------------------------------------------------}++getRec :: Int -> JMonad [(Ident, JType)]+getRec i = fromMaybe [] . (M.lookup i) . tc_recs <$> get++putRec :: Int -> [(Ident, JType)] -> JMonad ()+putRec i xs = do+ recs <- tc_recs <$> get+ modify (\tcs -> tcs {tc_recs = M.insert i xs recs})++recLookup :: Ident -> JType -> JMonad (Maybe JType)+recLookup v (JTRec i) = maybe Nothing (lookup v) . M.lookup i . tc_recs <$> get+recLookup _ _ = return $ Nothing++newRec :: JMonad JType+newRec = do+ x <- tc_varCt <$> get+ modify (\tcs -> tcs {tc_varCt = x + 1})+ return (JTRec x)++{--------------------------------------------------------------------+ Constraint utilities+--------------------------------------------------------------------}++unzipConstrs :: [JConstr] -> ([JType],[JType])+unzipConstrs = foldr go ([],[])+ where+ go (Sub l) ~(ls, rs) = (l:ls, rs)+ go (Super r) ~(ls, rs) = (ls, r:rs)++zipConstrs :: [JType] -> [JType] -> [JConstr]+zipConstrs subs supers = map Sub subs ++ map Super supers++lookupConstraints :: Int -> JMonad [JConstr]+lookupConstraints i = fromMaybe [] . M.lookup i . tc_constrs <$> get++--move simplification away from here, delay to last possible moment+addConstraint :: Int -> JConstr -> JMonad ()+addConstraint i c = do+ cs <- lookupConstraints i+ constrs <- tc_constrs <$> get+ modify (\tcs -> tcs {tc_constrs = M.insert i (c:cs) constrs})+++{--------------------------------------------------------------------+ Type utilities+--------------------------------------------------------------------}++chkNoNull :: [JType] -> JMonad ()+chkNoNull xs = do+ strictnull <- tc_strictnull <$> get+ if strictnull+ then mapM_ (chkNull <=< resolveType) xs+ else return ()+ where chkNull x@(JTVar _) = tyErr1 "Attempt to return a (potentially) null variable" x+ chkNull _ = return ()++showType :: JType -> JMonad String+showType (JTVar (-1)) = return ""+showType x@(JTVar _) = do+ xt <- resolveType x+ case xt of+ (JTVar i') -> return $ "t"++show i'+ _ -> showType xt+showType (JTSat i) = do+ cs <- lookupConstraints i+ case cs of+ [] -> return $ "ct" ++ show i+ _ -> do+ cst <- mapM go cs+ return $ "ct" ++ show i ++ " <= [" ++ intercalate ", " cst ++ "]"+ where go (Sub x) = do+ str <- showType x+ return ("<: " ++ str)+ go (Super x) = do+ str <- showType x+ return (">: " ++ str)+++showType JTNum = return "Num"+showType JTStr = return "String"+showType JTBool = return "Bool"+showType (JTRec i) = do+ rs <- getRec i+ strs <- mapM go rs+ return $ "{" ++ intercalate ", " strs ++ "...}"+ where go (StrI s, t) = do+ st <- showType t+ return (s ++ ": " ++ st)+showType (JTFunc args res) = do+ strs <- mapM showType args+ rest <- showType res+ if length strs == -1 --fixme+ then return $ concat strs ++ " -> " ++ rest+ else return $ "((" ++ intercalate ", " strs ++ ") -> " ++ rest++")"+showType JTStat = return $ "()"++showType (JTList _ (Just mono)) = do+ m <- showType mono+ return $ "[" ++ m ++ "]"++showType (JTList (Just multi) _) = do+ showType (JTRec multi)++showType (JTList Nothing Nothing) = error "trying to show bad list"++prettyType :: JType -> JMonad String+prettyType x = showType x -- =<< resC False x++prettyType' :: JType -> JMonad String+prettyType' x = showType =<< resC False x++resolveType :: JType -> JMonad JType+resolveType (JTSat i) = return $ JTSat i+resolveType (JTVar i) = do+ vars <- tc_vars <$> get+ case M.lookup i vars of+ Just t -> do+ rt <- resolveType t+ when (t /= rt) $ do+ modify (\tcs -> tcs {tc_vars = M.insert i rt vars})+ return rt+ _ -> return (JTVar i)+resolveType r@(JTRec i) = do+ (is, ts) <- unzip <$> getRec i+ ts' <- mapM resolveType ts+ putRec i (zip is ts')+ return r++resolveType (JTFunc argst rett) = do+ argst' <- mapM resolveType argst+ rett' <- resolveType rett+ return (JTFunc argst' rett')+resolveType x = return x++resolveState :: JMonad ()+resolveState = do+ envs <- tc_env <$> get+ envs' <- forM envs $ \env ->+ let (is,ts) = unzip $ M.toList env+ in M.fromList . zip is <$> mapM (resC False <=< resolveType) ts+ modify (\tcs -> tcs {tc_env = envs'})++{--------------------------------------------------------------------+ Trace/Error utilities+--------------------------------------------------------------------}++ifDbg :: JMonad () -> JMonad ()+ifDbg x = flip when x . tc_debug =<< get++traceSats :: JMonad ()+traceSats = ifDbg $ do+ ss <- tc_scopedSat <$> get+ trace ("scoped sats: " ++ show ss) $ return ()++traceVars :: JMonad ()+traceVars = ifDbg $ do+ resolveState+ vars <- tc_vars <$> get+ trace (show vars) $ return ()++traceConstrs:: JMonad ()+traceConstrs = ifDbg $ do+ resolveState+ cs <- tc_constrs <$> get+ trace (show cs) $ return ()++tyErr1 :: String -> JType -> JMonad a+tyErr1 s t = do+ st <- prettyType t+ throwError $ s ++ ": " ++ st++tyErr2 :: String -> JType -> JType -> JMonad a+tyErr2 s t t' = do+ st <- prettyType t+ st' <- prettyType t'+ throwError $ s ++ ". Expected: " ++ st ++ ", Inferred: " ++ st'++tyErr2l :: String -> [JType] -> [JType] -> JMonad a+tyErr2l s t t' = do+ sts <- mapM showType t+ sts' <- mapM showType t'+ throwError $ s ++ ". Expected: (" ++ intercalate ", " sts +++ "), Inferred: (" ++ intercalate "," sts' ++")"++traceTy :: String -> JType -> JMonad ()+traceTy s x = ifDbg $ do+ xt <- showType x+ trace (s ++ ": " ++ show xt) $ return ()++traceTys :: String -> JType -> JType -> JMonad ()+traceTys s x y = ifDbg $ do+ xt <- showType x+ yt <- showType y+ trace (s ++": " ++ xt ++ ", " ++ yt) $ return ()++{--------------------------------------------------------------------+ Subtyping+--------------------------------------------------------------------}++--subtype {} {x:a} fails+--subtype {x:a} {} succeeds with {}+-- x is a subtype of y+--subtype enforces subtype relation+(<:) :: JType -> JType -> JMonad ()+x <: y = do+ xr <- resolveType x+ yr <- resolveType y+ if xr == yr+ then return ()+ else traceTys "subtyping" xr yr >> subtype xr yr++subtype :: JType -> JType -> JMonad ()+subtype x@(JTSat i) y@(JTSat i') = do+ addConstraint i (Sub y)+ bumpScope i y++--assigning a free variable to a fixed type+--is incoherent, as it implies usage of a null variable+subtype x@(JTVar _) y = do+ x' <- resolveType x+ case x' of+ JTVar _ -> tyErr1 "Cannot subtype a free variable in" y+ _ -> x' <: y++--assigning to a free variable fixes it+subtype x y@(JTVar _) = do+ y' <- resolveType y+ case y' of+ JTVar _ -> do+ y' =.= x+ _ -> x <: y'++subtype x (JTSat i') = do+ cs <- lookupConstraints i'+ mapM_ go cs+ addConstraint i' (Super x)+ where go (Sub c) = x <: c+ go (Super c) = c <: x++subtype (JTSat i) y = do+ cs <- lookupConstraints i+ mapM_ go cs+ addConstraint i (Sub y)+ where go (Sub c) = c <: y+ go (Super c) = y <: c++--lookup ys in xs+subtype x@(JTRec i) y@(JTRec i') = do+ yl <- getRec i'+ xl <- getRec i+ let go [] = return ()+ go ((ident@(StrI s),v):ls) = do+ case lookup ident xl of+ Just t -> do+ t <: v+ go ls+ Nothing -> tyErr2 ("Couldn't subtype, missing property " ++ s) x y++ go yl++subtype x@(JTFunc argsx retx) y@(JTFunc argsy rety) = do+ when (length argsy < length argsx) $ tyErr2 "Couldn't match" x y+ zipWithM_ (<:) argsy argsx -- functions are contravariant in argument type+ retx <: rety -- functions are covariant in return type++--List case+subtype x y+ | x == y = return ()+ | otherwise = tyErr2 "Couldn't subtype" x y+++{--------------------------------------------------------------------+ Unification+--------------------------------------------------------------------}++--Unification should be very limited, and really only occur with+--free variables or atoms. Everything else is constraints.++--deal with constraints!?+occursCheck :: Int -> JType -> JMonad ()+occursCheck i typ = go typ >>= \b -> if b+ then do+ xt <- showType (JTVar i)+ yt <- showType typ+ throwError $ "Could not construct infinite type when unifying " ++ xt ++" and " ++ yt+ else return ()+ where go t@(JTVar _) = resolveType t >>= \rt -> case rt of+ (JTVar i') -> return (i==i')+ _ -> go rt+ go (JTRec i') = or <$> (mapM (go . snd) =<< getRec i')+ go (JTFunc args ret) = or <$> mapM go (ret:args)+ go _ = return False+ --list case++--unify, but fail if first argument is free+(<=.=) :: JType -> JType -> JMonad ()+x <=.= y = do+ strictnull <- tc_strictnull <$> get+ xr <- resolveType x+ if strictnull+ then case xr of+ (JTVar _) -> tyErr1 "Attempt to use null variable as type" y+ _ -> return ()+ else return ()+ case xr of+ (JTSat _) -> xr <: y+ _ -> xr =.= y++(=.=) :: JType -> JType -> JMonad ()+x =.= y = do+ xr <- resolveType x+ yr <- resolveType y+ if (xr == yr)+ then return ()+ else traceTys "unifying" xr yr >> unify xr yr++unify (JTVar i) t' = do+ occursCheck i t'+ case t' of+ (JTVar i') -> do+ newt <- newVar+ vars <- tc_vars <$> get+ modify (\tcs -> tcs {tc_vars = M.insert i' newt $+ M.insert i newt $+ vars})+ _ -> do+ vars <- tc_vars <$> get+ modify (\tcs -> tcs {tc_vars = M.insert i t' vars})++unify t t'@(JTVar _) = t' =.= t++--force actual unification with free vars?+{-+unify :: JType -> JType -> JMonad ()+unify (JTSat _) (JTSat _) = throwError "unification of two constrained type variables is unimplemented"++unify (JTSat i) t' = do+ cs <- lookupConstraints i+ mapM_ go cs+ let (subs,supers) = unzipConstrs cs+ luball subs+ glball supers+ addConstraint i (Sub t')+ b <- satInScope i+ when (not b) $ addConstraint i (Super t')+ where go (Sub x) = t' <: x+ go (Super x) = x <: t'++unify y x@(JTSat _) = unify x y++unify (JTRec i) (JTRec i') = do+ xl <- getRec i+ yl <- getRec i'++ --find every value in x in y, and unify each+ let go ((l,v):lvs) = case find ((==l) . fst) yl of+ Nothing -> go lvs+ Just (_,v') -> v =.= v'+ go _ = return ()++ go xl++ let xld = deleteFirstsBy ((==) `on` fst) xl yl --xs not in ys+ yld = deleteFirstsBy ((==) `on` fst) yl xl --ys not in xs++ putRec i (xl++yld)+ putRec i' (yl++xld)+ return ()++unify x@(JTFunc argsx retx) y@(JTFunc argsy rety) = do+ when (length argsx /= length argsy) $ tyErr2 "Couldn't match functions" x y+ zipWithM_ (=.=) argsx argsy+ retx =.= rety+-}+unify t t' = do+ rt <- resolveType t+ rt' <- resolveType t'+ if rt == rt'+ then return ()+ else tyErr2 "Type error" t t'+++{--------------------------------------------------------------------+ Clone -- i.e. schema instantiation+--------------------------------------------------------------------}+type JMonadClone a = StateT [(Int,JType)] (ErrorT String (State TCState)) a++addSub :: (Int,JType) -> JMonadClone ()+addSub x = do+ st <- get+ put (x:st)++findSub :: Int -> JMonadClone (Maybe JType)+findSub i = do+ sub <- lookup i <$> get+ case sub of+ Just x -> do+ newsub <- case x of+ (JTVar i') -> if i' /= i then findSub i' else return $ Just x+ (JTRec i') -> if i' /= i then findSub i' else return $ Just x+ (JTSat i') -> if i' /= i then findSub i' else return $ Just x+ _ -> return $ Just x+ case newsub of+ Just ans -> return $ Just ans+ Nothing -> return $ Just x+ _ -> return Nothing++traceSubs :: JMonadClone ()+traceSubs = do+ st <- get+ trace (show st) $ return ()++traceC :: JConstr -> JMonadClone ()+traceC (Sub x) = lift $ traceTy "Sub" x+traceC (Super x) = lift $ traceTy "Super" x++clone :: JType -> JMonad JType+clone t = evalStateT (clone'' t) []++cloneMany :: [JType] -> JMonad [JType]+cloneMany ts = evalStateT (mapM clone'' ts) []++--clone just replaces free variables+clone'' :: JType -> JMonadClone JType+clone'' x = do+ lift $ traceTy "Cloning" x+ c <- clone' x+ lift $ traceTy "Clone Result" c+ return c++clone' :: JType -> JMonadClone JType+clone' x@(JTVar _) = do+ xt <- lift $ resolveType x+ case xt of+ (JTVar i) -> do+ mbsub <- findSub i+ case mbsub of+ Just sub -> return sub+ _ -> do+ nv <- lift $ newVar+ addSub (i,nv)+ return $ nv+ _ -> clone' xt++clone' (JTSat i) = do+ mbsub <- findSub i+ b <- lift $ satInScope i+ case (mbsub,b) of+ (Just sub,_) -> return sub+ (_,False) -> do+ cs <- lift $ lookupConstraints i+ let (subs,supers) = unzipConstrs cs+ subs' <- mapM clone' subs+ supers' <- mapM clone' supers+ ns@(JTSat i') <- lift $ newSatAtScope [i]+ lift $ mapM (addConstraint i') $ zipConstrs subs' supers'+ addSub (i,ns)+ return ns+ _ -> do+ cs <- lift $ lookupConstraints i+ let (subs,supers) = unzipConstrs cs+ subs' <- mapM clone' subs+ supers' <- mapM clone' supers+ constrs <- lift $ tc_constrs <$> get+ lift $ modify (\tcs -> tcs {tc_constrs = M.insert i (zipConstrs subs' supers') constrs})+ addSub (i,JTSat i)+ return (JTSat i)++clone' (JTFunc args ret) = do+ args' <- mapM clone' args+ ret' <- clone' ret+ return (JTFunc args' ret')++clone' (JTRec i) = do+ mbsub <- findSub i+ case mbsub of+ Just sub -> return sub+ _ -> do+ rl <- lift $ getRec i+ rl' <- mapM go rl+ r'@(JTRec i') <- lift $ newRec+ lift $ putRec i' rl'+ return r'+ where go (i',v) = do+ v' <- clone' v+ return (i',v')++clone' (JTList mbmulti mbmono) = do+ mbmulti' <- maybe (return Nothing) (fmap Just . cloneRec) mbmulti+ mbmono' <- maybe (return Nothing) (fmap Just . clone') mbmono+ return $ JTList mbmulti' mbmono'+ where cloneRec x = do+ (JTRec i) <- clone' (JTRec x)+ return i++clone' x = return x++substitute :: JType -> JMonadClone JType+substitute x@(JTVar _) = do+ xt <- lift $ resolveType x+ case xt of+ (JTVar i) -> do+ mbsub <- findSub i+ case mbsub of+ Just sub -> return sub+ _ -> return xt+ _ -> substitute xt++substitute (JTSat i) = do+ mbsub <- findSub i+ b <- lift $ satInScope i+ case (mbsub,b) of+ (Just sub,_) -> return sub+ (_,False) -> do+ cs <- lift $ lookupConstraints i+ let (subs,supers) = unzipConstrs cs+ subs' <- mapM substitute subs+ supers' <- mapM substitute supers+ ns@(JTSat i') <- lift $ newSatAtScope [i]+ lift $ mapM (addConstraint i') $ zipConstrs subs' supers'+ addSub (i,ns)+ return ns+ _ -> do+ cs <- lift $ lookupConstraints i+ let (subs,supers) = unzipConstrs cs+ subs' <- mapM substitute subs+ supers' <- mapM substitute supers+ constrs <- lift $ tc_constrs <$> get+ lift $ modify (\tcs -> tcs {tc_constrs = M.insert i (zipConstrs subs' supers') constrs})+ return (JTSat i)++substitute (JTFunc args ret) = do+ args' <- mapM substitute args+ ret' <- substitute ret+ return (JTFunc args' ret')++substitute (JTRec i) = do+ mbsub <- findSub i+ case mbsub of+ Just sub -> return sub+ _ -> do+ rl <- lift $ getRec i+ rl' <- mapM go rl+ r'@(JTRec i') <- lift $ newRec+ lift $ putRec i' rl'+ return r'+ where go (i',v) = do+ v' <- substitute v+ return (i',v')+substitute x = return x+++{--------------------------------------------------------------------+ Constraint Resolution+--------------------------------------------------------------------}++resC :: Bool -> JType -> JMonad JType+resC inApp x = flip evalStateT [] $ do+ lift $ traceTy "resC" x+ c <- resC' inApp False x+ lift $ traceTy "resC Ans" c+ return c++resC' :: Bool -> Bool -> JType -> JMonadClone JType+resC' inApp contra x@(JTVar _) = do+ xt <- lift $ resolveType x+ case xt of+ (JTVar i) -> return (JTVar i)+ _ -> resC' inApp contra xt++resC' inApp contra (JTFunc args ret) = do+ args' <- mapM (resC' inApp True) args --mapM (resC' (not contra)) args+ ret' <- resC' False False ret+ return (JTFunc args' ret')++resC' inApp contra r@(JTRec i) = do+ rl <- lift $ getRec i+ rl' <- mapM go rl+ lift $ putRec i rl'+ return r+ where go (i',v) = do+ v' <- resC' inApp contra v+ return (i',v')++--in app we substitute, otherwise we keep as constrained+resC' inApp contra x@(JTSat i) = do+ mbsub <- findSub i+ b <- lift $ satInScope i+ case (mbsub,b) of+ (Just sub, _) -> return sub+ (_, False) -> do+ JTSat (i') <- substitute (JTSat i)+ cs <- lift (lookupConstraints i')+ cs' <- simplifyCs cs+ mapM traceC cs'+ ans <- resCs cs'+ --keep supertype, subtype constraints distinct+ ans' <- case (contra && not inApp, ans) of+ (True,(JTRec _)) -> trace "wao" $do+ ns@(JTSat i'') <- lift $ newSat --newSatAtScope [i]+ lift $ addConstraint i'' (Sub ans)+ addSub (i,ns)+ return ns+ (True,(JTFunc _ _ )) -> do+ ns@(JTSat i'') <- lift $ newSat --newSatAtScope [i]+ lift $ addConstraint i'' (Sub ans)+ addSub (i,ns)+ return ns+ _ -> return ans+ addSub (i,ans')+ lift $ traceTy "hai" ans'+ return ans'+ _ -> do+ cs <- lift (lookupConstraints i)+ cs' <- simplifyCs cs+ if any isAtom cs'+ then do+ ans <- resCs cs'+ addSub (i,ans)+ return ans+ else return x {- do+ ns@(JTSat i') <- lift $ newSat+ mapM (addConstraint i') cs'+ addSub (i,ns)+ return ns-}+ where+ resCs cs = do+ let (subs,supers) = unzipConstrs cs+ subs' <- mapM (resC' inApp contra) subs+ supers' <- mapM (resC' inApp contra) supers+ lubsubs <- lift $ resolveType =<< luball subs'+ glbsupers <- lift $ resolveType =<< glball supers'+ case (length subs', length supers') of+ (0,0) -> return lubsubs+ (0,_) -> return glbsupers+ (_,0) -> return lubsubs+ _ -> lift $ glbsupers \/ lubsubs+ isAtom (Sub JTNum) = True+ isAtom (Super JTNum) = True+ isAtom (Sub JTStr) = True+ isAtom (Super JTStr) = True+ isAtom _ = False+ --isatom should go deeper into sats++resC' inApp contra (JTList mbmulti mbmono) = do+ mbmulti' <- maybe (return Nothing) (fmap Just . resRec) mbmulti+ mbmono' <- maybe (return Nothing) (fmap Just . (resC' inApp contra)) mbmono+ return (JTList mbmulti' mbmono')+ where resRec x = do+ (JTRec i) <- resC' inApp contra (JTRec x)+ return i++resC' _ _ x = return x++getBot (JTRec _) = return $ JTRec (-1)+getBot (JTFunc _ ret) = do+ ret' <- getBot ret+ return $ JTFunc [] ret'+getBot x@(JTVar _) = do+ rx <- resolveType x+ case rx of+ (JTVar _) -> return $ BotOf rx+ _ -> getBot rx+getBot x@(JTList mbmulti mbmono) = do+ mbmono' <- maybe (return Nothing) (\x -> Just <$> getBot x) mbmono+ return $ JTList (fmap (const (negate 1)) mbmulti) mbmono --only bot of multi if multi, only bot of mono if mono!!!! TODO+getBot x = return x++simplifyCs :: [JConstr] -> JMonadClone [JConstr]+simplifyCs cs = concat <$> mapM simplifyC cs++simplifyC :: JConstr -> JMonadClone [JConstr]+simplifyC (Sub c) = case c of+ JTSat i -> do+ b <- lift $ satInScope i+ if b+ then return [Sub c]+ else do+ cs <- lift $ lookupConstraints i+ (subs, supers) <- unzipConstrs <$> simplifyCs cs+ supers' <- lift $ map Sub <$> mapM getBot supers+ return $ map Sub subs ++ supers'+ _ -> return [Sub c]++simplifyC (Super c) = case c of+ JTSat i -> do+ b <- lift $ satInScope i+ if b+ then return [Super c]+ else do+ cs <- lift $ lookupConstraints i+ (subs, supers) <- unzipConstrs <$> simplifyCs cs+ subs' <- lift $ map Sub <$> mapM getBot subs+ return $ map Super supers ++ subs'+ _ -> return [Super c]++{--------------------------------------------------------------------+ Least upper bound+--------------------------------------------------------------------}++--{} \/ {a} = {a}+(\/) :: JType -> JType -> JMonad JType+x \/ y = do+ xr <- resolveType x+ yr <- resolveType y+ if xr == yr+ then return xr+ else do+ traceTys "lub" xr yr+ ans <- lub xr yr+ traceTy "lub ans" ans+ return ans++lub :: JType -> JType -> JMonad JType++lub x@(JTSat i) y@(JTSat i') = do+ ns@(JTSat i'') <- newSatAtScope [i, i']+ addConstraint i'' (Sub y)+ addConstraint i'' (Sub x)+ return ns++--check if value satisfies constraint then proceed with constraint+lub (JTSat i) y = do+ cs <- lookupConstraints i+ mapM_ go cs+ ns@(JTSat i') <- newSatAtScope [i]+ mapM (addConstraint i') (Sub y : cs)+ return ns+ where go (Sub c) = y <: c+ go (Super c) = c <: y++lub x y@(JTSat _) = y \/ x++lub x@(JTVar _) y = do+ xt <- resolveType x+ case xt of+ (JTVar _) -> do+ ns@(JTSat i'') <- newSat+ addConstraint i'' (Sub y)+-- addConstraint i'' (Sub x)+ x =.= ns -- ?+ return ns+ _ -> xt \/ y++lub x y@(JTVar _) = y \/ x++lub (JTFunc args ret) (JTFunc args' ret') = do+ args'' <- zipWithM (/\) args args'+ ret'' <- ret \/ ret'+ return $ JTFunc args'' ret''++lub (JTRec i) (JTRec i') = do+ xl <- getRec i+ yl <- getRec i'+ --find every value in x in y, and return lub of each+ let go ((l,v):lvs) = case find ((==l) . fst) yl of+ Nothing -> go lvs+ Just (_,v') -> do+ newv <- v \/ v'+ ((l,newv) :) <$> go lvs+ go _ = return []+ xlyl <- go xl++ --then add every value of x not in y and every value of y not in x+ let xld = deleteFirstsBy ((==) `on` fst) xl yl --xs not in ys+ yld = deleteFirstsBy ((==) `on` fst) yl xl --ys not in xs++ r'@(JTRec i'') <- newRec+ putRec i'' $ xlyl ++ xld ++ yld+ return r'++lub (JTList mbmulti mbmono) (JTList mbmulti' mbmono') = do+ mbmulti'' <- case (mbmulti, mbmulti') of+ (Just multi, Just multi') -> do+ (JTRec i) <- (JTRec multi) \/ (JTRec multi')+ return $ Just i+ _ -> return Nothing+ mbmono'' <- case (mbmono, mbmono') of+ (Just mono, Just mono') -> Just <$> mono \/ mono'+ _ -> return Nothing+ return $ JTList mbmulti'' mbmono''++lub x y+ | x == y = return x+ | otherwise = do+ tyErr2 "No Least Upper Bound Exists" x y++luball :: [JType] -> JMonad JType+luball (h:xs) = do+ foldM (\x y -> x \/ y) h xs+luball [] = newVar+++{--------------------------------------------------------------------+ Greatest Lower bound+--------------------------------------------------------------------}++(/\) :: JType -> JType -> JMonad JType+x /\ y = do+ xr <- resolveType x+ yr <- resolveType y+ if xr == yr+ then return xr+ else do+ traceTys "glb" xr yr+ ans <- glb xr yr+ traceTy "glb ans" ans+ return ans++glb :: JType -> JType -> JMonad JType+glb (JTSat i) (JTSat i') = do+ ns <- newSatAtScope [i, i']+ addConstraint i (Super ns)+ addConstraint i' (Super ns)+ return ns++--glb of a free variable and anything is a subtype of the free var and the other thing+glb x@(JTVar _) y = do+ xt <- resolveType x+ case xt of+ (JTVar _) -> do+ ns@(JTSat i) <- newSatAtScope [-1] --always right?+-- addConstraint i (Super x)+ addConstraint i (Super y)+ x =.= ns -- ?+ return ns+ _ -> x /\ y++glb x y@(JTVar _) = y /\ x++glb x@(JTSat i) y = do+ ns@(JTSat i') <- newSatAtScope [i]+ addConstraint i' (Super y)+ addConstraint i' (Super x)+ return ns++glb x y@(JTSat _) = y /\ x++glb (JTFunc args ret) (JTFunc args' ret') = do+ args'' <- zipWithM (\/) args args'+ ret'' <- ret /\ ret'+ return $ JTFunc args'' ret''++glb (JTRec i) (JTRec i') = do+ xl <- getRec i+ yl <- getRec i'+ --find every value in x in y, and return glb of each+ let go ((l,v):lvs) = case find ((==l) . fst) yl of+ Nothing -> go lvs+ Just (_,v') -> do+ newv <- err2may (v /\ v')+ case newv of+ Just nv -> ((l,nv) :) <$> go lvs+ Nothing -> go lvs+ go _ = return []+ r'@(JTRec i'') <- newRec+ putRec i'' =<< go xl+ return r'+ where err2may v = fmap Just v `orElse` return Nothing++glb (JTList mbmulti mbmono) (JTList mbmulti' mbmono') = do+ mbmulti'' <- case (mbmulti, mbmulti') of+ (Just multi, Just multi') -> do+ (JTRec i) <- (JTRec multi) /\ (JTRec multi')+ return $ Just i+ _ -> return Nothing+ mbmono'' <- case (mbmono, mbmono') of+ (Just mono, Just mono') -> Just <$> mono /\ mono'+ _ -> return Nothing+ return $ JTList mbmulti'' mbmono''+++glb x y+ | x == y = return x+ | otherwise = tyErr2 "No Greatest Lower Bound Exists" x y++glball :: [JType] -> JMonad JType+glball (h:xs) = do+ foldM (\x y -> x /\ y) h xs+glball [] = newVar++{--------------------------------------------------------------------+ Typecheck+--------------------------------------------------------------------}++class JTypeCheck a where+ typecheck :: a -> JMonad JType++instance JTypeCheck JStat where+ typecheck (DeclStat i) = addNewVar i >> return JTStat+ typecheck (ReturnStat e) = typecheck e+ typecheck (BlockStat xs) = typecheck xs+ typecheck (AssignStat x y) = do+ xt <- typecheckLhs x+ yt <- typecheck y+ yt <: xt+ return JTStat++ typecheck (IfStat e s s') = do+ (<=.= JTBool) =<< typecheck e+ if (s' == BlockStat [])+ then inConditional $ typecheck s+ else inConditional $ do+ --can we allow assignments that happen in both, or is this way too hard?+ st <- typecheck s+ st' <- typecheck s'+ chkNoNull [st,st']+ st /\ st'+ typecheck (WhileStat e s) = do+ (<=.= JTBool) =<< typecheck e+ inConditional $ typecheck s++ --for in statements iterate over names+ typecheck (ForInStat False i e s) = withLocalScope' [i] $ do+ (JTStr =.=) =<< lookupEnvErr i+ et <- resolveType =<< typecheck e+ case et of+ --list case+ JTRec _ -> return ()+ _ -> tyErr1 "Attempt to use 'for in' construct with improper type" et+ inConditional $ typecheck s++ --for each in statements iterate over property values+ typecheck (ForInStat True ident e s) = withLocalScope' [ident] $ do+ et <- resolveType =<< typecheck e+ case et of+ --list case+ JTRec i -> do+ --el <- map snd . init <$> rec2list et+ el <- map snd <$> getRec i+ case el of+ [] -> return ()+ es -> do+ e' <- glball es+ (e' =.=) =<< lookupEnvErr ident+ _ -> tyErr1 "Attempt to use 'for each in' construct with improper type" et+ inConditional $ typecheck s+ typecheck (ApplStat e args) = typecheck (ApplExpr e args) >> return JTStat+ typecheck BreakStat = return JTStat+ --Switch+ --Unsat $ Anti -- anti can take signature!?++typecheckLhs :: JExpr -> JMonad JType+typecheckLhs (SelExpr e1 ident@(StrI s)) = do+ e1t <- typecheck e1+ case e1t of+ JTRec i -> do+ newt <- recLookup ident e1t+ canextend <- tc_canextend <$> get+ case newt of+ Just t -> return t+ Nothing -> if canextend+ then do+ v <- newVar+ rs <- getRec i+ putRec i $ (ident,v):rs+ return v+ else tyErr1 "Attempt to extend record in conditional code" e1t+ JTSat i -> do+ ns <- newSatAtScope [i]+ nr@(JTRec i') <- newRec+ putRec i' [(ident,ns)]+ addConstraint i (Sub nr)+ return ns+ _ -> tyErr1 ("No property " ++ s ++ " in type") e1t++typecheckLhs x = typecheck x+++instance JTypeCheck JExpr where+ typecheck (ValExpr v) = typecheck v+ typecheck (SelExpr e1 ident@(StrI s)) = do+ e1t <- typecheck e1+ newt <- recLookup ident e1t+ case (newt, e1t) of+ (Just t, _) -> return t+ (Nothing, JTSat i) -> do+ ns <- newSatAtScope [i]+ nr@(JTRec i') <- newRec+ putRec i' [(ident,ns)]+ addConstraint i (Sub nr)+ return ns+ (Nothing, _) -> tyErr1 ("No property " ++ s ++ " in type") e1t++ --NewExpr -- this is really a special appl+ --Unsat & Anti+ typecheck (InfixExpr s e1 e2)+ | s `elem` ["-","/","*"] = setFixed JTNum+ | s == "+" = setFixed JTNum `orElse` setFixed JTStr --TODO: Intersection types+ | s `elem` [">","<","==","/="] = setFixed JTNum >> return JTBool+ | s `elem` ["||","&&"] = setFixed JTBool+ | otherwise = throwError $ "Unhandled operator: " ++ s+ where setFixed t = do+ (<=.=) t =<< typecheck e1+ (<=.=) t =<< typecheck e2+ return t++ --check that e is either a selexpr or a var or an idxexpr+ typecheck (PostExpr _ e) = case e of+ (SelExpr _ _) -> go+ (ValExpr (JVar _)) -> go+ (IdxExpr _ _) -> go+ _ -> tyErr1 "Value not compatible with postfix assignment" =<< typecheck e+ where go = ((<=.= JTNum) =<< typecheck e) >> return JTNum++ typecheck (IfExpr e e1 e2) = do+ (<=.= JTBool) =<< typecheck e+ e1t <- typecheck e1+ e2t <- typecheck e2+ e1t /\ e2t++ typecheck (ApplExpr e args) = do+ et <- resolveType =<< typecheck e+ argst <- mapM (resolveType <=< typecheck) args+ appFun et argst+ typecheck (IdxExpr e1 e2) = do+ e1t <- resolveType =<< typecheck e1+ e2t <- resolveType =<< typecheck e2+ case e1t of+ (JTList _ (Just t)) -> return t+ (JTList (Just r) _) -> case e2 of+ (ValExpr (JStr i)) -> do+ newt <- recLookup (StrI i) (JTRec r)+ case newt of+ Just t -> return t+ Nothing -> tyErr1 ("No property " ++ i ++ " in type") e1t+ (ValExpr (JInt i)) -> do+ newt <- recLookup (StrI $ show i) (JTRec r)+ case newt of+ Just t -> return t+ Nothing -> tyErr1 ("No property " ++ show i ++ " in type") e1t+ _ -> tyErr1 "Cannot index into hash/tuple with runtime expression" e1t+ (JTList _ _) -> tyErr1 "List/Hash with no inhabited types" e1t+ (JTSat i) -> do+ ns <- newSatAtScope [i]+ mbrec <- case e2 of+ (ValExpr (JStr i)) -> do+ nr@(JTRec i') <- newRec+ putRec i' [(StrI i,ns)]+ return $ Just i'+ (ValExpr (JInt i)) -> do+ nr@(JTRec i') <- newRec+ putRec i' [(StrI $ show i,ns)]+ return $ Just i'+ _ -> return Nothing+ addConstraint i (Sub $ JTList mbrec (Just ns))+ return ns+ _ -> tyErr1 "Attempting to index into something of type" e1t++appFun :: JType -> [JType] -> JMonad JType+appFun(JTFunc args ret) appArgs = do+ when (length args > length appArgs) $ tyErr2l "Mismatched argument lengths" args appArgs+ appArgs' <- cloneMany appArgs+ (JTFunc args' ret') <- clone (JTFunc args ret)+ zipWithM (<:) appArgs' args'+ (JTFunc args'' ret'') <- withLocalScope [] $ resC True $ JTFunc args' ret'+-- zipWithM (=.=) args'' appArgs'+ return ret''+-- withLocalScope [] $ resC True ret''++appFun (JTSat i) args' = do+ s <- newSatAtScope [i]+ mapM (bumpScope i) args'+ addConstraint i (Sub $ JTFunc args' s)+ return s++appFun x _ = tyErr1 "Attempting to apply as a function something of type" x++instance JTypeCheck JVal where+ typecheck (JVar i) = case i of+ StrI "true" -> return JTBool+ StrI "false" -> return JTBool+ StrI "null" -> newVar+ StrI _ -> resolveType =<< lookupEnvErr i+ typecheck (JInt _) = return JTNum+ typecheck (JDouble _) = return JTNum+ typecheck (JStr _) = return JTStr+ typecheck (JFunc args stat) =+ withLocalScope args ( do+ argst <- mapM (typecheck . JVar) args+ rett <- typecheck stat+ resC False $ JTFunc argst rett)+ typecheck (JHash m) = do+ let (is, es) = unzip $ M.toList m+ ets <- mapM typecheck es+ let initialrec+ | null is = []+ | otherwise = zip (map StrI is) ets+ r@(JTRec i) <- newRec+ putRec i initialrec+ return r+ typecheck (JList es) = do+ (JTRec i) <- typecheck $ JHash $ M.fromList (zip (map show [1..]) es)+ es' <- mapM typecheck es+ e'' <- (Just <$> glball es') `orElse` return Nothing+ return $ JTList (Just i) e''+ --List++instance JTypeCheck [JStat] where+ typecheck [] = return JTStat+ typecheck stats = do+ ts <- filter (/=JTStat) <$> (mapM resolveType =<< mapM typecheckAnnotated stats)+ case ts of+ [] -> return JTStat+ _ -> chkNoNull ts >> glball ts++typecheckAnnotated :: (JMacro a, JsToDoc a, JTypeCheck a) => a -> JMonad JType+typecheckAnnotated stat = typecheck stat `catchError` \ e -> throwError $ e ++ "\nIn statement:\n" ++ renderStyle (style {mode = OneLineMode}) (renderJs stat)
+ Language/Javascript/JMacro/Util.hs view
@@ -0,0 +1,63 @@+module 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 (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']+++jsv :: P.String -> JExpr+jsv = ValExpr P.. JVar P.. StrI++jstr :: P.String -> JExpr+jstr = ValExpr P.. JStr+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jmacro.cabal view
@@ -0,0 +1,28 @@+name: jmacro+version: 0.1+synopsis: QuasiQuotation library for programmatic generation of Javascript code.+description: Javascript syntax, functional syntax, hygeinic names, compile-time guarantees of syntactic correctness, limited typechecking.+category: Language+license: BSD3+license-file: LICENSE+author: Gershom Bazerman+maintainer: gershomb@gmail.com+Tested-With: GHC == 6.10.3+Build-Type: Simple+Cabal-Version: >= 1.6+++library+ build-depends: base >= 4, base < 5, containers, pretty, safe >= 0.2, parsec >= 2.1, template-haskell >= 2.3, mtl, haskell-src-meta, bytestring >= 0.9+ exposed-modules: Language.Javascript.JMacro+ Language.Javascript.JMacro.Util+ Language.Javascript.JMacro.Typed+ other-modules: Language.Javascript.JMacro.Base+ Language.Javascript.JMacro.QQ+ ghc-options: -Wall+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++source-repository head+ type: darcs+ location: http://patch-tag.com/r/jmacro/pullrepo