diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ See full history at: +## 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 diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -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 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 @@ -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 diff --git a/src/Fay/Compiler/Desugar.hs b/src/Fay/Compiler/Desugar.hs --- a/src/Fay/Compiler/Desugar.hs +++ b/src/Fay/Compiler/Desugar.hs @@ -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 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 @@ -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 diff --git a/src/Fay/Compiler/FFI.hs b/src/Fay/Compiler/FFI.hs --- a/src/Fay/Compiler/FFI.hs +++ b/src/Fay/Compiler/FFI.hs @@ -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 "" 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 ++ "," ++ diff --git a/src/Fay/Compiler/GADT.hs b/src/Fay/Compiler/GADT.hs --- a/src/Fay/Compiler/GADT.hs +++ b/src/Fay/Compiler/GADT.hs @@ -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 _ = [] diff --git a/src/Fay/Compiler/Import.hs b/src/Fay/Compiler/Import.hs --- a/src/Fay/Compiler/Import.hs +++ b/src/Fay/Compiler/Import.hs @@ -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) diff --git a/src/Fay/Compiler/InitialPass.hs b/src/Fay/Compiler/InitialPass.hs --- a/src/Fay/Compiler/InitialPass.hs +++ b/src/Fay/Compiler/InitialPass.hs @@ -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 diff --git a/src/Fay/Compiler/Packages.hs b/src/Fay/Compiler/Packages.hs --- a/src/Fay/Compiler/Packages.hs +++ b/src/Fay/Compiler/Packages.hs @@ -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]] diff --git a/src/Fay/Compiler/Pattern.hs b/src/Fay/Compiler/Pattern.hs --- a/src/Fay/Compiler/Pattern.hs +++ b/src/Fay/Compiler/Pattern.hs @@ -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 []] diff --git a/src/Fay/Convert.hs b/src/Fay/Convert.hs --- a/src/Fay/Convert.hs +++ b/src/Fay/Convert.hs @@ -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 diff --git a/src/Fay/Exts.hs b/src/Fay/Exts.hs --- a/src/Fay/Exts.hs +++ b/src/Fay/Exts.hs @@ -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 diff --git a/src/Fay/Exts/NoAnnotation.hs b/src/Fay/Exts/NoAnnotation.hs --- a/src/Fay/Exts/NoAnnotation.hs +++ b/src/Fay/Exts/NoAnnotation.hs @@ -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 diff --git a/src/Fay/Exts/Scoped.hs b/src/Fay/Exts/Scoped.hs --- a/src/Fay/Exts/Scoped.hs +++ b/src/Fay/Exts/Scoped.hs @@ -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 diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -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] }