fay 0.20.2.0 → 0.21.0.0

raw patch · 16 files changed

+77/−76 lines, 16 filesdep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• fay.cabal +2/−2
• src/Fay/Compiler/Decl.hs +10/−7
• src/Fay/Compiler/Desugar.hs +8/−9
• src/Fay/Compiler/Exp.hs +13/−10
• src/Fay/Compiler/FFI.hs +13/−16
• src/Fay/Compiler/GADT.hs +6/−4
• src/Fay/Compiler/Import.hs +2/−2
• src/Fay/Compiler/InitialPass.hs +1/−7
• src/Fay/Compiler/Packages.hs +1/−1
• src/Fay/Compiler/Pattern.hs +4/−4
• src/Fay/Convert.hs +4/−7
• src/Fay/Exts.hs +4/−4
• src/Fay/Exts/NoAnnotation.hs +1/−1
• src/Fay/Exts/Scoped.hs +1/−1
• src/Fay/Types.hs +1/−1

@@ -2,6 +2,12 @@  See full history at: <https://github.com/faylang/fay/commits> +## 0.21.0.0 (2014-10-11)++* Errors are now properly thrown from `encodeFay`. Changes the type signature to `encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ Value`+* Update to `haskell-src-exts == 1.16.*`, This changes the type signature of `readerCompileLit` to `:: S.Sign -> S.Literal -> Compile JsExp`+* Fixes `ghc-pkg describe` stdout errors not always being printed+ ### 0.20.2.0 (2014-09-14)  * Config option to disable optimizations of newtypes, treating them as

@@ -1,5 +1,5 @@ name:                fay-version:             0.20.2.0+version:             0.21.0.0 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,@@ -123,7 +123,7 @@     , ghc-paths < 0.2     , haskell-names >= 0.3.1 && < 0.5     , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3-    , haskell-src-exts >= 1.15.0.1 && < 1.16+    , haskell-src-exts >= 1.16 && < 1.17     , language-ecmascript >= 0.15 && < 0.17     , mtl < 2.3     , process < 1.3

