0f9d2f7 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

cleanup PR as per comments. fixing the module name outstanding.

0f9d2f7U-CIQDEV\gbazerman11 years ago

src/Language/PureScript/Constants.hs+6

compare with golang

unifiedsplit

@@ -238,6 +238,12 @@ semigroupString = "semigroupString"

238semigroupoidArr :: String

239semigroupoidArr = "semigroupoidArr"

240

241+-- Generic Deriving

242+generic = "Generic"

243+toSpine = "toSpine"

244+fromSpine = "fromSpine"

245+toSignature = "toSignature"

246+

241-- Main module

247-- Main module

242

248

243main :: String

249main :: String

src/Language/PureScript/Sugar/TypeClasses.hs+3−3

@@ -237,9 +237,9 @@ fillDerivingDecls className tys tyDecls decls = do

237 [TypeConstructor t] | unQualify className == ProperName cls && Ident fun `elem` missingDecls -> return [ValueDeclaration (Ident fun) Public [] (Right $ TypeClassInstanceMemberFunction (Ident fun) className t)]

238 _ -> return []

239 extraDecls <- concat <$> mapM (uncurry mkMissingDecl)

240− [("Generic","toSpine")

240+ [(C.generic,C.toSpine)

241− ,("Generic","fromSpine")

241+ ,(C.generic,C.fromSpine)

242− ,("Generic","toSignature")]

242+ ,(C.generic,C.toSignature)]

243 return $ extraDecls ++ decls

244 where

245 declName :: Declaration -> Maybe Ident

src/Language/PureScript/TypeChecker/Deriving.hs+24−14

@@ -34,14 +34,16 @@ import Language.PureScript.Errors

34import Language.PureScript.Names

35import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.Types

37+import qualified Language.PureScript.Constants as C

39+-- | Takes an expression, and if the head of the expression is a TypeClassInstanceMemberFunction, elaborates that into an instantiation of the actual member function via code generation.

38elaborateInstance :: (Functor m, MonadState CheckState m, MonadError MultipleErrors m) => Expr -> m Expr

40elaborateInstance :: (Functor m, MonadState CheckState m, MonadError MultipleErrors m) => Expr -> m Expr

39elaborateInstance (TypeClassInstanceMemberFunction funName className t) =

41elaborateInstance (TypeClassInstanceMemberFunction funName className t) =

40 fromMaybe noInstanceError $ lookup (unQualify className, funName) derivingList

42 fromMaybe noInstanceError $ lookup (unQualify className, funName) derivingList

41 where noInstanceError = throwError $ MultipleErrors [ErrorInInstance className [TypeConstructor t] (SimpleErrorWrapper $ MissingClassMember funName)]

43 where noInstanceError = throwError $ MultipleErrors [ErrorInInstance className [TypeConstructor t] (SimpleErrorWrapper $ MissingClassMember funName)]

42− derivingList = [((ProperName "Generic", Ident "toSpine"), mkSpineFunction t)

44+ derivingList = [((ProperName C.generic, Ident C.toSpine), mkSpineFunction t)

43− ,((ProperName "Generic", Ident "fromSpine"), mkFromSpineFunction t)

45+ ,((ProperName C.generic, Ident C.fromSpine), mkFromSpineFunction t)

44− ,((ProperName "Generic", Ident "toSignature"), mkSignatureFunction t)]

46+ ,((ProperName C.generic, Ident C.toSignature), mkSignatureFunction t)]

45elaborateInstance e = return e

47elaborateInstance e = return e

47mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

49mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

@@ -50,19 +52,21 @@ mkSpineFunction t = do

50 tcs <- M.toList . typeClasses <$> getEnv

52 tcs <- M.toList . typeClasses <$> getEnv

51 let prodConstructor = App (Constructor $ findName "SProd" ctors)

53 let prodConstructor = App (Constructor $ findName "SProd" ctors)

52 recordConstructor = App (Constructor $ findName "SRecord" ctors)

54 recordConstructor = App (Constructor $ findName "SRecord" ctors)

55+

56+ --TODO always set this

53− genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn

57+ genericModule = case findName C.generic tcs of (Qualified mn _) -> mn

55 mkCtorClause (ctorName, (_,_,typ,idents)) = CaseAlternative [ConstructorBinder ctorName (map VarBinder idents)] (Right caseResult)

59 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)

60 where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)

58 toSpineFun :: Expr -> Type -> Expr

62 toSpineFun :: Expr -> Type -> Expr

59 toSpineFun i (ObjectType rec) =

63 toSpineFun i (ObjectType rec) =

60− lam "q" . recordConstructor . ArrayLiteral .

64+ lamNull . recordConstructor . ArrayLiteral .

