module Language.PureScript.Sugar.TypeClasses
( desugarTypeClasses
, typeClassMemberName
, superClassDictionaryNames
) where
import Prelude.Compat
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors hiding (isExported)
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 Language.PureScript.Label (Label(..))
import Language.PureScript.PSString (mkString)
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
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
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 =
M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses
`M.union` 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
(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
:: (MonadSupply m, MonadError MultipleErrors m)
=> ModuleName
-> [DeclarationRef]
-> Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration name args implies deps members) = do
modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps))
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 d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do
let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))])
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
-> [(Text, Maybe Kind)]
-> [Constraint]
-> [Declaration]
-> Declaration
typeClassDictionaryDeclaration name args implies members =
let superclassTypes = superClassDictionaryNames implies `zip`
[ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)
| (Constraint superclass tyArgs _) <- implies
]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty))
typeClassMemberToDictionaryAccessor
:: ModuleName
-> ProperName 'ClassName
-> [(Text, 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 [Constraint className (map (TypeVar . fst) args) Nothing] 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 tyRecord REmpty
typeInstanceDictionaryDeclaration
:: forall 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
TypeClassData{..} <-
maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $
M.lookup (qualify mn className) m
case map fst typeClassMembers \\ mapMaybe declName decls of
member : _ -> throwError . errorMessage $ MissingClassMember member
[] -> do
let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers
members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
let superclasses = superClassDictionaryNames typeClassSuperclasses `zip`
[ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
| (Constraint superclass suTyArgs _) <- typeClassSuperclasses
, let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
]
let props = Literal $ ObjectLiteral $ map (first mkString) (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 -> Text
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] -> [Text]
superClassDictionaryNames supers =
[ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer))
| (index, Constraint pn _ _) <- zip [0..] supers
]