module Language.PureScript.Sugar.TypeClasses (
desugarTypeClasses
) where
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Supply
import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
import qualified Language.PureScript.Constants as C
import Control.Applicative
import Control.Monad.Error
import Control.Monad.State
import Control.Arrow (first, second)
import Data.List ((\\), find)
import Data.Monoid ((<>))
import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
type MemberMap = M.Map (ModuleName, ProperName) Declaration
type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
desugarModule (Module name decls (Just exps)) = do
(newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
desugarModule _ = error "Exports should have been elaborated in name desugaring"
desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration name args implies members) = do
modify (M.insert (mn, name) d)
return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
go d@(TypeInstanceDeclaration name deps className tys members) = do
desugared <- lift $ desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
return $ (expRef name className tys, [d, dictDecl])
go (PositionedDeclaration pos d) = do
(dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
return (dr, map (PositionedDeclaration pos) ds)
go other = return (Nothing, [other])
expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
expRef name className tys
| isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
| otherwise = Nothing
isExportedClass :: Qualified ProperName -> Bool
isExportedClass = isExported (elem . TypeClassRef)
isExportedType :: Qualified ProperName -> Bool
isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
isExported _ _ = error "Names should have been qualified in name desugaring"
matchesTypeRef :: ProperName -> DeclarationRef -> Bool
matchesTypeRef pn (TypeRef pn' _) = pn == pn'
matchesTypeRef _ _ = False
getConstructors :: Type -> [Qualified ProperName]
getConstructors = everythingOnTypes (++) getConstructor
getConstructor :: Type -> [Qualified ProperName]
getConstructor (TypeConstructor tcname) = [tcname]
getConstructor _ = []
memberToNameAndType :: Declaration -> (Ident, Type)
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = error "Invalid declaration in type class definition"
typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args implies members =
let superclassTypes = [ (fieldName, function unit tySynApp)
| (index, (superclass, tyArgs)) <- zip [0..] implies
, let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
, let fieldName = mkSuperclassDictionaryName superclass index
]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
ValueDeclaration ident TypeClassAccessorImport [] Nothing $
TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String
mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index
unit :: Type
unit = TypeApp tyObject REmpty
typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls =
rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do
m <- get
(TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
M.lookup (qualify mn className) m
case mapMaybe declName tyDecls \\ mapMaybe declName decls of
x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
[] -> do
let instanceTys = map memberToNameAndType tyDecls
let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls
let superclasses =
[ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))
| (index, (superclass, suTyArgs)) <- zip [0..] implies
, let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
, let fieldName = mkSuperclassDictionaryName superclass index
]
let memberNames' = ObjectLiteral (memberNames ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor className) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className memberNames'
result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (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
memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)
memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
_ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
let memberValue = typeInstanceDictionaryEntryValue d
return (ident, memberValue)
memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
(ident, val) <- memberToNameAndValue tys' d
return (ident, PositionedValue pos val)
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
typeInstanceDictionaryEntryValue :: Declaration -> Expr
typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"