git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add TCD accessor value
100acfaGary Burgess
src/Language/PureScript/AST/Declarations.hs+4
compare with golang
unifiedsplit
@@ -378,6 +378,10 @@ data Expr
378 --
378 --
379 | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
379 | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
380 -- |
380 -- |
381+ -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
382+ --
383+ | TypeClassDictionaryAccessor (Qualified ProperName) Ident
384+ -- |
381 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
385 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
382 --
386 --
383 | SuperClassDictionary (Qualified ProperName) [Type]
387 | SuperClassDictionary (Qualified ProperName) [Type]
src/Language/PureScript/CoreFn/Desugar.hs+3
@@ -176,6 +176,9 @@ exprToCoreFn mn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.Typed
176 let args = map (exprToCoreFn mn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
176 let args = map (exprToCoreFn mn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
177 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
177 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
178 in foldl (App (ss, com, Nothing, Nothing)) ctor args
178 in foldl (App (ss, com, Nothing, Nothing)) ctor args
179+exprToCoreFn _ _ ss com ty (A.TypeClassDictionaryAccessor _ ident) =
180+ Abs (ss, com, ty, Nothing) (Ident "dict")
181+ (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
179exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =
182exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =
180 exprToCoreFn mn env (Just ss) (com ++ com1) ty v
183 exprToCoreFn mn env (Just ss) (com ++ com1) ty v
181exprToCoreFn _ _ _ _ _ e =
184exprToCoreFn _ _ _ _ _ e =
src/Language/PureScript/Sugar/TypeClasses.hs+13−12
@@ -21,24 +21,24 @@ module Language.PureScript.Sugar.TypeClasses
21 ) where
21 ) where
22
22
23import Language.PureScript.AST hiding (isExported)
23import Language.PureScript.AST hiding (isExported)
24−import Language.PureScript.Names
25−import Language.PureScript.Types
26−import Language.PureScript.Kinds
27−import Language.PureScript.Sugar.CaseDeclarations
28import Language.PureScript.Environment
24import Language.PureScript.Environment
29import Language.PureScript.Errors
25import Language.PureScript.Errors
30−import Language.PureScript.Supply
26+import Language.PureScript.Kinds
27+import Language.PureScript.Names
31import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
28import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
29+import Language.PureScript.Sugar.CaseDeclarations
30+import Language.PureScript.Supply
31+import Language.PureScript.Types
32
32
33import qualified Language.PureScript.Constants as C
33import qualified Language.PureScript.Constants as C
34
34
35import Control.Applicative
35import Control.Applicative
36+import Control.Arrow (first, second)
36import Control.Monad.Error
37import Control.Monad.Error
37import Control.Monad.State
38import Control.Monad.State
38−import Control.Arrow (first, second)
39import Data.List ((\\), find)
39import Data.List ((\\), find)
40−import Data.Monoid ((<>))
41import Data.Maybe (catMaybes, mapMaybe, isJust)
40import Data.Maybe (catMaybes, mapMaybe, isJust)
41+import Data.Monoid ((<>))
42
42
43import qualified Data.Map as M
43import qualified Data.Map as M
44
44
@@ -158,12 +158,12 @@ desugarDecl mn exps = go
158 where
158 where
159 go d@(TypeClassDeclaration name args implies members) = do
159 go d@(TypeClassDeclaration name args implies members) = do
160 modify (M.insert (mn, name) d)
160 modify (M.insert (mn, name) d)
161− return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
161+ return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
162 go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
162 go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
163 go d@(TypeInstanceDeclaration name deps className tys members) = do
163 go d@(TypeInstanceDeclaration name deps className tys members) = do
164 desugared <- lift $ desugarCases members
164 desugared <- lift $ desugarCases members
165 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
165 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
166− return $ (expRef name className tys, [d, dictDecl])
166+ return (expRef name className tys, [d, dictDecl])
167 go (PositionedDeclaration pos com d) = do
167 go (PositionedDeclaration pos com d) = do
168 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
168 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
169 return (dr, map (PositionedDeclaration pos com) ds)
169 return (dr, map (PositionedDeclaration pos com) ds)
@@ -212,9 +212,10 @@ typeClassDictionaryDeclaration name args implies members =
212
212
213typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
213typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
214typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
214typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
215+ let className = Qualified (Just mn) name
215− ValueDeclaration ident TypeClassAccessorImport [] $ Right $
216+ in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
216− TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
217+ TypedValue False (TypeClassDictionaryAccessor className ident) $
217− moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
218+ moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
218typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
219typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
219 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
220 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
220typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
221typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"