git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Generic Deriving
e2e78caU-CIQDEV\gbazerman
purescript.cabal+1
compare with golang
unifiedsplit
@@ -110,6 +110,7 @@ library
110 Language.PureScript.Sugar.TypeDeclarations
110 Language.PureScript.Sugar.TypeDeclarations
111 Language.PureScript.Traversals
111 Language.PureScript.Traversals
112 Language.PureScript.TypeChecker
112 Language.PureScript.TypeChecker
113+ Language.PureScript.TypeChecker.Deriving
113 Language.PureScript.TypeChecker.Entailment
114 Language.PureScript.TypeChecker.Entailment
114 Language.PureScript.TypeChecker.Kinds
115 Language.PureScript.TypeChecker.Kinds
115 Language.PureScript.TypeChecker.Monad
116 Language.PureScript.TypeChecker.Monad
src/Language/PureScript/AST/Declarations.hs+3
@@ -371,6 +371,9 @@ data Expr
371 --
371 --
372 | SuperClassDictionary (Qualified ProperName) [Type]
372 | SuperClassDictionary (Qualified ProperName) [Type]
373 -- |
373 -- |
374+ -- A placeholder for a member function of a typeclass instance. To be elaborated during typechecking. (function name, class name, name of the type gaining the instance).
375+ | TypeClassInstanceMemberFunction Ident (Qualified ProperName) (Qualified ProperName)
376+ -- |
374 -- A value with source position information
377 -- A value with source position information
375 --
378 --
376 | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
379 | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Sugar/TypeClasses.hs+24−1
@@ -229,8 +229,29 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type
229unit :: Type
229unit :: Type
230unit = TypeApp tyObject REmpty
230unit = TypeApp tyObject REmpty
231
231
232+fillDerivingDecls :: (MonadError MultipleErrors m, Applicative m) => Qualified ProperName -> [Type] -> [Declaration] -> [Declaration] -> Desugar m [Declaration]
233+fillDerivingDecls className tys tyDecls decls = do
234+ let missingDecls = mapMaybe declName tyDecls \\ mapMaybe declName decls
235+ let mkMissingDecl cls fun =
236+ case tys of
237+ [TypeConstructor t] | unQualify className == ProperName cls && Ident fun `elem` missingDecls -> return [ValueDeclaration (Ident fun) Value [] (Right $ TypeClassInstanceMemberFunction (Ident fun) className t)]
238+ _ -> return []
239+ extraDecls <- concat <$> mapM (uncurry mkMissingDecl)
240+ [("Generic","toSpine")
241+ ,("Generic","fromSpine")
242+ ,("Generic","toSignature")]
243+ return $ extraDecls ++ decls
244+ where
245+ declName :: Declaration -> Maybe Ident
246+ declName (PositionedDeclaration _ _ d) = declName d
247+ declName (ValueDeclaration ident _ _ _) = Just ident
248+ declName (TypeDeclaration ident _) = Just ident
249+ declName _ = Nothing
250+
251+ unQualify (Qualified _ a) = a
252+
232typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
253typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
233−typeInstanceDictionaryDeclaration name mn deps className tys decls =
254+typeInstanceDictionaryDeclaration name mn deps className tys decls1 =
234 rethrow (onErrorMessages (ErrorInInstance className tys)) $ do
255 rethrow (onErrorMessages (ErrorInInstance className tys)) $ do
235 m <- get
256 m <- get
236
257
@@ -239,6 +260,8 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
239 maybe (throwError . errorMessage $ UnknownTypeClass className) return $
260 maybe (throwError . errorMessage $ UnknownTypeClass className) return $
240 M.lookup (qualify mn className) m
261 M.lookup (qualify mn className) m
241
262
263+ decls <- fillDerivingDecls className tys tyDecls decls1
264+
242 case mapMaybe declName tyDecls \\ mapMaybe declName decls of
265 case mapMaybe declName tyDecls \\ mapMaybe declName decls of
243 member : _ -> throwError . errorMessage $ MissingClassMember member
266 member : _ -> throwError . errorMessage $ MissingClassMember member
244 [] -> do
267 [] -> do
src/Language/PureScript/TypeChecker/Deriving.hsnew file+150
@@ -0,0 +1,150 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Deriving
4+-- Copyright : (c) Gershom Bazerman 2015
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the generic deriving elaboration that takes place during typechecking.
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, PatternSynonyms #-}
17+
18+module Language.PureScript.TypeChecker.Deriving (
19+ elaborateInstance
20+) where
21+
22+import Data.List
23+import Data.Maybe (fromMaybe)
24+import Data.Ord (comparing)
25+import qualified Data.Map as M
26+
27+import Control.Applicative
28+import Control.Monad.State
29+import Control.Monad.Except
30+
31+import Language.PureScript.AST
32+import Language.PureScript.Environment
33+import Language.PureScript.Errors
34+import Language.PureScript.Names
35+import Language.PureScript.TypeChecker.Monad
36+import Language.PureScript.Types
37+
38+elaborateInstance :: (MonadState CheckState m, MonadError MultipleErrors m) => Expr -> m Expr
39+elaborateInstance (TypeClassInstanceMemberFunction funName className t) =
40+ fromMaybe noInstanceError $ lookup (unQualify className, funName) derivingList
41+ where noInstanceError = throwError $ MultipleErrors [ErrorInInstance className [TypeConstructor t] (SimpleErrorWrapper $ MissingClassMember funName)]
42+ derivingList = [((ProperName "Generic", Ident "toSpine"), mkSpineFunction t)
43+ ,((ProperName "Generic", Ident "fromSpine"), mkFromSpineFunction t)
44+ ,((ProperName "Generic", Ident "toSignature"), mkSignatureFunction t)]
45+elaborateInstance e = return e
46+
47+mkSpineFunction :: MonadState CheckState m => Qualified ProperName -> m Expr
48+mkSpineFunction t = do
49+ ctors <- M.toList . dataConstructors <$> getEnv
50+ tcs <- M.toList . typeClasses <$> getEnv
51+ let prodConstructor = App (Constructor $ findName "SProd" ctors)
52+ recordConstructor = App (Constructor $ findName "SRecord" ctors)
53+ genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
54+
55+ mkCtorClause (ctorName, (_,_,typ,idents)) = CaseAlternative [ConstructorBinder ctorName (map VarBinder idents)] (Right caseResult)
56+ where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)
57+
58+ toSpineFun :: Expr -> Type -> Expr
59+ toSpineFun i (ObjectType rec) =
60+ lam "q" . recordConstructor . ArrayLiteral .
61+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
62+ $ decomposeRec rec
63+ toSpineFun i _ = lam "q" $ App (mkVarMn genericModule "toSpine") i
64+
65+ return . lamCase "x" . map mkCtorClause . constructorsForType t $ ctors
66+
67+mkSignatureFunction :: MonadState CheckState m => Qualified ProperName -> m Expr
68+mkSignatureFunction t = do
69+ ctors <- M.toList . dataConstructors <$> getEnv
70+ envtyps <- M.toList . types <$> getEnv
71+ tcs <- M.toList . typeClasses <$> getEnv
72+ let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral
73+ mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral
74+ genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
75+
76+ mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
77+
78+ mkProductSignature (ObjectType rec) =
79+ lam "q" . mkSigRec .
80+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
81+ $ decomposeRec rec
82+ mkProductSignature typ = lam "q" $ App (mkVarMn genericModule "toSignature")
83+ (TypedValue False (mkVarMn genericModule "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))
84+
85+ return . lam "x" . mkSigProd . map mkProdClause . constructorsForType t $ ctors
86+
87+mkFromSpineFunction :: MonadState CheckState m => Qualified ProperName -> m Expr
88+mkFromSpineFunction t = do
89+ ctors <- M.toList . dataConstructors <$> getEnv
90+ tcs <- M.toList . typeClasses <$> getEnv
91+ let
92+ mkJust = App (Constructor $ findName "Just" ctors)
93+ mkNothing = Constructor $ findName "Nothing" ctors
94+ genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
95+
96+ mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =
97+ CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]
98+ . Right $ liftApplicative (mkJust $ Constructor ctor) (zipWith fromSpineFun (map (Var . (Qualified Nothing))idents) (argTypes typ))
99+
100+ fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
101+
102+ fromSpineFun e _ = App (mkVarMn genericModule "fromSpine") (App e (mkPrelVar "unit"))
103+
104+ mkRecCase rs = CaseAlternative [ConstructorBinder (findName "SRecord" ctors) [ArrayBinder (map (VarBinder . Ident . fst) rs)]] . Right $ liftApplicative (mkRecFun rs) (map (\(x,y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
105+
106+ mkRecFun :: [(String,Type)] -> Expr
107+ mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
108+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
109+
110+ return . lamCase "x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]
111+
112+-- Helpers
113+
114+pattern ObjectType rec = TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec
115+
116+lam :: String -> Expr -> Expr
117+lam s = Abs (Left (Ident s))
118+
119+lamCase :: String -> [CaseAlternative] -> Expr
120+lamCase s = lam s . Case [mkVar s]
121+
122+liftApplicative :: Expr -> [Expr] -> Expr
123+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "ap") x) e)
124+
125+mkVarMn :: Maybe ModuleName -> String -> Expr
126+mkVarMn mn s = Var (Qualified mn (Ident s))
127+
128+mkVar :: String -> Expr
129+mkVar s = mkVarMn Nothing s
130+
131+mkPrelVar :: String -> Expr
132+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName "Prelude"])) s
133+
134+decomposeRec :: Type -> [(String, Type)]
135+decomposeRec = sortBy (comparing fst) . go
136+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
137+ go _ = []
138+
139+argTypes :: Type -> [Type]
140+argTypes (TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Function"))) a) b) = a : argTypes b
141+argTypes _ = []
142+
143+findName :: String -> [(Qualified ProperName, a)] -> Qualified ProperName
144+findName s lst = fromMaybe (Qualified Nothing (ProperName s)) . find ((== ProperName s) . unQualify) . map fst $ lst
145+
146+unQualify :: Qualified a -> a
147+unQualify (Qualified _ x) = x
148+
149+constructorsForType :: Qualified ProperName -> [(Qualified ProperName, (a, ProperName, b, c))] -> [(Qualified ProperName, (a, ProperName, b, c))]
150+constructorsForType t = filter (\(Qualified mn _ ,(_,typeName,_,_)) -> t == Qualified mn typeName)
src/Language/PureScript/TypeChecker/Types.hs+5
@@ -52,6 +52,7 @@ import Language.PureScript.Errors
52import Language.PureScript.Kinds
52import Language.PureScript.Kinds
53import Language.PureScript.Names
53import Language.PureScript.Names
54import Language.PureScript.Traversals
54import Language.PureScript.Traversals
55+import Language.PureScript.TypeChecker.Deriving
55import Language.PureScript.TypeChecker.Entailment
56import Language.PureScript.TypeChecker.Entailment
56import Language.PureScript.TypeChecker.Kinds
57import Language.PureScript.TypeChecker.Kinds
57import Language.PureScript.TypeChecker.Monad
58import Language.PureScript.TypeChecker.Monad
@@ -556,6 +557,9 @@ check' (Constructor c) ty = do
556 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
557 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
557 _ <- subsumes Nothing repl ty
558 _ <- subsumes Nothing repl ty
558 return $ TypedValue True (Constructor c) ty
559 return $ TypedValue True (Constructor c) ty
560+
561+check' e@TypeClassInstanceMemberFunction{} ty = flip check' ty =<< elaborateInstance e
562+
559check' (Let ds val) ty = do
563check' (Let ds val) ty = do
560 (ds', val') <- inferLetBinding [] ds val (`check` ty)
564 (ds', val') <- inferLetBinding [] ds val (`check` ty)
561 return $ TypedValue True (Let ds' val') ty
565 return $ TypedValue True (Let ds' val') ty
@@ -575,6 +579,7 @@ containsTypeSynonyms = everythingOnTypes (||) go where
575 go (SaturatedTypeSynonym _ _) = True
579 go (SaturatedTypeSynonym _ _) = True
576 go _ = False
580 go _ = False
577
581
582+
578-- |
583-- |
579-- Check the type of a collection of named record fields
584-- Check the type of a collection of named record fields
580--
585--