diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ **Note: 0.18.0.1 added source mappings returend by `Fay:compileFile` and friends meaning it should have been a major bump. Sorry about this!** +### 0.18.1.2 (2013-11-26) + +* Add support for indirect application of newtypes (such as `p = NewType; foo = p x` and `bar = NewType $ y`) + ### 0.18.1.1 (2013-11-22) * Fix a bug where records with the same name as top level modules wouldn't be initialized correctly. diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.18.1.1 +version: 0.18.1.2 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which is type-checked with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad, @@ -15,9 +15,9 @@ . /Release Notes/ . - See + See . - See full history at: + See full history at: homepage: http://fay-lang.org/ bug-reports: https://github.com/faylang/fay/issues license: BSD3 @@ -107,7 +107,6 @@ ghc-options: -O2 -Wall -fno-warn-name-shadowing build-depends: base >= 4 && < 5 , Cabal < 1.19 - , HUnit < 1.3 , aeson < 0.7 , attoparsec < 0.11 , bytestring < 0.11 @@ -127,9 +126,6 @@ , safe < 0.4 , split < 0.3 , syb < 0.5 - , test-framework < 0.9 - , test-framework-hunit < 0.4 - , test-framework-th < 0.3 , text < 0.12 , time < 1.5 , unordered-containers < 0.3 @@ -144,24 +140,9 @@ main-is: Main.hs build-depends: base , fay - , Cabal - , aeson - , containers - , cpphs , data-default - , directory - , filepath - , ghc-paths - , haskeline < 0.8 - , haskell-src-exts - , language-ecmascript - , mtl , optparse-applicative >= 0.6 && < 0.8 - , process - , safe , split - , syb - , utf8-string executable fay-tests hs-source-dirs: src/tests @@ -174,29 +155,16 @@ Test.Util build-depends: base , fay - , Cabal - , HUnit + , HUnit < 1.3 , aeson , attoparsec , bytestring - , containers - , cpphs , data-default , directory , filepath - , ghc-paths , haskell-src-exts - , language-ecmascript - , mtl - , pretty-show - , process - , safe - , split - , syb - , test-framework - , test-framework-hunit - , test-framework-th + , test-framework < 0.9 + , test-framework-hunit < 0.4 + , test-framework-th < 0.3 , text - , unordered-containers , utf8-string - , vector diff --git a/src/Fay/Compiler/Decl.hs b/src/Fay/Compiler/Decl.hs --- a/src/Fay/Compiler/Decl.hs +++ b/src/Fay/Compiler/Decl.hs @@ -44,9 +44,9 @@ compileDecl toplevel decl = case decl of pat@PatBind{} -> compilePatBind toplevel Nothing pat FunBind _ matches -> compileFunCase toplevel matches - DataDecl _ (DataType _ ) _ head' constructors _ -> compileDataDecl toplevel (mkTyVars head') constructors + DataDecl _ (DataType _ ) _ (mkTyVars -> tyvars) constructors _ -> compileDataDecl toplevel tyvars constructors GDataDecl _ (DataType _) _l (mkTyVars -> tyvars) _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls) - DataDecl _ (NewType _) _ _ _ _ -> return [] + DataDecl _ (NewType _) _ _ _ _ -> return [] -- Just ignore type aliases and signatures. TypeDecl {} -> return [] TypeSig {} -> return [] diff --git a/src/Fay/Compiler/Exp.hs b/src/Fay/Compiler/Exp.hs --- a/src/Fay/Compiler/Exp.hs +++ b/src/Fay/Compiler/Exp.hs @@ -71,11 +71,19 @@ -- | Compile variable. compileVar :: S.QName -> Compile JsExp -compileVar qname = case qname of - Special _ t@TupleCon{} -> shouldBeDesugared t - _ -> do - qname <- unsafeResolveName qname - return (JsName (JsNameVar qname)) +compileVar (Special _ t@TupleCon{}) = shouldBeDesugared t +compileVar qname = do + nc <- lookupNewtypeConst qname + nd <- lookupNewtypeDest qname + if (nc /= Nothing || nd /= Nothing) + then -- variable is either a newtype constructor or newtype destructor, + -- replace it with identity function + return idFun + else do + qname <- unsafeResolveName qname + return (JsName (JsNameVar qname)) + where + idFun = JsFun Nothing [JsTmp 1] [] (Just (JsName $ JsTmp 1)) -- | Compile Haskell literal. compileLit :: S.Literal -> Compile JsExp @@ -138,10 +146,18 @@ -- | Compile an infix application, optimizing the JS cases. compileInfixApp :: S.Exp -> S.QOp -> S.Exp -> Compile JsExp -compileInfixApp exp1 ap exp2 = compileExp (App noI (App noI (Var noI op) exp1) exp2) - where op = getOp ap - getOp (QVarOp _ op) = op - getOp (QConOp _ op) = op +compileInfixApp exp1 ap exp2 = case exp1 of + Con _ q -> do + newtypeConst <- lookupNewtypeConst q + case newtypeConst of + Just _ -> compileExp exp2 + Nothing -> normalApp + _ -> normalApp + where + normalApp = compileExp (App noI (App noI (Var noI op) exp1) exp2) + op = getOp ap + getOp (QVarOp _ op) = op + getOp (QConOp _ op) = op -- | Compile a let expression. compileLet :: [S.Decl] -> S.Exp -> Compile JsExp diff --git a/tests/newtypeIndirectApp.hs b/tests/newtypeIndirectApp.hs new file mode 100644 --- /dev/null +++ b/tests/newtypeIndirectApp.hs @@ -0,0 +1,17 @@ +module Main where + +import Prelude + +newtype Parser a = Parser { runParser :: Char -> Either Char (a, Char) } + +pure :: a -> Parser a +pure a = Parser $ \s -> Right (a, s) + +p = Parser + +pure' a = p (\s -> Right (a, s)) + +main :: Fay () +main = do + print $ runParser (pure 5) '0' + print $ runParser (pure' 5) '0' diff --git a/tests/newtypeIndirectApp.res b/tests/newtypeIndirectApp.res new file mode 100644 --- /dev/null +++ b/tests/newtypeIndirectApp.res @@ -0,0 +1,2 @@ +{ instance: 'Right', slot1: [ 5, '0' ] } +{ instance: 'Right', slot1: [ 5, '0' ] }