fay 0.18.1.2 → 0.18.1.3
raw patch · 6 files changed
+141/−240 lines, 6 filesdep +uniplatedep ~text
Dependencies added: uniplate
Dependency ranges changed: text
Files
- CHANGELOG.md +6/−1
- fay.cabal +3/−2
- src/Fay/Compiler/Desugar.hs +114/−210
- src/Fay/Compiler/Exp.hs +1/−20
- src/Fay/Compiler/Misc.hs +8/−7
- src/Fay/Convert.hs +9/−0
CHANGELOG.md view
@@ -2,7 +2,12 @@ See full history at: <https://github.com/faylang/fay/commits> -**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!**+**Note: 0.18.0.1 added source mappings returned by `Fay:compileFile` and friends meaning it should have been a major bump. Sorry about this!**++### 0.18.1.3 (2013-12-14)++* Add parsing of Integer to Fay.Convert (note that the runtime doesn't have arbitrary precision Integers)+* Allow text 1.0.* ### 0.18.1.2 (2013-11-26)
fay.cabal view
@@ -1,5 +1,5 @@ name: fay-version: 0.18.1.2+version: 0.18.1.3 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,@@ -126,8 +126,9 @@ , safe < 0.4 , split < 0.3 , syb < 0.5- , text < 0.12+ , text < 1.1 , time < 1.5+ , uniplate >= 1.6.11 && < 1.7 , unordered-containers < 0.3 , utf8-string < 0.4 , vector < 0.11
src/Fay/Compiler/Desugar.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Fay.Compiler.Desugar (desugar@@ -12,11 +13,13 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.Reader+import Data.Data (Data)+import qualified Data.Generics.Uniplate.Data as U import Data.Maybe+import Data.Typeable (Typeable) import Language.Haskell.Exts.Annotated hiding (binds, loc) import Prelude hiding (exp) - -- Types data DesugarReader = DesugarReader { readerNameDepth :: Int }@@ -38,110 +41,41 @@ -- | Generate a temporary, SCOPED name for testing conditions and -- such. We don't have name tracking yet, so instead we use this.-withScopedTmpName :: l -> (Name l -> Desugar a) -> Desugar a+withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar a) -> Desugar a withScopedTmpName l f = do n <- asks readerNameDepth local (\r -> DesugarReader $ readerNameDepth r + 1) $ f $ Ident l $ "$gen" ++ show n + -- | Top level, desugar a whole module possibly returning errors-desugar :: Module l -> IO (Either CompileError (Module l))-desugar md = runDesugar (desugarModule md)+desugar :: (Data l, Typeable l) => Module l -> IO (Either CompileError (Module l))+desugar md = runDesugar $+ checkEnum md+ >> desugarSection md+ >>= desugarListComp+ >>= return . desugarTupleCon+ >>= return . desugarPatParen+ >>= return . desugarFieldPun+ >>= return . desugarPatFieldPun+ >>= desugarDo+ >>= desugarTupleSection -- | Desugaring -desugarModule :: Module l -> Desugar (Module l)-desugarModule m = case m of- Module l h ps is decls -> Module l h ps is <$> mapM desugarDecl decls- _ -> return $ m--desugarDecl :: Decl l -> Desugar (Decl l)-desugarDecl d = case d of- FunBind l ms -> FunBind l <$> mapM desugarMatch ms- PatBind l p mt rhs mbs -> PatBind l <$> desugarPat p <*> return mt <*> desugarRhs rhs <*> mmap desugarBinds mbs-- _ -> return d--mmap :: (Applicative f) => (t -> f a) -> Maybe t -> f (Maybe a)-mmap f mbs' = case mbs' of Just b -> return <$> f b; Nothing -> pure Nothing--desugarBinds :: Binds l -> Desugar (Binds l)-desugarBinds bs = case bs of- BDecls l ds -> BDecls l <$> mapM desugarDecl ds- _ -> return bs--desugarMatch :: Match l -> Desugar (Match l)-desugarMatch m = case m of- Match l n ps rhs mb -> Match l (desugarName n) <$> mapM desugarPat ps <*> desugarRhs rhs <*> mmap desugarBinds mb- InfixMatch l p n ps r mb -> InfixMatch l <$> desugarPat p <*> return (desugarName n) <*> mapM desugarPat ps <*> desugarRhs r <*> mmap desugarBinds mb--desugarRhs :: Rhs l -> Desugar (Rhs l)-desugarRhs r = case r of- UnGuardedRhs l e -> UnGuardedRhs l <$> desugarExp e- GuardedRhss l gs -> GuardedRhss l <$> mapM desugarGuardedRhs gs--desugarGuardedRhs :: GuardedRhs l -> Desugar (GuardedRhs l)-desugarGuardedRhs g = case g of- GuardedRhs l stmts exp -> GuardedRhs l <$> mapM desugarStmt stmts <*> desugarExp exp--desugarExp :: Exp l -> Desugar (Exp l)-desugarExp ex = case ex of- -- (a `f`) => (\b -> f a b)- LeftSection l e q -> desugarExp =<<- (withScopedTmpName l $ \v ->- return $ Lambda l [PVar l v] (InfixApp l e q (Var l (UnQual l v))))- -- (`f` b) => (\a -> f a b)- RightSection l q e -> desugarExp =<<- (withScopedTmpName l $ \tmp ->- return (Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e)))-- -- Check for TupleCon- Var _ q -> return $ desugarVar ex q- Con _ q -> return $ desugarVar ex q+desugarSection :: (Data l, Typeable l) => Module l -> Desugar (Module l)+desugarSection = transformBiM $ \ex -> case ex of+ LeftSection l e q -> withScopedTmpName l $ \tmp ->+ return $ Lambda l [PVar l tmp] (InfixApp l e q (Var l (UnQual l tmp)))+ RightSection l q e -> withScopedTmpName l $ \tmp ->+ return $ Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e)+ _ -> return ex - IPVar{} -> return ex- Lit{} -> return ex- InfixApp l e1 qop e2 -> InfixApp l <$> desugarExp e1 <*> return (desugarQOp qop) <*> desugarExp e2- App l e1 e2 -> App l <$> desugarExp e1 <*> desugarExp e2- NegApp l e -> NegApp l <$> desugarExp e- Lambda l ps e -> Lambda l <$> mapM desugarPat ps <*> desugarExp e- Let l b e -> Let l <$> desugarBinds b <*> desugarExp e- If l e1 e2 e3 -> If l <$> desugarExp e1 <*> desugarExp e2 <*> desugarExp e3- Case l e as -> Case l <$> desugarExp e <*> mapM desugarAlt as- Do _ stmts -> maybe (throwError EmptyDoBlock) return =<< (mmap desugarExp $ foldl desugarStmt' Nothing (reverse stmts))- MDo l ss -> MDo l <$> mapM desugarStmt ss- Tuple l b es -> Tuple l b <$> mapM desugarExp es- TupleSection l _ mes -> desugarTupleSec l =<< (mapM (mmap desugarExp) mes)- List l es -> List l <$> mapM desugarExp es- Paren l e -> Paren l <$> desugarExp e- RecConstr l q f -> RecConstr l (desugarQName q) <$> mapM desugarFieldUpdate f- RecUpdate l e f -> RecUpdate l <$> desugarExp e <*> mapM desugarFieldUpdate f- e@(EnumFrom l e1) -> checkEnum e >> (EnumFrom l <$> desugarExp e1)- e@(EnumFromTo l e1 e2) -> checkEnum e >> (EnumFromTo l <$> desugarExp e1 <*> desugarExp e2)- e@(EnumFromThen l e1 e2) -> checkEnum e >> (EnumFromThen l <$> desugarExp e1 <*> desugarExp e2)- e@(EnumFromThenTo l e1 e2 e3) -> checkEnum e >> (EnumFromThenTo l <$> desugarExp e1 <*> desugarExp e2 <*> desugarExp e3)- ListComp l e qs -> ListComp l <$> desugarExp e <*> mapM desugarQualStmt qs- ParComp l e qqs -> ParComp l <$> desugarExp e <*> mapM (mapM desugarQualStmt) qqs- ExpTypeSig l e t -> ExpTypeSig l <$> desugarExp e <*> return (desugarType t)- VarQuote l q -> return $ VarQuote l (desugarQName q)- TypQuote l q -> return $ TypQuote l (desugarQName q)- BracketExp l b -> return $ BracketExp l (desugarBracket b)- SpliceExp l s -> return $ SpliceExp l (desugarSplice s)- QuasiQuote{} -> return ex- XTag{} -> return ex- XETag{} -> return ex- XPcdata{} -> return ex- XExpTag{} -> return ex- XChildTag{} -> return ex- GenPragma{} -> return ex- Proc l p e -> Proc l <$> desugarPat p <*> desugarExp e- LeftArrApp{} -> return ex- RightArrApp{} -> return ex- LeftArrHighApp{} -> return ex- RightArrHighApp{} -> return ex- CorePragma{} -> return ex- SCCPragma{} -> return ex+desugarDo :: (Data l, Typeable l) => Module l -> Desugar (Module l)+desugarDo = transformBiM $ \ex -> case ex of+ Do _ stmts -> maybe (throwError EmptyDoBlock) return $ foldl desugarStmt' Nothing (reverse stmts)+ _ -> return ex -- | Convert do notation into binds and thens. desugarStmt' :: Maybe (Exp l) -> (Stmt l) -> Maybe (Exp l)@@ -169,110 +103,32 @@ (QVarOp s $ UnQual s $ Symbol s ">>=") (Lambda s [pat] (inner')) --desugarPat :: Pat l -> Desugar (Pat l)-desugarPat pt = case pt of- -- (p) => p- PParen _ p -> desugarPat p-- PVar l n -> return $ PVar l (desugarName n)- PLit {} -> return pt- PNeg l p -> PNeg l <$> desugarPat p- PNPlusK{} -> return pt- PInfixApp l p1 q p2 -> PInfixApp l <$> desugarPat p1 <*> return (desugarQName q) <*> desugarPat p2- PApp l q ps -> PApp l (desugarQName q) <$> mapM desugarPat ps- PTuple l b ps -> PTuple l b <$> mapM desugarPat ps- PList l ps -> PList l <$> mapM desugarPat ps- PRec l q pfs -> PRec l (desugarQName q) <$> mapM desugarPatField pfs- PAsPat l n p -> PAsPat l (desugarName n) <$> desugarPat p- PWildCard{} -> return pt- PIrrPat l p -> PIrrPat l <$> desugarPat p- PatTypeSig l p t -> PatTypeSig l <$> desugarPat p <*> return (desugarType t)- PViewPat l e p -> PViewPat l <$> desugarExp e <*> desugarPat p- PBangPat l p -> PBangPat l <$> desugarPat p- _ -> return pt--desugarPatField :: PatField l -> Desugar (PatField l)-desugarPatField pf = case pf of- -- {a} => {a=a} for R{a}- PFieldPun l n -> let dn = desugarName n in desugarPatField $ PFieldPat l (UnQual l dn) (PVar l dn)-- PFieldPat l q p -> PFieldPat l (desugarQName q) <$> desugarPat p- PFieldWildcard l -> return $ PFieldWildcard l--desugarGuardedAlts :: GuardedAlts l -> Desugar (GuardedAlts l)-desugarGuardedAlts g = case g of- UnGuardedAlt l e -> UnGuardedAlt l <$> desugarExp e- GuardedAlts l gas -> GuardedAlts l <$> mapM desugarGuardedAlt gas--desugarQOp :: QOp l -> QOp l-desugarQOp = id--desugarType :: Type l -> Type l-desugarType = id--desugarQName :: QName l -> QName l-desugarQName = id--desugarQualStmt :: QualStmt l -> Desugar (QualStmt l)-desugarQualStmt q = case q of- QualStmt l s -> QualStmt l <$> desugarStmt s- ThenTrans l e -> ThenTrans l <$> desugarExp e- ThenBy l e1 e2 -> ThenBy l <$> desugarExp e1 <*> desugarExp e2- GroupBy l e -> GroupBy l <$> desugarExp e- GroupUsing l e -> GroupUsing l <$> desugarExp e- GroupByUsing l e1 e2 -> GroupByUsing l <$> desugarExp e1 <*> desugarExp e2--desugarAlt :: Alt l -> Desugar (Alt l)-desugarAlt (Alt l p ga mb) = Alt l <$> desugarPat p <*> desugarGuardedAlts ga <*> mmap desugarBinds mb--desugarFieldUpdate :: FieldUpdate l -> Desugar (FieldUpdate l)-desugarFieldUpdate f = case f of- FieldUpdate l q e -> FieldUpdate l (desugarQName q) <$> desugarExp e- FieldPun l n -> let dn = UnQual l (desugarName n)- in desugarFieldUpdate $ FieldUpdate l dn (Var l dn)- FieldWildcard{} -> return f--desugarBracket :: Bracket l -> Bracket l-desugarBracket = id--desugarSplice :: Splice l -> Splice l-desugarSplice = id--desugarGuardedAlt :: GuardedAlt l -> Desugar (GuardedAlt l)-desugarGuardedAlt (GuardedAlt l ss e) = GuardedAlt l <$> mapM desugarStmt ss <*> desugarExp e--desugarStmt :: Stmt l -> Desugar (Stmt l)-desugarStmt s = case s of- Generator l p e -> Generator l <$> desugarPat p <*> desugarExp e- Qualifier l e -> Qualifier l <$> desugarExp e- LetStmt l b -> LetStmt l <$> desugarBinds b- RecStmt l ss -> RecStmt l <$> mapM desugarStmt ss--desugarName :: Name a -> Name a-desugarName = id--desugarVar :: Exp l -> QName l -> Exp l-desugarVar e q = case q of- Special _ t@TupleCon{} -> fromMaybe e $ desugarTupleCon t- _ -> e---- | (,) => \x y -> (x,y)-desugarTupleCon :: SpecialCon l -> Maybe (Exp l)-desugarTupleCon s = case s of- TupleCon l b n -> Just $ Lambda l params body- where- -- It doesn't matter if these variable names shadow anything since- -- this lambda won't have inner scopes.- names = take n $ map (Ident l . ("$gen" ++) . show) [(1::Int)..]- params = PVar l <$> names- body = Tuple l b (Var l . UnQual l <$> names)- _ -> Nothing+-- | (,) => \x y -> (x,y)+-- (,,) => \x y z -> (x,y,z)+-- etc+desugarTupleCon :: (Data l, Typeable l) => Module l -> Module l+desugarTupleCon = transformBi $ \ex -> case ex of+ Var _ (Special _ t@TupleCon{}) -> fromTupleCon ex t+ Con _ (Special _ t@TupleCon{}) -> fromTupleCon ex t+ _ -> ex+ where+ fromTupleCon :: Exp l -> SpecialCon l -> Exp l+ fromTupleCon e s = fromMaybe e $ case s of+ TupleCon l b n -> Just $ Lambda l params body+ where+ -- It doesn't matter if these variable names shadow anything since+ -- this lambda won't have inner scopes.+ names = take n $ map (Ident l . ("$gen" ++) . show) [(1::Int)..]+ params = PVar l <$> names+ body = Tuple l b (Var l . UnQual l <$> names)+ _ -> Nothing -desugarTupleSec :: l -> [Maybe (Exp l)] -> Desugar (Exp l)-desugarTupleSec l xs = do- (names, lst) <- genSlotNames l xs (varNames l)+desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar (Module l)+desugarTupleSection = transformBiM $ \ex -> case ex of+ TupleSection l _ mes -> do+ (names, lst) <- genSlotNames l mes (varNames l) return $ Lambda l (map (PVar l) names) (Tuple l Unboxed lst)+ _ -> return ex where varNames :: l -> [Name l] varNames l = map (\i -> Ident l ("$gen_" ++ show i)) [0::Int ..]@@ -285,25 +141,64 @@ return (head ns : rn, Var l (UnQual l (head ns)) : re) genSlotNames l (Just e : rest) ns = do (rn, re) <- genSlotNames l rest ns- e' <- desugarExp e- return (rn, e' : re)+ return (rn, e : re) +-- (p) => p for patterns+desugarPatParen :: (Data l, Typeable l) => Module l -> Module l+desugarPatParen = transformBi $ \pt -> case pt of+ PParen _ p -> p+ _ -> pt++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)+ _ -> f++desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l+desugarPatFieldPun = transformBi $ \pf -> case pf of+ -- {a} => {a=a} for R{a}+ PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n)+ _ -> pf++-- | Desugar list comprehensions.+desugarListComp :: (Data l, Typeable l) => Module l -> Desugar (Module l)+desugarListComp = transformBiM $ \ex -> case ex of+ ListComp l exp stmts -> desugarListComp' l exp stmts+ _ -> return ex+ where+ desugarListComp' l e [] = return (List l [ e ])+ desugarListComp' l e (QualStmt _ (Generator _ p e2) : stmts) = do+ nested <- desugarListComp' l e stmts+ withScopedTmpName l $ \f ->+ return (Let l (BDecls l [ FunBind l [+ Match l f [ p ] (UnGuardedRhs l nested) Nothing+ , Match l f [ PWildCard l ] (UnGuardedRhs l (List l [])) Nothing+ ]]) (App l (App l (Var l (Qual l (ModuleName l "$Prelude") (Ident l "concatMap"))) (Var l (UnQual l f))) e2))+ desugarListComp' l e (QualStmt _ (Qualifier _ e2) : stmts) = do+ nested <- desugarListComp' l e stmts+ return (If l e2 nested (List l []))+ desugarListComp' l e (QualStmt _ (LetStmt _ bs) : stmts) = do+ nested <- desugarListComp' l e stmts+ return (Let l bs nested)+ desugarListComp' _ _ (_ : _) =+ error "UnsupportedListComprehension"+ -- | We only have Enum instance for Int, but GHC hard codes [x..y] -- syntax to GHC.Base.Enum instead of using our Enum class so we check -- for obviously incorrect usages and throw an error on them. This can -- only checks literals, but it helps a bit.-checkEnum :: Exp l -> Desugar ()-checkEnum exp = case exp of- EnumFrom _ e -> checkIntOrUnknown [e]- EnumFromTo _ e1 e2 -> checkIntOrUnknown [e1,e2]- EnumFromThen _ e1 e2 -> checkIntOrUnknown [e1,e2]- EnumFromThenTo _ e1 e2 e3 -> checkIntOrUnknown [e1,e2,e3]- _ -> error "checkEnum: Only for Enums"+checkEnum :: (Data l, Typeable l) => Module l -> Desugar ()+checkEnum = mapM_ f . universeBi where- checkIntOrUnknown :: [Exp l] -> Desugar ()- checkIntOrUnknown es = if any isIntOrUnknown es- then return ()- else throwError . UnsupportedEnum $ unAnn exp+ f ex = case ex of+ e@(EnumFrom _ e1) -> checkIntOrUnknown e [e1]+ e@(EnumFromTo _ e1 e2) -> checkIntOrUnknown e [e1,e2]+ e@(EnumFromThen _ e1 e2) -> checkIntOrUnknown e [e1,e2]+ e@(EnumFromThenTo _ e1 e2 e3) -> checkIntOrUnknown e [e1,e2,e3]+ _ -> return ()++ checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar ()+ checkIntOrUnknown exp es = when (not $ any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp) isIntOrUnknown :: Exp l -> Bool isIntOrUnknown e = case e of Con {} -> False@@ -316,3 +211,12 @@ EnumFromThen {} -> False EnumFromThenTo {} -> False _ -> True++transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a+transformBi = U.transformBi++universeBi :: U.Biplate (from a) (to a) => from a -> [to a]+universeBi = U.universeBi++transformBiM :: (Monad m, U.Biplate (from a) (to a)) => (to a -> m (to a)) -> from a -> m (from a)+transformBiM = U.transformBiM
src/Fay/Compiler/Exp.hs view
@@ -57,7 +57,7 @@ EnumFromThenTo _ a b z -> compileEnumFromThenTo a b z RecConstr _ name fieldUpdates -> compileRecConstr name fieldUpdates RecUpdate _ rec fieldUpdates -> compileRecUpdate rec fieldUpdates- ListComp _ exp stmts -> compileExp =<< desugarListComp exp stmts+ ListComp {} -> shouldBeDesugared exp Do {} -> shouldBeDesugared exp LeftSection {} -> shouldBeDesugared exp RightSection {} -> shouldBeDesugared exp@@ -333,25 +333,6 @@ updateExp _ f@FieldPun{} = shouldBeDesugared f -- I also couldn't find a code that generates (FieldUpdate FieldWildCard) updateExp _ FieldWildcard{} = error "unsupported update: FieldWildcard"---- | Desugar list comprehensions.-desugarListComp :: S.Exp -> [S.QualStmt] -> Compile S.Exp-desugarListComp e [] = return (List noI [ e ])-desugarListComp e (QualStmt _ (Generator _ p e2) : stmts) = do- nested <- desugarListComp e stmts- withScopedTmpName $ \f ->- return (Let noI (BDecls noI [ FunBind noI [- Match noI f [ p ] (UnGuardedRhs noI nested) Nothing- , Match noI f [ PWildCard noI ] (UnGuardedRhs noI (List noI [])) Nothing- ]]) (App noI (App noI (Var noI (Qual noI (ModuleName noI "$Prelude") (Ident noI "concatMap"))) (Var noI (UnQual noI f))) e2))-desugarListComp e (QualStmt _ (Qualifier _ e2) : stmts) = do- nested <- desugarListComp e stmts- return (If noI e2 nested (List noI []))-desugarListComp e (QualStmt _ (LetStmt _ bs) : stmts) = do- nested <- desugarListComp e stmts- return (Let noI bs nested)-desugarListComp _ (s : _ ) =- throwError (UnsupportedQualStmt s) -- | Make a Fay list. makeList :: [JsExp] -> JsExp
src/Fay/Compiler/Misc.hs view
@@ -322,17 +322,18 @@ defaultExtensions :: [Extension] defaultExtensions = map EnableExtension- [GADTs+ [EmptyDataDecls ,ExistentialQuantification- ,StandaloneDeriving- ,PackageImports- ,EmptyDataDecls- ,TypeOperators- ,RecordWildCards- ,NamedFieldPuns ,FlexibleContexts ,FlexibleInstances+ ,GADTs ,KindSignatures+ ,NamedFieldPuns+ ,PackageImports+ ,RecordWildCards+ ,StandaloneDeriving ,TupleSections+ ,TypeFamilies+ ,TypeOperators ] ++ map DisableExtension [ImplicitPrelude]
src/Fay/Convert.hs view
@@ -103,6 +103,7 @@ `ext1R` parseArray value `extR` parseDouble value `extR` parseInt value+ `extR` parseInteger value `extR` parseBool value `extR` parseString value `extR` parseChar value@@ -180,6 +181,14 @@ number <- parseNumber value case number of I n -> return (fromIntegral n)+ _ -> mzero++-- | Parse an integer.+parseInteger :: Value -> Maybe Integer+parseInteger value = do+ number <- parseNumber value+ case number of+ I n -> return n _ -> mzero -- | Parse a number.