@@ -60,14 +60,17 @@   mkTyVars :: S.DeclHead -> [S.TyVarBind]-mkTyVars (DHead _ _ binds) = binds-mkTyVars (DHInfix _ t1 _ t2) = [t1, t2]-mkTyVars (DHParen _ dh) = mkTyVars dh+mkTyVars x = go x []+  where+    go (DHead _ _) = id+    go (DHInfix _ r _) = (r:)+    go (DHParen _ dh) = go dh+    go (DHApp _ dh r) = go dh . (r:)  -- | Compile a top-level pattern bind. compilePatBind :: Bool -> S.Decl -> Compile [JsStmt] compilePatBind toplevel patDecl = case patDecl of-  PatBind _ (PVar _ name') Nothing+  PatBind _ (PVar _ name')     (UnGuardedRhs _       (ExpTypeSig _         (App _ (Var _ (UnQual _ (Ident _ "ffi")))@@ -79,12 +82,12 @@       fun <- compileFFIExp loc (Just name) formatstr sig       stmt <- bindToplevel toplevel (Just (srcInfoSpan loc)) name fun       return [stmt]-  PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) Nothing ->+  PatBind srcloc (PVar _ ident) (UnGuardedRhs _ rhs) Nothing ->       compileUnguardedRhs toplevel srcloc ident rhs   -- TODO: Generalize to all patterns-  PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) ->+  PatBind srcloc (PVar _ ident) (UnGuardedRhs _ rhs) (Just bdecls) ->     compileUnguardedRhs toplevel srcloc ident (Let S.noI bdecls rhs)-  PatBind _ pat Nothing (UnGuardedRhs _ rhs) _bdecls -> case pat of+  PatBind _ pat (UnGuardedRhs _ rhs) _bdecls -> case pat of     PList {} -> compilePatBind' pat rhs     PTuple{} -> compilePatBind' pat rhs     PApp  {} -> compilePatBind' pat rhs

@@ -14,7 +14,7 @@ import           Fay.Compiler.Desugar.Name import           Fay.Compiler.Desugar.Types import           Fay.Compiler.Misc               (ffiExp, hasLanguagePragma)-import           Fay.Compiler.QName              (unname)+import           Fay.Compiler.QName              (unname, unQual) import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types                       (CompileError (..)) @@ -121,8 +121,7 @@ desugarMultiIf :: (Data l, Typeable l) => Module l -> Module l desugarMultiIf = transformBi $ \ex -> case ex of   MultiIf l alts -> Case l (Con l (Special l (UnitCon l)))-                           [Alt l (PWildCard l) (GuardedAlts l gas) Nothing]-    where gas = map (\(IfAlt l' p a) -> GuardedAlt l' [Qualifier l' p] a) alts+                           [Alt l (PWildCard l) (GuardedRhss l alts) Nothing]   _ -> ex  -- | (a,) => \b -> (a,b)@@ -155,13 +154,13 @@ -- | {a} => {a=a} for R{a} expressions desugarFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarFieldPun = transformBi $ \f -> case f of-  FieldPun l n -> let dn = UnQual l n in FieldUpdate l dn (Var l dn)+  FieldPun l n -> FieldUpdate l n (Var l n)   _ -> f  -- | {a} => {a=a} for R{a} patterns desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarPatFieldPun = transformBi $ \pf -> case pf of-  PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n)+  PFieldPun l n -> PFieldPat l n (PVar l (unQual n))   _             -> pf  -- | Desugar list comprehensions.@@ -253,7 +252,7 @@     getPrelude :: Desugar l (ImportDecl l)     getPrelude = do       noInfo <- asks readerNoInfo-      return $ ImportDecl noInfo (ModuleName noInfo "Prelude") False False Nothing Nothing Nothing+      return $ ImportDecl noInfo (ModuleName noInfo "Prelude") False False False Nothing Nothing Nothing  desugarFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarFFITypeSigs = desugarToplevelFFITypeSigs >=> desugarBindsTypeSigs@@ -291,13 +290,13 @@   go typeSigs = map (addTypeSig typeSigs)    addTypeSig typeSigs decl = case decl of-    (PatBind loc pat typ rhs binds) ->+    (PatBind loc pat rhs binds) ->       case getUnguardedRhs rhs of         Just (srcInfo, rhExp) ->           if isFFI rhExp             then do               rhExp' <- addSigToExp typeSigs decl rhExp-              return $ PatBind loc pat typ (UnGuardedRhs srcInfo rhExp') binds+              return $ PatBind loc pat (UnGuardedRhs srcInfo rhExp') binds             else return decl         _ -> return decl     _ -> return decl@@ -322,7 +321,7 @@     Nothing -> return rhExp    getTypeFor typeSigs decl = case decl of-    (PatBind _ (PVar _ name) _ _ _) -> lookup (unname name) typeSigs+    (PatBind _ (PVar _ name) _ _) -> lookup (unname name) typeSigs     _ -> Nothing  -- | a `op` b => op a b

@@ -37,7 +37,7 @@ compileExp :: S.Exp -> Compile JsExp compileExp e = case e of   Var _ qname                        -> compileVar qname-  Lit _ lit                          -> compileLit lit+  Lit s lit                          -> compileLit (Signless s) lit   App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError $ FfiNeedsTypeSig e   App _ exp1 exp2                    -> compileApp exp1 exp2   NegApp _ exp                       -> compileNegApp exp@@ -84,17 +84,22 @@     idFun = JsFun Nothing [JsTmp 1] [] (Just (JsName $ JsTmp 1))  -- | Compile Haskell literal.-compileLit :: S.Literal -> Compile JsExp-compileLit lit = case lit of+compileLit :: S.Sign -> S.Literal -> Compile JsExp+compileLit sign lit = case lit of   Char _ ch _       -> return (JsLit (JsChar ch))-  Int _ integer _   -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:-  Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational)))+  Int _ integer _   -> return (JsLit (JsInt (fromIntegral (applySign integer)))) -- FIXME:+  Frac _ rational _ -> return (JsLit (JsFloating (fromRational (applySign rational))))   String _ string _ -> do     fromString <- gets stateUseFromString     return $ if fromString       then JsLit (JsStr string)       else JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)]   _                 -> throwError $ UnsupportedLiteral lit+  where+    applySign :: Num a => a -> a+    applySign = case sign of+      Signless _ -> id+      Negative _ -> negate  -- | Compile simple application. compileApp :: S.Exp -> S.Exp -> Compile JsExp@@ -201,13 +206,11 @@     compilePat exp pat [alt]  -- | Compile a guarded alt.-compileGuardedAlt :: S.GuardedAlts -> Compile JsStmt+compileGuardedAlt :: S.Rhs -> Compile JsStmt compileGuardedAlt alt =   case alt of-    UnGuardedAlt _ exp -> JsEarlyReturn <$> compileExp exp-    GuardedAlts _ alts -> compileGuards (map altToRhs alts)-   where-    altToRhs (GuardedAlt l s e) = GuardedRhs l s e+    UnGuardedRhs _ exp -> JsEarlyReturn <$> compileExp exp+    GuardedRhss _ alts -> compileGuards alts  -- | Compile guards compileGuards :: [S.GuardedRhs] -> Compile JsStmt

