git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add TCD accessor value
commit100acfa8dc415878dc9e23575d6b27b950bcdad5 authorGary Burgess <gary.burgess@gmail.com> dateMon 16 Feb 2015, 23:05 (12 years ago) parentf78a8d5
3 files changed+20−12
compare with golang
unifiedsplit
src/Language/PureScript/AST/Declarations.hs+4 src/Language/PureScript/CoreFn/Desugar.hs+3 src/Language/PureScript/Sugar/TypeClasses.hs+13−12
src/Language/PureScript/AST/Declarations.hs+4
@@ -378,6 +378,10 @@ data Expr
378378 --
379379 | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
380380 -- |
381+ -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
382+ --
383+ | TypeClassDictionaryAccessor (Qualified ProperName) Ident
384+ -- |
381385 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
382386 --
383387 | 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
176176 let args = map (exprToCoreFn mn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
177177 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
178178 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")))
179182exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =
180183 exprToCoreFn mn env (Just ss) (com ++ com1) ty v
181184exprToCoreFn _ _ _ _ _ e =
src/Language/PureScript/Sugar/TypeClasses.hs+13−12
@@ -21,24 +21,24 @@ module Language.PureScript.Sugar.TypeClasses
2121 ) where
2222
2323import 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
2824import Language.PureScript.Environment
2925import Language.PureScript.Errors
30−import Language.PureScript.Supply
26+import Language.PureScript.Kinds
27+import Language.PureScript.Names
3128import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
29+import Language.PureScript.Sugar.CaseDeclarations
30+import Language.PureScript.Supply
31+import Language.PureScript.Types
3232
3333import qualified Language.PureScript.Constants as C
3434
3535import Control.Applicative
36+import Control.Arrow (first, second)
3637import Control.Monad.Error
3738import Control.Monad.State
38−import Control.Arrow (first, second)
3939import Data.List ((\\), find)
40−import Data.Monoid ((<>))
4140import Data.Maybe (catMaybes, mapMaybe, isJust)
41+import Data.Monoid ((<>))
4242
4343import qualified Data.Map as M
4444
@@ -158,12 +158,12 @@ desugarDecl mn exps = go
158158 where
159159 go d@(TypeClassDeclaration name args implies members) = do
160160 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)
162162 go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
163163 go d@(TypeInstanceDeclaration name deps className tys members) = do
164164 desugared <- lift $ desugarCases members
165165 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
166− return $ (expRef name className tys, [d, dictDecl])
166+ return (expRef name className tys, [d, dictDecl])
167167 go (PositionedDeclaration pos com d) = do
168168 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
169169 return (dr, map (PositionedDeclaration pos com) ds)
@@ -212,9 +212,10 @@ typeClassDictionaryDeclaration name args implies members =
212212
213213typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
214214typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
215− ValueDeclaration ident TypeClassAccessorImport [] $ Right $
216− TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
217− moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
215+ let className = Qualified (Just mn) name
216+ in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
217+ TypedValue False (TypeClassDictionaryAccessor className ident) $
218+ moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
218219typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
219220 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
220221typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"