module Language.PureScript.Sugar.Names
( desugarImports
, desugarImportsWithEnv
, Env
, ImportRecord(..)
, ImportProvenance(..)
, Imports(..)
, Exports(..)
) where
import Prelude ()
import Prelude.Compat
import Data.List (find, nub)
import Data.Maybe (fromMaybe, mapMaybe)
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer (MonadWriter(..), censor)
import Control.Monad.State.Lazy
import qualified Data.Map as M
import qualified Data.Set as S
import Language.PureScript.Crash
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Errors
import Language.PureScript.Traversals
import Language.PureScript.Externs
import Language.PureScript.Sugar.Names.Env
import Language.PureScript.Sugar.Names.Imports
import Language.PureScript.Sugar.Names.Exports
import Language.PureScript.Linter.Imports
desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
desugarImports externs modules =
fmap snd (desugarImportsWithEnv externs modules)
desugarImportsWithEnv
:: forall m
. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> [ExternsFile]
-> [Module]
-> m (Env, [Module])
desugarImportsWithEnv externs modules = do
env <- silence $ foldM externsEnv primEnv externs
modules' <- traverse updateExportRefs modules
(modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules'
(env',) <$> traverse (renameInModule' env') modules''
where
silence :: m a -> m a
silence = censor (const mempty)
externsEnv :: Env -> ExternsFile -> m Env
externsEnv env ExternsFile{..} = do
let members = Exports{..}
ss = internalModuleSourceSpan "<Externs>"
env' = M.insert efModuleName (ss, nullImports, members) env
fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])
imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
exps <- resolveExports env' efModuleName imps members efExports
return $ M.insert efModuleName (ss, imps, exps) env
where
exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
exportedTypes = mapMaybe toExportedType efExports
where
toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)
where
forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)
forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
forTyCon _ = Nothing
toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r
toExportedType _ = Nothing
exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
exportedTypeClasses = mapMaybe toExportedTypeClass efExports
where
toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)
toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r
toExportedTypeClass _ = Nothing
exportedValues :: [(Ident, ModuleName)]
exportedValues = mapMaybe toExportedValue efExports
where
toExportedValue (ValueRef ident) = Just (ident, efModuleName)
toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r
toExportedValue _ = Nothing
updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
updateEnv (ms, env) m@(Module ss _ mn _ refs) =
case mn `M.lookup` env of
Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
Nothing -> do
members <- findExportable m
let env' = M.insert mn (ss, nullImports, members) env
(m', imps) <- resolveImports env' m
exps <- maybe (return members) (resolveExports env' mn imps members) refs
return (m' : ms, M.insert mn (ss, imps, exps) env)
renameInModule' :: Env -> Module -> m Module
renameInModule' env m@(Module _ _ mn _ _) =
warnAndRethrow (addHint (ErrorInModule mn)) $ do
let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
(m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)
lintImports m env used
return m'
elaborateExports :: Exports -> Module -> Module
elaborateExports exps (Module ss coms mn decls refs) =
Module ss coms mn decls $
Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++
map TypeClassRef (my exportedTypeClasses) ++
map ValueRef (my exportedValues) ++
maybe [] (filter isModuleRef) refs
where
my :: (Exports -> [(a, ModuleName)]) -> [a]
my f = fst `map` filter ((== mn) . snd) (f exps)
renameInModule
:: forall m
. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
=> Env
-> Imports
-> Module
-> m Module
renameInModule env imports (Module ss coms mn decls exps) =
Module ss coms mn <$> parU decls go <*> pure exps
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
updateDecl
:: (Maybe SourceSpan, [Ident])
-> Declaration
-> m ((Maybe SourceSpan, [Ident]), Declaration)
updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =
return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
(,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
(,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
(,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds)
updateDecl (pos, bound) (TypeDeclaration name ty) =
(,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (ExternDeclaration name ty) =
(,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (FixityDeclaration fx name alias) =
(,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias)
updateDecl s d = return (s, d)
updateValue
:: (Maybe SourceSpan, [Ident])
-> Expr
-> m ((Maybe SourceSpan, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _ _) =
return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') =
return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') = do
let args = mapMaybe letBoundVariable ds
unless (length (nub args) == length args) $
maybe id rethrowWithPosition pos $
throwError . errorMessage $ OverlappingNamesInLet
return ((pos, args ++ bound), Let ds val')
updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
updateValue s@(pos, _) (Constructor name) =
(,) s <$> (Constructor <$> updateDataConstructorName name pos)
updateValue s@(pos, _) (TypedValue check val ty) =
(,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
updateBinder
:: (Maybe SourceSpan, [Ident])
-> Binder
-> m ((Maybe SourceSpan, [Ident]), Binder)
updateBinder (_, bound) v@(PositionedBinder pos _ _) =
return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) =
(,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
updateBinder s@(pos, _) (OpBinder name) =
(,) s <$> (OpBinder <$> updateValueName name pos)
updateBinder s (TypedBinder t b) = do
(s'@ (span', _), b') <- updateBinder s b
t' <- updateTypesEverywhere span' t
return (s', TypedBinder t' b')
updateBinder s v =
return (s, v)
updateCase
:: (Maybe SourceSpan, [Ident])
-> CaseAlternative
-> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
updateCase (pos, bound) c@(CaseAlternative bs _) =
return ((pos, concatMap binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
letBoundVariable _ = Nothing
updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
updateTypesEverywhere pos = everywhereOnTypesM updateType
where
updateType :: Type -> m Type
updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
updateType t = return t
updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)
updateTypeName
:: Qualified (ProperName 'TypeName)
-> Maybe SourceSpan
-> m (Qualified (ProperName 'TypeName))
updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)
updateDataConstructorName
:: Qualified (ProperName 'ConstructorName)
-> Maybe SourceSpan
-> m (Qualified (ProperName 'ConstructorName))
updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)
updateClassName
:: Qualified (ProperName 'ClassName)
-> Maybe SourceSpan
-> m (Qualified (ProperName 'ClassName))
updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)
updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)
resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)
resolve as name = mkQualified name <$> name `lookup` as
resolveType
:: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
-> ProperName 'TypeName
-> Maybe (Qualified (ProperName 'TypeName))
resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys
resolveDctor
:: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
-> ProperName 'ConstructorName
-> Maybe (Qualified (ProperName 'ConstructorName))
resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys
update
:: (Ord a, Show a)
=> (Qualified a -> SimpleErrorMessage)
-> M.Map (Qualified a) [ImportRecord a]
-> (Exports -> a -> Maybe (Qualified a))
-> (Qualified a -> Name)
-> (a -> String)
-> Qualified a
-> Maybe SourceSpan
-> m (Qualified a)
update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $
case (M.lookup qname imps, mn') of
(Just options, _) -> do
(mnNew, mnOrig) <- checkImportConflicts mn render options
modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
return $ Qualified (Just mnOrig) name
(Nothing, Just mn'') -> do
case M.lookup mn'' env of
Nothing
| mn'' `S.member` importedVirtualModules imports -> throwUnknown
| otherwise -> throwError . errorMessage $ UnknownModule mn''
Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)
_ -> throwUnknown
where
positioned err = case pos of
Nothing -> err
Just pos' -> rethrowWithPosition pos' err
throwUnknown = throwError . errorMessage $ unknown qname
updateExportRefs
:: forall m
. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Module
-> m Module
updateExportRefs (Module ss coms mn decls exps) =
Module ss coms mn decls <$> traverse (traverse updateRef) exps
where
updateRef :: DeclarationRef -> m DeclarationRef
updateRef (ProperRef name)
| ProperName name `elem` classNames = do
tell . errorMessage . DeprecatedClassExport $ ProperName name
return . TypeClassRef $ ProperName name
| otherwise = return $ TypeRef (ProperName name) (Just [])
updateRef (PositionedDeclarationRef pos com ref) =
warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref
updateRef other = return other
classNames :: [ProperName 'ClassName]
classNames = mapMaybe go decls
where
go (PositionedDeclaration _ _ d) = go d
go (TypeClassDeclaration name _ _ _) = Just name
go _ = Nothing