@@ -52,6 +52,10 @@       TyInfix _ t1 q t2 -> flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2       TyKind _ t k      -> flip (TyKind ()) (unAnn k) <$> rmNewtys t       TyPromoted {}     -> return $ unAnn typ+      TyParArray _ t    -> TyParArray () <$> rmNewtys t+      TyEquals _ t1 t2  -> TyEquals () <$> rmNewtys t1 <*> rmNewtys t2+      TySplice {}       -> return $ unAnn typ+      TyBang _ bt t     -> TyBang () (unAnn bt) <$> rmNewtys t     compileFFI' :: N.Type -> Compile JsExp     compileFFI' sig = do       let name = fromMaybe "<exp>" nameopt@@ -104,7 +108,7 @@     globalNames = ["Math","console","JSON"]  -- | Make a Fay→JS encoder.-emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], BangType d)] -> Compile ()+emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile () emitFayToJs (unAnn -> name) (map unAnn -> tyvars) (explodeFields -> fieldTypes) = do   qname <- qualify name   let ctrName = printJSString $ unQual qname@@ -121,7 +125,7 @@     obj = JsVar obj_ $       JsObj [("instance",JsLit (JsStr (printJSString (unAnn name))))] -    fieldStmts :: [(Int,(N.Name,N.BangType))] -> [JsStmt]+    fieldStmts :: [(Int,(N.Name,N.Type))] -> [JsStmt]     fieldStmts [] = []     fieldStmts ((i,fieldType):fts) =       JsVar obj_v field :@@ -137,11 +141,11 @@     obj_ = JsNameVar "obj_"      -- Declare/encode Fay→JS field-    declField :: Int -> (N.Name,N.BangType) -> (String,JsExp)+    declField :: Int -> (N.Name,N.Type) -> (String,JsExp)     declField i (fname,typ) =       (prettyPrint fname       ,fayToJs (SerializeUserArg i)-               (argType (bangType typ))+               (argType typ)                (JsGetProp (JsName transcodingObjForced)                           (JsNameVar (UnQual () fname)))) @@ -185,13 +189,6 @@       TyCon _ (UnQual _ user)   -> UserDefined user []       _ -> UnknownType --- | Extract the type.-bangType :: N.BangType -> N.Type-bangType typ = case typ of-  BangedTy _ ty   -> ty-  UnBangedTy _ ty -> ty-  UnpackedTy _ ty -> ty- -- | Expand a type application. expandApp :: N.Type -> [N.Type] expandApp (TyParen _ t) = expandApp t@@ -327,7 +324,7 @@ jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]]  -- | Make a JS→Fay decoder.-emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],BangType d)] -> Compile ()+emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],Type d)] -> Compile () emitJsToFay (unAnn -> name) (map unAnn -> tyvars) (map (unAnn *** unAnn) . explodeFields -> fieldTypes) = do   qname <- qualify name   tell (mempty { writerJsToFay = [(printJSString (unAnn name), translator qname)] })@@ -338,10 +335,10 @@             (Just $ JsNew (JsConstructor qname)                           (map (decodeField . getIndex name tyvars) fieldTypes))     -- Decode JS→Fay field-    decodeField :: (Int,(N.Name,N.BangType)) -> JsExp+    decodeField :: (Int,(N.Name,N.Type)) -> JsExp     decodeField (i,(fname,typ)) =       jsToFay (SerializeUserArg i)-              (argType (bangType typ))+              (argType typ)               (JsGetPropExtern (JsName transcodingObj)                                (prettyPrint fname)) @@ -350,9 +347,9 @@ argTypes = JsNameVar "argTypes"  -- | Get the index of a name from the set of type variables bindings.-getIndex :: Name a -> [TyVarBind b] -> (Name c,BangType d) -> (Int,(N.Name,N.BangType))+getIndex :: Name a -> [TyVarBind b] -> (Name c,Type d) -> (Int,(N.Name,N.Type)) getIndex (unAnn -> name) (map unAnn -> tyvars) (unAnn -> sname,unAnn -> ty) =-  case bangType ty of+  case ty of     TyVar _ tyname -> case elemIndex tyname (map tyvar tyvars) of       Nothing -> error $ "unknown type variable " ++ prettyPrint tyname ++                          " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," ++

