diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ See full history at: +#### 0.23.1.9 + +* Allow and require `haskell-src-exts 1.17.*` + #### 0.23.1.8 * Allow `vector 0.11.*` diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.23.1.8 +version: 0.23.1.9 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, @@ -136,7 +136,8 @@ build-depends: base >= 4 && < 4.9 - , aeson > 0.6 && < 0.10 + , base-compat == 0.8.* + , aeson > 0.6 && < 0.11 , bytestring < 0.11 , containers < 0.6 , data-default < 0.6 @@ -144,7 +145,7 @@ , directory < 1.3 , filepath < 1.5 , ghc-paths < 0.2 - , haskell-src-exts >= 1.16 && < 1.17 + , haskell-src-exts == 1.17.* , language-ecmascript >= 0.15 && < 0.18 , mtl < 2.3 , mtl-compat >= 0.1 && < 0.3 @@ -153,7 +154,7 @@ , sourcemap < 0.2 , split < 0.3 , spoon < 0.4 - , syb < 0.6 + , syb < 0.7 , text < 1.3 , time >= 1 && < 1.6 , transformers >= 0.3 && < 0.4 || > 0.4.1 && < 0.5 @@ -177,7 +178,7 @@ base , fay , mtl - , optparse-applicative == 0.11.* + , optparse-applicative >= 0.11 && < 0.13 , split executable fay-tests @@ -204,7 +205,7 @@ , groom == 0.1.* , haskell-src-exts , random >= 1.0 && < 1.2 - , tasty >= 0.9 && < 0.11 + , tasty >= 0.9 && < 0.12 , tasty-hunit >= 0.8 && < 0.10 , tasty-th == 0.1.* , text diff --git a/src/Fay.hs b/src/Fay.hs --- a/src/Fay.hs +++ b/src/Fay.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -23,14 +24,16 @@ ,getRuntime ) where +import Fay.Compiler.Prelude + import Fay.Compiler import Fay.Compiler.Misc (ioWarn, printSrcSpanInfo) import Fay.Compiler.Packages -import Fay.Compiler.Prelude import Fay.Compiler.Typecheck import Fay.Config import qualified Fay.Exts as F import Fay.Types + import Data.Aeson (encode) import qualified Data.ByteString.Lazy as L import Language.Haskell.Exts.Annotated (prettyPrint) diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -42,12 +42,12 @@ import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Monad.Except -import Control.Monad.RWS +import Control.Monad.Except (throwError) +import Control.Monad.RWS (gets, modify) import qualified Data.Set as S import Language.Haskell.Exts.Annotated hiding (name) -import Language.Haskell.Names (annotateModule) +import Language.Haskell.Names (annotateModule) -------------------------------------------------------------------------------- -- Top level entry points 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 @@ -21,8 +21,8 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Except -import Control.Monad.RWS +import Control.Monad.Except (throwError) +import Control.Monad.RWS (gets, modify) import Language.Haskell.Exts.Annotated hiding (binds, loc, name) -- | Compile Haskell declaration. @@ -161,7 +161,7 @@ JsSetConstructor qname $ JsFun (Just $ JsConstructor qname) fields - (for fields $ \field -> JsSetProp JsThis field (JsName field)) + (flip fmap fields $ \field -> JsSetProp JsThis field (JsName field)) Nothing -- Creates a function to initialize the record by regular application 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,11 +14,11 @@ import Fay.Compiler.Desugar.Name import Fay.Compiler.Desugar.Types import Fay.Compiler.Misc (ffiExp, hasLanguagePragma) -import Fay.Compiler.QName (unname, unQual) +import Fay.Compiler.QName (unQual, unname) import Fay.Exts.NoAnnotation (unAnn) import Fay.Types (CompileError (..)) -import Control.Monad.Except +import Control.Monad.Except (throwError) import Control.Monad.Reader (asks) import qualified Data.Generics.Uniplate.Data as U import Language.Haskell.Exts.Annotated hiding (binds, loc, name) @@ -28,7 +28,7 @@ desugar = desugar' "$gen" -- | Desugar with the option to specify a prefix for generated names. --- Useful if you want to provide valid haskell name that HSE can print. +-- Useful if you want to provide valid haskell names that HSE can print. desugar' :: (Data l, Typeable l) => String -> l -> Module l -> IO (Either CompileError (Module l)) desugar' prefix emptyAnnotation md = runDesugar prefix emptyAnnotation $ checkEnum md 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 @@ -27,11 +27,11 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Except (throwError) +import Control.Monad.Except (throwError) import Control.Monad.RWS (asks, gets) import qualified Data.Char as Char import Language.Haskell.Exts.Annotated hiding (alt, binds, name, op) -import Language.Haskell.Names (Scoped (Scoped), NameInfo (RecExpWildcard)) +import Language.Haskell.Names (NameInfo (RecExpWildcard), Scoped (Scoped)) -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp @@ -291,7 +291,7 @@ exp <- compileExp value return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp] updateStmt o (FieldWildcard (wildcardFields -> fields)) = - return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o) + return $ flip fmap fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o) (JsNameVar fieldName) (JsName $ JsNameVar fieldName) -- I couldn't find a code that generates (FieldUpdate (FieldPun ..)) 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 @@ -25,8 +25,8 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Except -import Control.Monad.Writer +import Control.Monad.Except (throwError) +import Control.Monad.Writer (tell) import Data.Generics.Schemes import Language.ECMAScript3.Parser as JS import Language.ECMAScript3.Syntax 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 @@ -7,8 +7,8 @@ -- which at this point is InitialPass's preprocessing -- and Compiler's code generation module Fay.Compiler.Import - (startCompile - ,compileWith + ( startCompile + , compileWith ) where import Fay.Compiler.Prelude @@ -20,8 +20,8 @@ import Fay.Exts.NoAnnotation (unAnn) import Fay.Types -import Control.Monad.Except -import Control.Monad.RWS +import Control.Monad.Except (throwError) +import Control.Monad.RWS (ask, get, gets, lift, listen, modify) import Language.Haskell.Exts.Annotated hiding (name, var) import System.Directory import System.FilePath 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 @@ -19,8 +19,8 @@ import Fay.Exts.NoAnnotation (unAnn) import Fay.Types -import Control.Monad.Except -import Control.Monad.RWS +import Control.Monad.Except (throwError) +import Control.Monad.RWS (modify) import qualified Data.Map as M import Language.Haskell.Exts.Annotated hiding (name, var) import qualified Language.Haskell.Names as HN (getInterfaces) @@ -90,7 +90,7 @@ scanRecordDecls decl = do case decl of DataDecl _loc ty _ctx (F.declHeadName -> name) qualcondecls _deriv -> do - let addIt = let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) + let addIt = let ns = flip fmap qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) in addRecordTypeState name ns case ty of DataType{} -> addIt diff --git a/src/Fay/Compiler/Misc.hs b/src/Fay/Compiler/Misc.hs --- a/src/Fay/Compiler/Misc.hs +++ b/src/Fay/Compiler/Misc.hs @@ -20,7 +20,7 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Except +import Control.Monad.Except (runExceptT, throwError) import Control.Monad.RWS (asks, gets, modify, runRWST) import Data.Version (parseVersion) import Language.Haskell.Exts.Annotated hiding (name) diff --git a/src/Fay/Compiler/ModuleT.hs b/src/Fay/Compiler/ModuleT.hs --- a/src/Fay/Compiler/ModuleT.hs +++ b/src/Fay/Compiler/ModuleT.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Fay.Compiler.ModuleT @@ -26,10 +27,10 @@ , ModName (..) ) where -import Control.Applicative +import Fay.Compiler.Prelude + import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Writer import qualified Data.Char as Char (isAlphaNum, isUpper) import qualified Data.Map as Map diff --git a/src/Fay/Compiler/Optimizer.hs b/src/Fay/Compiler/Optimizer.hs --- a/src/Fay/Compiler/Optimizer.hs +++ b/src/Fay/Compiler/Optimizer.hs @@ -13,8 +13,8 @@ import Fay.Compiler.Misc import Fay.Types -import Control.Monad.State -import Control.Monad.Writer +import Control.Monad.State (State, modify, runState) +import Control.Monad.Writer (runWriter, tell) import qualified Fay.Exts.NoAnnotation as N import Language.Haskell.Exts.Annotated hiding (app, name, op) 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 @@ -1,7 +1,6 @@ -{-# LANGUAGE TupleSections #-} - +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} -- | Dealing with Cabal packages in Fay's own special way. - module Fay.Compiler.Packages where import Fay.Compiler.Prelude 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 @@ -15,10 +15,10 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Except -import Control.Monad.Reader +import Control.Monad.Except (throwError) +import Control.Monad.Reader (ask) import Language.Haskell.Exts.Annotated hiding (name) -import Language.Haskell.Names (Scoped (Scoped), NameInfo (RecPatWildcard)) +import Language.Haskell.Names (NameInfo (RecPatWildcard), Scoped (Scoped)) -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt] diff --git a/src/Fay/Compiler/Prelude.hs b/src/Fay/Compiler/Prelude.hs --- a/src/Fay/Compiler/Prelude.hs +++ b/src/Fay/Compiler/Prelude.hs @@ -1,46 +1,48 @@ -- | Re-exports of base functionality. Note that this module is just -- used inside the compiler. It's not compiled to JavaScript. -- Based on the base-extended package (c) 2013 Simon Meier, licensed as BSD3. +{-# LANGUAGE NoImplicitPrelude #-} module Fay.Compiler.Prelude - ( module Prelude -- Partial + ( module Prelude.Compat -- Partial -- * Control modules , module Control.Applicative , module Control.Arrow -- Partial - , module Control.Monad + , module Control.Monad.Compat -- * Data modules - , module Data.Char -- Partial - , module Data.Data -- Partial + , module Data.Char -- Partial + , module Data.Data -- Partial , module Data.Either , module Data.Function - , module Data.List -- Partial + , module Data.List.Compat -- Partial , module Data.Maybe - , module Data.Monoid -- Partial + , module Data.Monoid -- Partial , module Data.Ord + , module Data.Traversable -- * Safe , module Safe -- * Additions , anyM - , for , io , readAllFromProcess ) where import Control.Applicative -import Control.Arrow (first, second, (&&&), (***), (+++), (|||)) -import Control.Monad hiding (guard) -import Data.Char hiding (GeneralCategory (..)) -import Data.Data (Data (..), Typeable) +import Control.Arrow (first, second, (&&&), (***), (+++), (|||)) +import Control.Monad.Compat hiding (guard) +import Data.Char hiding (GeneralCategory (..)) +import Data.Data (Data (..), Typeable) import Data.Either -import Data.Function (on) -import Data.List hiding (delete) +import Data.Function (on) +import Data.List.Compat import Data.Maybe -import Data.Monoid (Monoid (..), (<>)) +import Data.Monoid (Monoid (..), (<>)) import Data.Ord -import Prelude hiding (exp, mod) +import Data.Traversable +import Prelude.Compat hiding (exp, mod) import Safe import Control.Monad.Except @@ -54,10 +56,6 @@ -- | Do any of the (monadic) predicates match? anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM p l = return . not . null =<< filterM p l - --- | Flip of map. -for :: (Functor f) => f a -> (a -> b) -> f b -for = flip fmap -- | Read from a process returning both std err and out. readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String)) diff --git a/src/Fay/Compiler/Print.hs b/src/Fay/Compiler/Print.hs --- a/src/Fay/Compiler/Print.hs +++ b/src/Fay/Compiler/Print.hs @@ -1,12 +1,11 @@ {-# OPTIONS -fno-warn-orphans #-} -{-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -- | Code printers. Can be used to produce both pretty and not -- pretty output. -- -- Special constructors and symbols in Haskell are encoded to -- JavaScript appropriately. - module Fay.Compiler.Print where import Fay.Compiler.Prelude diff --git a/src/Fay/Config.hs b/src/Fay/Config.hs --- a/src/Fay/Config.hs +++ b/src/Fay/Config.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} -- | Configuring the compiler - module Fay.Config ( Config ( configOptimize diff --git a/src/Fay/Convert.hs b/src/Fay/Convert.hs --- a/src/Fay/Convert.hs +++ b/src/Fay/Convert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -18,7 +19,7 @@ import Fay.Compiler.Prelude -import Control.Monad.State +import Control.Monad.State (evalStateT, get, lift, put) import Control.Spoon import Data.Aeson import Data.Aeson.Types (parseEither) diff --git a/src/haskell-names/Language/Haskell/Names/Annotated.hs b/src/haskell-names/Language/Haskell/Names/Annotated.hs --- a/src/haskell-names/Language/Haskell/Names/Annotated.hs +++ b/src/haskell-names/Language/Haskell/Names/Annotated.hs @@ -17,6 +17,7 @@ , annotate ) where +import Fay.Compiler.Prelude import qualified Language.Haskell.Names.GlobalSymbolTable as Global import qualified Language.Haskell.Names.LocalSymbolTable as Local import Language.Haskell.Names.Open.Base @@ -24,10 +25,8 @@ import Language.Haskell.Names.RecordWildcards import Language.Haskell.Names.Types -import Control.Applicative import Data.Lens.Light import Data.Proxy -import Data.Typeable (Typeable) import Language.Haskell.Exts.Annotated import Type.Eq diff --git a/src/haskell-names/Language/Haskell/Names/Exports.hs b/src/haskell-names/Language/Haskell/Names/Exports.hs --- a/src/haskell-names/Language/Haskell/Names/Exports.hs +++ b/src/haskell-names/Language/Haskell/Names/Exports.hs @@ -1,10 +1,13 @@ {-# OPTIONS -fno-warn-name-shadowing #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Names.Exports ( processExports ) where +import Fay.Compiler.Prelude + import Fay.Compiler.ModuleT import Language.Haskell.Names.GlobalSymbolTable as Global import Language.Haskell.Names.ModuleSymbols @@ -13,11 +16,7 @@ import Language.Haskell.Names.Types (Error (..), GName (..), ModuleNameS, NameInfo (..), Scoped (..), Symbols (..), mkTy, mkVal, st_origName) -import Control.Applicative -import Control.Arrow -import Control.Monad -import Control.Monad.Writer -import Data.Data +import Control.Monad.Writer (WriterT (WriterT), runWriterT) import qualified Data.Map as Map import qualified Data.Set as Set import Language.Haskell.Exts.Annotated @@ -51,7 +50,7 @@ -> m (ExportSpec (Scoped l), Symbols) resolveExportSpec tbl exp = case exp of - EVar l ns@(NoNamespace {}) qn -> return $ + EVar l qn -> return $ case Global.lookupValue qn tbl of Global.Error err -> (scopeError err exp, mempty) @@ -59,20 +58,19 @@ let s = mkVal i in (EVar (Scoped (Export s) l) - (noScope ns) (Scoped (GlobalValue i) <$> qn), s) Global.Special {} -> error "Global.Special in export list?" - EVar _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME - EAbs l qn -> return $ + EAbs l ns qn -> return $ case Global.lookupType qn tbl of Global.Error err -> (scopeError err exp, mempty) Global.Result i -> let s = mkTy i in - (EAbs (Scoped (Export s) l) + (EAbs (Scoped (Export s) l) (noScope ns) (Scoped (GlobalType i) <$> qn), s) Global.Special {} -> error "Global.Special in export list?" + EAbs _ NoNamespace{} _ -> error "resolveExportSpec: 'type' namespace is not supported yet" -- FIXME EThingAll l qn -> return $ case Global.lookupType qn tbl of Global.Error err -> diff --git a/src/haskell-names/Language/Haskell/Names/GetBound.hs b/src/haskell-names/Language/Haskell/Names/GetBound.hs --- a/src/haskell-names/Language/Haskell/Names/GetBound.hs +++ b/src/haskell-names/Language/Haskell/Names/GetBound.hs @@ -2,21 +2,22 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} module Language.Haskell.Names.GetBound ( GetBound(..) ) where +import Fay.Compiler.Prelude import qualified Language.Haskell.Names.GlobalSymbolTable as Global import Language.Haskell.Names.RecordWildcards import Language.Haskell.Names.SyntaxUtils -import Control.Applicative -import Data.Data import Data.Generics.Uniplate.Data import Language.Haskell.Exts.Annotated + -- | Get bound value identifiers. class GetBound a l | a -> l where -- | For record wildcards we need to know which fields the given @@ -72,6 +73,7 @@ InlineConlikeSig{} -> [] ClosedTypeFamDecl{} -> [] MinimalPragma{} -> [] + _ -> error "Unsupported syntax" instance (Data l) => GetBound (QualConDecl l) l where getBound ctx (QualConDecl _ _ _ d) = getBound ctx d diff --git a/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs --- a/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs +++ b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs @@ -13,15 +13,12 @@ , toSymbols ) where +import Fay.Compiler.Prelude hiding (empty) import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Types -import Control.Applicative hiding (empty) -import Control.Arrow -import Data.Data import Data.Lens.Light import qualified Data.Map as Map -import Data.Monoid import qualified Data.Set as Set import Language.Haskell.Exts.Annotated as HSE diff --git a/src/haskell-names/Language/Haskell/Names/Imports.hs b/src/haskell-names/Language/Haskell/Names/Imports.hs --- a/src/haskell-names/Language/Haskell/Names/Imports.hs +++ b/src/haskell-names/Language/Haskell/Names/Imports.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -fno-warn-name-shadowing #-} {-# OPTIONS -fno-warn-orphans #-} -- ModName (ModuleName l) module Language.Haskell.Names.Imports (processImports) where +import Fay.Compiler.Prelude + import Fay.Compiler.ModuleT import qualified Language.Haskell.Names.GlobalSymbolTable as Global import Language.Haskell.Names.ScopeUtils import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Types -import Control.Applicative -import Control.Arrow -import Control.Monad.Writer -import Data.Either -import Data.Foldable (fold, foldMap) +import Control.Monad.Writer (WriterT (WriterT), runWriterT) +import Data.Foldable (fold) import Data.Lens.Light import qualified Data.Map as Map -import Data.Maybe import qualified Data.Set as Set import Language.Haskell.Exts.Annotated @@ -149,7 +148,7 @@ -- NB: this can be made more efficient resolveImportSpec mod isHiding syms spec = case spec of - IVar _ (NoNamespace {}) n -> + IVar _ n -> let matches = mconcat $ -- Strictly speaking, the isConstructor check is unnecessary @@ -165,8 +164,7 @@ matches spec -- FIXME think about data families etc. - IVar _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME - IAbs _ n + IAbs _ _ n | isHiding -> -- This is a bit special. 'C' may match both types/classes and -- data constructors. @@ -191,6 +189,7 @@ (ENotExported Nothing n mod) matches spec + IAbs _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME -- FIXME -- What about things like: diff --git a/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs b/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs --- a/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs +++ b/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs @@ -1,5 +1,6 @@ -- | This module is designed to be imported qualified. {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Names.LocalSymbolTable ( Table , empty @@ -7,11 +8,11 @@ , addValue ) where +import Fay.Compiler.Prelude hiding (empty) import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Types import qualified Data.Map as Map -import Data.Monoid import Language.Haskell.Exts.Annotated -- | Local symbol table — contains locally bound names diff --git a/src/haskell-names/Language/Haskell/Names/Open/Base.hs b/src/haskell-names/Language/Haskell/Names/Open/Base.hs --- a/src/haskell-names/Language/Haskell/Names/Open/Base.hs +++ b/src/haskell-names/Language/Haskell/Names/Open/Base.hs @@ -11,6 +11,7 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,18 +39,15 @@ , lTable ) where +import Fay.Compiler.Prelude import Language.Haskell.Names.GetBound import qualified Language.Haskell.Names.GlobalSymbolTable as Global import qualified Language.Haskell.Names.LocalSymbolTable as Local import Language.Haskell.Names.RecordWildcards -import Control.Applicative import Control.Monad.Identity import Data.Generics.Traversable import Data.Lens.Light -import Data.List -import Data.Monoid -import Data.Typeable import GHC.Exts (Constraint) import Language.Haskell.Exts.Annotated diff --git a/src/haskell-names/Language/Haskell/Names/Open/Derived.hs b/src/haskell-names/Language/Haskell/Names/Open/Derived.hs --- a/src/haskell-names/Language/Haskell/Names/Open/Derived.hs +++ b/src/haskell-names/Language/Haskell/Names/Open/Derived.hs @@ -80,3 +80,5 @@ deriveGTraversable ''Overlap deriveGTraversable ''Sign deriveGTraversable ''Namespace +deriveGTraversable ''Role +deriveGTraversable ''PatternSynDirection diff --git a/src/haskell-names/Language/Haskell/Names/Open/Instances.hs b/src/haskell-names/Language/Haskell/Names/Open/Instances.hs --- a/src/haskell-names/Language/Haskell/Names/Open/Instances.hs +++ b/src/haskell-names/Language/Haskell/Names/Open/Instances.hs @@ -13,18 +13,15 @@ {-# LANGUAGE MonoLocalBinds #-} module Language.Haskell.Names.Open.Instances () where +import Fay.Compiler.Prelude import Language.Haskell.Names.GetBound import Language.Haskell.Names.Open.Base import Language.Haskell.Names.Open.Derived () import Language.Haskell.Names.RecordWildcards import Language.Haskell.Names.Types -import Control.Applicative -import qualified Data.Data as D import Data.Lens.Light -import Data.List import qualified Data.Traversable as T -import Data.Typeable import Language.Haskell.Exts.Annotated c :: Applicative w => c -> w c @@ -40,7 +37,7 @@ sc -: b = (b, sc) infix 5 -: -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Decl l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Decl l) where rtraverse e sc = case e of -- N.B. We do not add pat to the local scope. @@ -68,10 +65,10 @@ <| sc -: ty _ -> defaultRtraverse e sc -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Type l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Type l) where rtraverse e sc = defaultRtraverse e (exprT sc) -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (DeclHead l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (DeclHead l) where rtraverse e sc = case e of DHead l name -> @@ -85,7 +82,7 @@ <| binderT sc -: name _ -> defaultRtraverse e sc -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (ConDecl l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (ConDecl l) where rtraverse e sc = case e of ConDecl l name tys -> @@ -106,7 +103,7 @@ <| sc -: fields -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (FieldDecl l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (FieldDecl l) where rtraverse e sc = case e of FieldDecl l name tys -> @@ -115,7 +112,7 @@ <| binderV sc -: name <| sc -: tys -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Pat l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Pat l) where rtraverse e sc = case e of PVar l name -> @@ -159,7 +156,7 @@ <| sc -: pat _ -> defaultRtraverse e sc -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (PatField l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (PatField l) where rtraverse e sc = case e of PFieldPat l qn pat -> @@ -183,7 +180,7 @@ , GetBound (a l) l , Applicative w , SrcInfo l - , D.Data l + , Data l , ?alg :: Alg w) => [a l] -> Scope -> (w [a l], Scope) chain pats sc = @@ -196,7 +193,7 @@ (ps', sc'') = chain ps sc' in ((:) <$> p' <*> ps', sc'') -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Match l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Match l) where rtraverse e sc = case e of Match l name pats rhs mbWhere -> @@ -222,7 +219,7 @@ -- NB: there is an inefficiency here (and in similar places), because we -- call intro on the same subtree several times. Maybe tackle it later. -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Binds l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Binds l) where rtraverse e sc = case e of BDecls l decls -> @@ -233,7 +230,7 @@ <| scWithBinds -: decls _ -> defaultRtraverse e sc -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Exp l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Exp l) where rtraverse e sc = case e of Let l bnds body -> @@ -297,7 +294,7 @@ _ -> defaultRtraverse e sc -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Alt l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (Alt l) where rtraverse e sc = case e of Alt l pat guardedAlts mbWhere -> @@ -311,7 +308,7 @@ <| scWithBinds -: guardedAlts <| scWithBinds -: mbWhere -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (GuardedRhs l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (GuardedRhs l) where rtraverse e sc = case e of GuardedRhs l stmts exp -> @@ -322,11 +319,11 @@ <*> stmts' <| scWithStmts -: exp -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable [Stmt l] where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable [Stmt l] where rtraverse e sc = fst $ chain e sc -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (QualStmt l) where +instance (Resolvable l, SrcInfo l, Data l) => Resolvable (QualStmt l) where rtraverse e sc = case e of QualStmt {} -> defaultRtraverse e sc diff --git a/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs b/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs --- a/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs +++ b/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs @@ -8,14 +8,12 @@ , sv_parent ) where +import Fay.Compiler.Prelude import qualified Language.Haskell.Names.GlobalSymbolTable as Global import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Types -import Control.Applicative -import Control.Arrow import Data.Lens.Light -import Data.Monoid import qualified Data.Set as Set import Language.Haskell.Exts.Annotated diff --git a/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs b/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs --- a/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs +++ b/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs @@ -48,7 +48,7 @@ getModuleHead :: Module l -> ModuleHead l getModuleHead (Module _ (Just mh) _ _ _) = mh getModuleHead (XmlHybrid _ (Just mh) _ _ _ _ _ _ _) = mh -getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (NoNamespace l) (UnQual l (Ident l "main"))])) +getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (UnQual l (Ident l "main"))])) where l = ann m qNameToName :: QName l -> Name l diff --git a/src/haskell-names/Language/Haskell/Names/Types.hs b/src/haskell-names/Language/Haskell/Names/Types.hs --- a/src/haskell-names/Language/Haskell/Names/Types.hs +++ b/src/haskell-names/Language/Haskell/Names/Types.hs @@ -29,13 +29,11 @@ ) where import {-# SOURCE #-} qualified Language.Haskell.Names.GlobalSymbolTable as Global +import Fay.Compiler.Prelude -import Data.Data import Data.Foldable as F import Data.Lens.Light -import Data.Monoid import qualified Data.Set as Set -import Data.Traversable import Language.Haskell.Exts.Annotated import Text.Printf diff --git a/src/tests/Test/Desugar.hs b/src/tests/Test/Desugar.hs --- a/src/tests/Test/Desugar.hs +++ b/src/tests/Test/Desugar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} module Test.Desugar ( tests , devTest @@ -91,12 +92,17 @@ parseAndDesugar :: String -> String -> IO (Module SrcLoc, Either CompileError (Module SrcLoc)) parseAndDesugar name s = - case parseFay "test" s :: ParseResult (Module SrcLoc) of + case parseFay "test" s :: ParseResult (Module SrcSpanInfo) of ParseFailed a b -> error $ show (name, a, b) - ParseOk m -> do - d <- desugar' "gen" noLoc m - return (m,d) - + ParseOk (fmap srcSpanInfoToSrcLoc -> m) -> do + d <- desugar' "gen" noLoc $ m + return (m, d) + where + srcSpanInfoToSrcLoc :: SrcSpanInfo -> SrcLoc + srcSpanInfoToSrcLoc = (\ss -> SrcLoc { srcFilename = srcSpanFilename ss + , srcLine = srcSpanStartLine ss + , srcColumn = srcSpanStartColumn ss + }) . srcInfoSpan doDesugar :: String -> String -> String -> Assertion doDesugar testName a b = do (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll testName a b @@ -106,8 +112,8 @@ parseAndDesugarAll :: String -> String -> String -> IO (Module SrcLoc, Module SrcLoc, Module SrcLoc) parseAndDesugarAll testName a b = do - (originalExpected',Right desugaredExpected) <- parseAndDesugar (testName ++ " expected") a - (_ ,Right desugared ) <- parseAndDesugar (testName ++ " input") b + (originalExpected',Right desugaredExpected) <- parseAndDesugar (testName ++ " expected") a + (_ ,Right desugared ) <- parseAndDesugar (testName ++ " input") b -- We need to desugar parens in the original module since we -- strip it away in desugaring but there isn't alawys a way to construct -- this paren directly from a source string diff --git a/src/tests/Tests.hs b/src/tests/Tests.hs --- a/src/tests/Tests.hs +++ b/src/tests/Tests.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} -- | Generate the web site/documentation for the Fay project. -- @@ -7,8 +8,9 @@ module Main where -import Fay import Fay.Compiler.Prelude + +import Fay import qualified Test.CommandLine as Cmd import qualified Test.Compile as Compile import qualified Test.Convert as Convert