61 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

65 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

62 $ decomposeRec rec

66 $ decomposeRec rec

63− toSpineFun i _ = lam "q" $ App (mkVarMn genericModule "toSpine") i

67+ toSpineFun i _ = lamNull $ App (mkVarMn genericModule C.toSpine) i

65− return . lamCase "x" . map mkCtorClause . constructorsForType t $ ctors

69+ return . lamCase "$x" . map mkCtorClause . constructorsForType t $ ctors

67mkSignatureFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

71mkSignatureFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

68mkSignatureFunction t = do

72mkSignatureFunction t = do

@@ -71,18 +75,20 @@ mkSignatureFunction t = do

71 tcs <- M.toList . typeClasses <$> getEnv

75 tcs <- M.toList . typeClasses <$> getEnv

72 let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral

76 let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral

73 mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral

77 mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral

78+

79+ -- TODO always fix this

74 genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn

80 genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn

76 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]

82 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]

78 mkProductSignature (ObjectType rec) =

84 mkProductSignature (ObjectType rec) =

79− lam "q" . mkSigRec .

85+ lamNull . mkSigRec .

80 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])

86 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])

81 $ decomposeRec rec

87 $ decomposeRec rec

82− mkProductSignature typ = lam "q" $ App (mkVarMn genericModule "toSignature")

88+ mkProductSignature typ = lamNull $ App (mkVarMn genericModule "toSignature")

83 (TypedValue False (mkVarMn genericModule "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))

89 (TypedValue False (mkVarMn genericModule "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))

85− return . lam "x" . mkSigProd . map mkProdClause . constructorsForType t $ ctors

91+ return . lamNull . mkSigProd . map mkProdClause . constructorsForType t $ ctors

87mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

93mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

88mkFromSpineFunction t = do

94mkFromSpineFunction t = do

@@ -91,6 +97,7 @@ mkFromSpineFunction t = do

91 let

97 let

92 mkJust = App (Constructor $ findName "Just" ctors)

98 mkJust = App (Constructor $ findName "Just" ctors)

93 mkNothing = Constructor $ findName "Nothing" ctors

99 mkNothing = Constructor $ findName "Nothing" ctors

100+ --TODO hardwire this

94 genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn

101 genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn

102

96 mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =

103 mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =

@@ -99,7 +106,7 @@ mkFromSpineFunction t = do

106

100 fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))

107 fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))

101

108

102− fromSpineFun e _ = App (mkVarMn genericModule "fromSpine") (App e (mkPrelVar "unit"))

109+ fromSpineFun e _ = App (mkVarMn genericModule C.fromSpine) (App e (mkPrelVar "unit"))

103

110

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)

111 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

112

@@ -107,7 +114,7 @@ mkFromSpineFunction t = do

107 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

114 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

108 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

115 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

109

116

110− return . lamCase "x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]

117+ return . lamCase "$x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]

111

118

112-- Helpers

119-- Helpers

113

120

@@ -116,11 +123,14 @@ pattern ObjectType rec = TypeApp (TypeConstructor (Qualified (Just (ModuleName [

116lam :: String -> Expr -> Expr

123lam :: String -> Expr -> Expr

117lam s = Abs (Left (Ident s))

124lam s = Abs (Left (Ident s))

118

125

126+lamNull :: Expr -> Expr

127+lamNull = Abs (Right NullBinder)

128+

119lamCase :: String -> [CaseAlternative] -> Expr

129lamCase :: String -> [CaseAlternative] -> Expr

120lamCase s = lam s . Case [mkVar s]

130lamCase s = lam s . Case [mkVar s]

121

131

122liftApplicative :: Expr -> [Expr] -> Expr

132liftApplicative :: Expr -> [Expr] -> Expr

123−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "ap") x) e)

133+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)

124

134

125mkVarMn :: Maybe ModuleName -> String -> Expr

135mkVarMn :: Maybe ModuleName -> String -> Expr

126mkVarMn mn s = Var (Qualified mn (Ident s))

136mkVarMn mn s = Var (Qualified mn (Ident s))

@@ -129,7 +139,7 @@ mkVar :: String -> Expr

129mkVar s = mkVarMn Nothing s

139mkVar s = mkVarMn Nothing s

130

140

131mkPrelVar :: String -> Expr

141mkPrelVar :: String -> Expr

132−mkPrelVar s = mkVarMn (Just (ModuleName [ProperName "Prelude"])) s

142+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s

133

143

134decomposeRec :: Type -> [(String, Type)]

144decomposeRec :: Type -> [(String, Type)]

135decomposeRec = sortBy (comparing fst) . go

145decomposeRec = sortBy (comparing fst) . go