@@ -9,13 +9,15 @@ -- | Convert a GADT to a normal data type. convertGADT :: GadtDecl a -> QualConDecl a convertGADT d = case d of-  GadtDecl s name typ -> QualConDecl s tyvars context-                           (ConDecl s name (convertFunc typ))+  GadtDecl s name Nothing typ ->+    QualConDecl s tyvars context (ConDecl s name (convertFunc typ))+  GadtDecl s name (Just fs) _typ ->+    QualConDecl s tyvars context (RecDecl s name fs)   where     tyvars = Nothing     context = Nothing-    convertFunc :: Type a -> [BangType a]+    convertFunc :: Type a -> [Type a]     convertFunc (TyCon _ _) = []-    convertFunc (TyFun s x xs) = UnBangedTy s x : convertFunc xs+    convertFunc (TyFun _ x xs) = x : convertFunc xs     convertFunc (TyParen _ x) = convertFunc x     convertFunc _ = []

@@ -99,8 +99,8 @@   -> Compile a compileImport compileModule i = case i of   -- Package imports are ignored since they are used for some trickery in fay-base.-  ImportDecl _ _    _ _ Just{}  _ _ -> return mempty-  ImportDecl _ name _ _ Nothing _ _ -> compileModuleFromName compileModule name+  ImportDecl _ _    _ _ _ Just{}  _ _ -> return mempty+  ImportDecl _ name _ _ _ Nothing _ _ -> compileModuleFromName compileModule name  -- | Find an import's filepath and contents from its module name. findImport :: [FilePath] -> ModuleName a -> Compile (FilePath,String)

@@ -17,7 +17,6 @@ import           Fay.Compiler.Parse import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn)-import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types  import           Control.Monad.Error@@ -77,18 +76,13 @@   RecDecl _ cname [FieldDecl _ [dname] ty] -> addNewtype cname (Just dname) ty   x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x   where-    getBangTy :: F.BangType -> N.Type-    getBangTy (BangedTy _ t)   = unAnn t-    getBangTy (UnBangedTy _ t) = unAnn t-    getBangTy (UnpackedTy _ t) = unAnn t-     addNewtype cname dname ty = do       qcname <- qualify cname       qdname <- case dname of                   Nothing -> return Nothing                   Just n  -> Just <$> qualify n       modify (\cs@CompileState{stateNewtypes=nts} ->-               cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts})+               cs{stateNewtypes=(qcname,qdname,unAnn ty):nts}) compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q  -- | Add record declarations to the state

@@ -57,7 +57,7 @@ describePackage db name = do   result <- readAllFromProcess ghc_pkg args ""   case result of-    Left  (err,_out) -> error $ "ghc-pkg describe error:\n" ++ err+    Left  (err,out) -> error $ "ghc-pkg describe error:\n" ++ err ++ "\n" ++ out     Right (_err,out) -> return out    where args = ["describe",name] ++ ["-f" ++ db' | Just db' <- [db]]

@@ -29,7 +29,7 @@     case newty of       Nothing -> compilePApp pat cons pats exp body       Just _  -> compileNewtypePat pats exp body-  PLit _ literal    -> compilePLit exp literal body+  PLit _ sign lit   -> compilePLit exp sign lit body   PWildCard _       -> return body   PList _ pats      -> compilePList pats body exp   PTuple _ _bx pats -> compilePList pats body exp@@ -78,10 +78,10 @@         _ -> []  -- | Compile a literal value from a pattern match.-compilePLit :: JsExp -> S.Literal -> [JsStmt] -> Compile [JsStmt]-compilePLit exp literal body = do+compilePLit :: JsExp -> S.Sign -> S.Literal -> [JsStmt] -> Compile [JsStmt]+compilePLit exp sign literal body = do   c <- ask-  lit <- readerCompileLit c literal+  lit <- readerCompileLit c sign literal   return [JsIf (equalExps exp lit)                body                []]

