module Language.PureScript.Sugar.TypeClasses
( desugarTypeClasses
, typeClassMemberName
, superClassDictionaryNames
) where
import Prelude.Compat
import Control.Arrow (first, second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
import Control.Monad.Supply.Class
import Data.Graph
import Data.List (find, partition)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Set as S
import Data.Text (Text)
import qualified Language.PureScript.Constants as C
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors hiding (isExported)
import Language.PureScript.Externs
import Language.PureScript.Kinds
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names
import Language.PureScript.PSString (mkString)
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Types
import Language.PureScript.TypeClassDictionaries (superclassName)
type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData
type Desugar = StateT MemberMap
desugarTypeClasses
:: (MonadSupply m, MonadError MultipleErrors m)
=> [ExternsFile]
-> [Module]
-> m [Module]
desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
where
initialState :: MemberMap
initialState =
mconcat
[ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses
, M.mapKeys (qualify C.PrimRow) primRowClasses
, M.mapKeys (qualify C.PrimRowList) primRowListClasses
, M.mapKeys (qualify C.PrimSymbol) primSymbolClasses
, M.mapKeys (qualify C.PrimTypeError) primTypeErrorClasses
, M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
]
fromExternsDecl
:: ModuleName
-> ExternsDeclaration
-> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where
typeClass = makeTypeClassData args members implies deps
fromExternsDecl _ _ = Nothing
desugarModule
:: (MonadSupply m, MonadError MultipleErrors m)
=> Module
-> Desugar m Module
desugarModule (Module ss coms name decls (Just exps)) = do
let (classDecls, restDecls) = partition isTypeClassDeclaration decls
classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls
(classNewExpss, classDeclss) <- unzip <$> parU (stronglyConnComp classVerts) (desugarClassDecl name exps)
(restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps)
return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss)
where
desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m)
=> ModuleName
-> [DeclarationRef]
-> SCC Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d
desugarClassDecl _ _ (CyclicSCC ds') = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeClassDeclaration (map classDeclName ds')
superClassesNames :: Declaration -> [Qualified (ProperName 'ClassName)]
superClassesNames (TypeClassDeclaration _ _ _ implies _ _) = fmap constraintName implies
superClassesNames _ = []
constraintName :: SourceConstraint -> Qualified (ProperName 'ClassName)
constraintName (Constraint _ cName _ _) = cName
classDeclName :: Declaration -> Qualified (ProperName 'ClassName)
classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (Just name) pn
classDeclName _ = internalError "Expected TypeClassDeclaration"
desugarModule _ = internalError "Exports should have been elaborated in name desugaring"
desugarDecl
:: (MonadSupply m, MonadError MultipleErrors m)
=> ModuleName
-> [DeclarationRef]
-> Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration sa name args implies deps members) = do
modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps))
return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"
go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) = do
desugared <- desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared
return (expRef name className tys, [d, dictDecl])
go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do
let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps)
return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]])
go other = return (Nothing, [other])
expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef
expRef name className tys
| isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name
| otherwise = Nothing
isExportedClass :: Qualified (ProperName 'ClassName) -> Bool
isExportedClass = isExported (elem . TypeClassRef genSpan)
isExportedType :: Qualified (ProperName 'TypeName) -> Bool
isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
isExported
:: (ProperName a -> [DeclarationRef] -> Bool)
-> Qualified (ProperName a)
-> Bool
isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
isExported _ _ = internalError "Names should have been qualified in name desugaring"
matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool
matchesTypeRef pn (TypeRef _ pn' _) = pn == pn'
matchesTypeRef _ _ = False
getConstructors :: SourceType -> [Qualified (ProperName 'TypeName)]
getConstructors = everythingOnTypes (++) getConstructor
where
getConstructor (TypeConstructor _ tcname) = [tcname]
getConstructor _ = []
genSpan :: SourceSpan
genSpan = internalModuleSourceSpan "<generated>"
memberToNameAndType :: Declaration -> (Ident, SourceType)
memberToNameAndType (TypeDeclaration td) = unwrapTypeDeclaration td
memberToNameAndType _ = internalError "Invalid declaration in type class definition"
typeClassDictionaryDeclaration
:: SourceAnn
-> ProperName 'ClassName
-> [(Text, Maybe SourceKind)]
-> [SourceConstraint]
-> [Declaration]
-> Declaration
typeClassDictionaryDeclaration sa name args implies members =
let superclassTypes = superClassDictionaryNames implies `zip`
[ function unit (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName superclass)) tyArgs)
| (Constraint _ superclass tyArgs _) <- implies
]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
toRowListItem (l, t) = srcRowListItem (Label $ mkString l) t
in TypeSynonymDeclaration sa (coerceProperName name) args (srcTypeApp tyRecord $ rowFromList (map toRowListItem mtys, srcREmpty))
typeClassMemberToDictionaryAccessor
:: ModuleName
-> ProperName 'ClassName
-> [(Text, Maybe SourceKind)]
-> Declaration
-> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) =
let className = Qualified (Just mn) name
in ValueDecl sa ident Private [] $
[MkUnguarded (
TypedValue False (TypeClassDictionaryAccessor className ident) $
moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className (map (srcTypeVar . fst) args) Nothing) ty))
)]
typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"
unit :: SourceType
unit = srcTypeApp tyRecord srcREmpty
typeInstanceDictionaryDeclaration
:: forall m
. (MonadSupply m, MonadError MultipleErrors m)
=> SourceAnn
-> Ident
-> ModuleName
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> [Declaration]
-> Desugar m Declaration
typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls =
rethrow (addHint (ErrorInInstance className tys)) $ do
m <- get
TypeClassData{..} <-
maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $
M.lookup (qualify mn className) m
let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers
let declaredMembers = S.fromList $ mapMaybe declIdent decls
case filter (\(ident, _) -> not $ S.member ident declaredMembers) memberTypes of
hd : tl -> throwError . errorMessage' ss $ MissingClassMember (hd NEL.:| tl)
[] -> do
members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
let superclasses = superClassDictionaryNames typeClassSuperclasses `zip`
[ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs)
| (Constraint _ superclass suTyArgs _) <- typeClassSuperclasses
, let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
]
let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses)
dictTy = foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (foldr srcConstrainedType dictTy deps)
dict = TypeClassDictionaryConstructorApp className props
result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]
return result
where
memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr
memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do
_ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys'
return val
memberToValue _ _ = internalError "Invalid declaration in type instance definition"
declIdent :: Declaration -> Maybe Ident
declIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
declIdent (TypeDeclaration td) = Just (tydeclIdent td)
declIdent _ = Nothing
typeClassMemberName :: Declaration -> Text
typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid declaration in type class definition") . fmap runIdent . declIdent
superClassDictionaryNames :: [Constraint a] -> [Text]
superClassDictionaryNames supers =
[ superclassName pn index
| (index, Constraint _ pn _ _) <- zip [0..] supers
]