module Language.PureScript.Sugar.TypeClasses
( desugarTypeClasses
, typeClassMemberName
, superClassDictionaryNames
) where
import Prelude ()
import Prelude.Compat
import Language.PureScript.Crash
import Language.PureScript.AST hiding (isExported)
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Externs
import Language.PureScript.Sugar.CaseDeclarations
import Control.Monad.Supply.Class
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
import Control.Arrow (first, second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
import Data.List ((\\), find, sortBy)
import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])
type Desugar = StateT MemberMap
desugarTypeClasses
:: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
=> [ExternsFile]
-> [Module]
-> m [Module]
desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
where
initialState :: MemberMap
initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
fromExternsDecl
:: ModuleName
-> ExternsDeclaration
-> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))
fromExternsDecl _ _ = Nothing
desugarModule
:: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
=> Module
-> Desugar m Module
desugarModule (Module ss coms name decls (Just exps)) = do
(newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
where
classesFirst :: Declaration -> Declaration -> Ordering
classesFirst d1 d2
| isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT
| not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT
| otherwise = EQ
desugarModule _ = internalError "Exports should have been elaborated in name desugaring"
desugarDecl
:: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
=> ModuleName
-> [DeclarationRef]
-> Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration name args implies members) = do
modify (M.insert (mn, name) (args, implies, members))
return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"
go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do
desugared <- desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
return (expRef name className tys, [d, dictDecl])
go (PositionedDeclaration pos com d) = do
(dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
return (dr, map (PositionedDeclaration pos com) ds)
go other = return (Nothing, [other])
expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef
expRef name className tys
| isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
| otherwise = Nothing
isExportedClass :: Qualified (ProperName 'ClassName) -> Bool
isExportedClass = isExported (elem . TypeClassRef)
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 :: Type -> [Qualified (ProperName 'TypeName)]
getConstructors = everythingOnTypes (++) getConstructor
where
getConstructor (TypeConstructor tcname) = [tcname]
getConstructor _ = []
memberToNameAndType :: Declaration -> (Ident, Type)
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
memberToNameAndType _ = internalError "Invalid declaration in type class definition"
typeClassDictionaryDeclaration
:: ProperName 'ClassName
-> [(String, Maybe Kind)]
-> [Constraint]
-> [Declaration]
-> Declaration
typeClassDictionaryDeclaration name args implies members =
let superclassTypes = superClassDictionaryNames implies `zip`
[ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)
| (superclass, tyArgs) <- implies
]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))
typeClassMemberToDictionaryAccessor
:: ModuleName
-> ProperName 'ClassName
-> [(String, Maybe Kind)]
-> Declaration
-> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
let className = Qualified (Just mn) name
in ValueDeclaration ident Private [] $ Right $
TypedValue False (TypeClassDictionaryAccessor className ident) $
moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"
unit :: Type
unit = TypeApp tyObject REmpty
typeInstanceDictionaryDeclaration
:: forall m
. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
=> Ident
-> ModuleName
-> [Constraint]
-> Qualified (ProperName 'ClassName)
-> [Type]
-> [Declaration]
-> Desugar m Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls =
rethrow (addHint (ErrorInInstance className tys)) $ do
m <- get
(args, implies, tyDecls) <-
maybe (throwError . errorMessage $ UnknownTypeClass className) return $
M.lookup (qualify mn className) m
case mapMaybe declName tyDecls \\ mapMaybe declName decls of
member : _ -> throwError . errorMessage $ MissingClassMember member
[] -> do
let instanceTys = map memberToNameAndType tyDecls
let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
let superclasses = superClassDictionaryNames implies `zip`
[ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
| (superclass, suTyArgs) <- implies
, let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
]
let props = ObjectLiteral (members ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className props
result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))
return result
where
declName :: Declaration -> Maybe Ident
declName (PositionedDeclaration _ _ d) = declName d
declName (ValueDeclaration ident _ _ _) = Just ident
declName (TypeDeclaration ident _) = Just ident
declName _ = Nothing
memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr
memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
_ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'
return val
memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
val <- memberToValue tys' d
return (PositionedValue pos com val)
memberToValue _ _ = internalError "Invalid declaration in type instance definition"
typeClassMemberName :: Declaration -> String
typeClassMemberName (TypeDeclaration ident _) = runIdent ident
typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d
typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"
superClassDictionaryNames :: [Constraint] -> [String]
superClassDictionaryNames supers =
[ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)
| (index, (pn, _)) <- zip [0..] supers
]