@@ -39,7 +39,7 @@ --   values aren't handled by explicit cases.  'encodeFay' can be used to --   resolve this issue. showToFay :: Data a => a -> Maybe Value-showToFay = encodeFay (\x -> x)+showToFay = spoon . encodeFay (\x -> x)  -- | Convert a Haskell value to a Fay json value.  This can fail when primitive --   values aren't handled by explicit cases.  When this happens, you can add@@ -48,11 +48,8 @@ --   The first parameter is a function that can be used to override the --   conversion.  This usually looks like using 'extQ' to additional type- --   specific cases.-encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ (Maybe Value)-encodeFay specialCases = spoon . encodeFayInternal specialCases--encodeFayInternal :: (GenericQ Value -> GenericQ Value) -> GenericQ Value-encodeFayInternal specialCases = specialCases $+encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ Value+encodeFay specialCases = specialCases $     encodeGeneric rec     `extQ` unit     `extQ` Bool@@ -66,7 +63,7 @@     `extQ` text   where     rec :: GenericQ Value-    rec = encodeFayInternal specialCases+    rec = encodeFay specialCases     unit () = Null     list :: Data a => [a] -> Value     list = Array . Vector.fromList . map rec

@@ -15,7 +15,6 @@ type FieldDecl = A.FieldDecl X type FieldUpdate = A.FieldUpdate X type GadtDecl = A.GadtDecl X-type GuardedAlts = A.GuardedAlts X type GuardedRhs = A.GuardedRhs X type ImportDecl = A.ImportDecl X type ImportSpec = A.ImportSpec X@@ -57,7 +56,7 @@ noI :: A.SrcSpanInfo noI = A.noInfoSpan (A.mkSrcSpan A.noLoc A.noLoc) -convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.BangType a)+convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.Type a) convertFieldDecl (A.FieldDecl _ ns b) = (ns, b)  fieldDeclNames :: A.FieldDecl a -> [A.Name a]@@ -65,6 +64,7 @@  declHeadName :: A.DeclHead a -> A.Name a declHeadName d = case d of-  A.DHead _ n _ -> n-  A.DHInfix _ _ n _ -> n+  A.DHead _ n -> n+  A.DHInfix _ _ n -> n   A.DHParen _ h -> declHeadName h+  A.DHApp _ h _ -> declHeadName h

@@ -19,7 +19,6 @@ type FieldDecl = A.FieldDecl () type FieldUpdate = A.FieldUpdate () type GadtDecl = A.GadtDecl ()-type GuardedAlts = A.GuardedAlts () type GuardedRhs = A.GuardedRhs () type ImportDecl = A.ImportDecl () type ImportSpec = A.ImportSpec ()@@ -36,6 +35,7 @@ type QualConDecl = A.QualConDecl () type QualStmt = A.QualStmt () type Rhs = A.Rhs ()+type Sign = A.Sign () type SpecialCon = A.SpecialCon () type SrcLoc = A.SrcLoc type SrcSpan = A.SrcSpan

@@ -19,7 +19,6 @@ type FieldDecl = A.FieldDecl X type FieldUpdate = A.FieldUpdate X type GadtDecl = A.GadtDecl X-type GuardedAlts = A.GuardedAlts X type GuardedRhs = A.GuardedRhs X type ImportDecl = A.ImportDecl X type ImportSpec = A.ImportSpec X@@ -36,6 +35,7 @@ type QualConDecl = A.QualConDecl X type QualStmt = A.QualStmt X type Rhs = A.Rhs X+type Sign = A.Sign X type SpecialCon = A.SpecialCon X type SrcLoc = A.SrcLoc type Stmt = A.Stmt X

@@ -82,7 +82,7 @@ -- | Configuration and globals for the compiler. data CompileReader = CompileReader   { readerConfig       :: Config -- ^ The compilation configuration.-  , readerCompileLit   :: S.Literal -> Compile JsExp+  , readerCompileLit   :: S.Sign -> S.Literal -> Compile JsExp   , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]   }