@@ -1,232 +1,232 @@
1−-----------------------------------------------------------------------------
1+-----------------------------------------------------------------------------
3−-- Module : Language.PureScript.Sugar.TypeClasses.Deriving
3+-- Module : Language.PureScript.Sugar.TypeClasses.Deriving
4−-- Copyright : (c) Gershom Bazerman 2015
4+-- Copyright : (c) Gershom Bazerman 2015
5−-- License : MIT (http://opensource.org/licenses/MIT)
5+-- License : MIT (http://opensource.org/licenses/MIT)
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
8+-- Stability : experimental
9−-- Portability :
9+-- Portability :
12−-- This module implements the generic deriving elaboration that takes place during desugaring.
12+-- This module implements the generic deriving elaboration that takes place during desugaring.
14−-----------------------------------------------------------------------------
14+-----------------------------------------------------------------------------
16−{-# LANGUAGE FlexibleContexts #-}
16+{-# LANGUAGE FlexibleContexts #-}
17−{-# LANGUAGE MultiParamTypeClasses #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
18−{-# LANGUAGE OverloadedStrings #-}
18+{-# LANGUAGE OverloadedStrings #-}
19−{-# LANGUAGE PatternGuards #-}
19+{-# LANGUAGE PatternGuards #-}
20−{-# LANGUAGE RankNTypes #-}
20+{-# LANGUAGE RankNTypes #-}
21−{-# LANGUAGE ScopedTypeVariables #-}
21+{-# LANGUAGE ScopedTypeVariables #-}
23−module Language.PureScript.Sugar.TypeClasses.Deriving (
23+module Language.PureScript.Sugar.TypeClasses.Deriving (
24− deriveInstances
24+ deriveInstances
27−import Prelude ()
27+import Prelude ()
28−import Prelude.Compat
28+import Prelude.Compat
30−import Data.List (foldl', find, sortBy)
30+import Data.List (foldl', find, sortBy)
31−import Data.Maybe (fromMaybe)
31+import Data.Maybe (fromMaybe)
32−import Data.Ord (comparing)
32+import Data.Ord (comparing)
34−import Control.Monad (replicateM)
34+import Control.Monad (replicateM)
35−import Control.Monad.Supply.Class (MonadSupply, freshName)
35+import Control.Monad.Supply.Class (MonadSupply, freshName)
36−import Control.Monad.Error.Class (MonadError(..))
36+import Control.Monad.Error.Class (MonadError(..))
38−import Language.PureScript.Crash
38+import Language.PureScript.Crash
39−import Language.PureScript.AST
39+import Language.PureScript.AST
40−import Language.PureScript.Environment
40+import Language.PureScript.Environment
41−import Language.PureScript.Errors
41+import Language.PureScript.Errors
42−import Language.PureScript.Names
42+import Language.PureScript.Names
43−import Language.PureScript.Types
43+import Language.PureScript.Types
44−import qualified Language.PureScript.Constants as C
44+import qualified Language.PureScript.Constants as C
46−-- | Elaborates deriving instance declarations by code generation.
46+-- | Elaborates deriving instance declarations by code generation.
47−deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
47+deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
48−deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
48+deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
50−-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
50+-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
51−-- elaborates that into an instance declaration via code generation.
51+-- elaborates that into an instance declaration via code generation.
52−deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
52+deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
53−deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
53+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
54− | className == Qualified (Just dataGeneric) (ProperName C.generic)
54+ | className == Qualified (Just dataGeneric) (ProperName C.generic)
55− , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
55+ , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
56− , mn == fromMaybe mn mn'
56+ , mn == fromMaybe mn mn'
57− = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
57+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
58−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
58+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
59− = throwError . errorMessage $ CannotDerive className tys
59+ = throwError . errorMessage $ CannotDerive className tys
60−deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
60+deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
61−deriveInstance _ _ e = return e
61+deriveInstance _ _ e = return e
63−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)
63+unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)
64−unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon
64+unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon
65−unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty
65+unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty
66−unwrapTypeConstructor _ = Nothing
66+unwrapTypeConstructor _ = Nothing
68−dataGeneric :: ModuleName
68+dataGeneric :: ModuleName
69−dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
69+dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
71−dataMaybe :: ModuleName
71+dataMaybe :: ModuleName
72−dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
72+dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
74−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
74+deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
75−deriveGeneric mn ds tyConNm = do
75+deriveGeneric mn ds tyConNm = do
76− tyCon <- findTypeDecl tyConNm ds
76+ tyCon <- findTypeDecl tyConNm ds
77− toSpine <- mkSpineFunction mn tyCon
77+ toSpine <- mkSpineFunction mn tyCon
78− fromSpine <- mkFromSpineFunction mn tyCon
78+ fromSpine <- mkFromSpineFunction mn tyCon
79− let toSignature = mkSignatureFunction mn tyCon
79+ let toSignature = mkSignatureFunction mn tyCon
80− return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
80+ return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
81− , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
81+ , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
82− , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
82+ , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
85−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
85+findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
86−findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
86+findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
88− isTypeDecl :: Declaration -> Bool
88+ isTypeDecl :: Declaration -> Bool
89− isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True
89+ isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True
90− isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
90+ isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
91− isTypeDecl _ = False
91+ isTypeDecl _ = False
93−mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
93+mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
94−mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
94+mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
96− prodConstructor :: Expr -> Expr
96+ prodConstructor :: Expr -> Expr
97− prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
97+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
99− recordConstructor :: Expr -> Expr
99+ recordConstructor :: Expr -> Expr
100− recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
100+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
102− mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
102+ mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
103− mkCtorClause (ctorName, tys) = do
103+ mkCtorClause (ctorName, tys) = do
104− idents <- replicateM (length tys) (fmap Ident freshName)
104+ idents <- replicateM (length tys) (fmap Ident freshName)
105− return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
105+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
107− caseResult idents =
107+ caseResult idents =
108− App (prodConstructor (StringLiteral . runProperName $ ctorName))
108+ App (prodConstructor (StringLiteral . runProperName $ ctorName))
109− . ArrayLiteral
109+ . ArrayLiteral
110− $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
110+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
112− toSpineFun :: Expr -> Type -> Expr
112+ toSpineFun :: Expr -> Type -> Expr
113− toSpineFun i r | Just rec <- objectType r =
113+ toSpineFun i r | Just rec <- objectType r =
114− lamNull . recordConstructor . ArrayLiteral .
114+ lamNull . recordConstructor . ArrayLiteral .
115− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
115+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
116− $ decomposeRec rec
116+ $ decomposeRec rec
117− toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
117+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
118−mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
118+mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
119−mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
119+mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
121−mkSignatureFunction :: ModuleName -> Declaration -> Expr
121+mkSignatureFunction :: ModuleName -> Declaration -> Expr
122−mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
122+mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
124− mkSigProd :: [Expr] -> Expr
124+ mkSigProd :: [Expr] -> Expr
125− mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
125+ mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
127− mkSigRec :: [Expr] -> Expr
127+ mkSigRec :: [Expr] -> Expr
128− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
128+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
130− proxy :: Type -> Type
130+ proxy :: Type -> Type
131− proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
131+ proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
133− mkProdClause :: (ProperName, [Type]) -> Expr
133+ mkProdClause :: (ProperName, [Type]) -> Expr
134− mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
134+ mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
135− , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
135+ , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
138− mkProductSignature :: Type -> Expr
138+ mkProductSignature :: Type -> Expr
139− mkProductSignature r | Just rec <- objectType r =
139+ mkProductSignature r | Just rec <- objectType r =
140− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
140+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
141− , ("recValue", mkProductSignature typ)
141+ , ("recValue", mkProductSignature typ)
143− | (str, typ) <- decomposeRec rec
143+ | (str, typ) <- decomposeRec rec
145− mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
145+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
146− (TypedValue False (mkGenVar "anyProxy") (proxy typ))
146+ (TypedValue False (mkGenVar "anyProxy") (proxy typ))
147−mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
147+mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
148−mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
148+mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
150−mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
150+mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
151−mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
151+mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
153− mkJust :: Expr -> Expr
153+ mkJust :: Expr -> Expr
154− mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
154+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
156− mkNothing :: Expr
156+ mkNothing :: Expr
157− mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
157+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
159− prodBinder :: [Binder] -> Binder
159+ prodBinder :: [Binder] -> Binder
160− prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
160+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
162− recordBinder :: [Binder] -> Binder
162+ recordBinder :: [Binder] -> Binder
163− recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
163+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
165− mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
165+ mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
166− mkAlternative (ctorName, tys) = do
166+ mkAlternative (ctorName, tys) = do
167− idents <- replicateM (length tys) (fmap Ident freshName)
167+ idents <- replicateM (length tys) (fmap Ident freshName)
168− return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
168+ return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
170− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
170+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
171− (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
171+ (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
173− addCatch :: [CaseAlternative] -> [CaseAlternative]
173+ addCatch :: [CaseAlternative] -> [CaseAlternative]
174− addCatch = (++ [catchAll])
174+ addCatch = (++ [catchAll])
176− catchAll = CaseAlternative [NullBinder] (Right mkNothing)
176+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)
178− fromSpineFun e r
178+ fromSpineFun e r
179− | Just rec <- objectType r
179+ | Just rec <- objectType r
180− = App (lamCase "r" [ mkRecCase (decomposeRec rec)
180+ = App (lamCase "r" [ mkRecCase (decomposeRec rec)
181− , CaseAlternative [NullBinder] (Right mkNothing)
181+ , CaseAlternative [NullBinder] (Right mkNothing)
183− (App e (mkPrelVar "unit"))
183+ (App e (mkPrelVar "unit"))
185− fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
185+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
187− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
187+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
191− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
191+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
193− mkRecFun :: [(String, Type)] -> Expr
193+ mkRecFun :: [(String, Type)] -> Expr
194− mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
194+ mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
195− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
195+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
196−mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
196+mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
197−mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
197+mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
199−-- Helpers
199+-- Helpers
201−objectType :: Type -> Maybe Type
201+objectType :: Type -> Maybe Type
202−objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
202+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
203−objectType _ = Nothing
203+objectType _ = Nothing
205−lam :: String -> Expr -> Expr
205+lam :: String -> Expr -> Expr
206−lam s = Abs (Left (Ident s))
206+lam s = Abs (Left (Ident s))
208−lamNull :: Expr -> Expr
208+lamNull :: Expr -> Expr
209−lamNull = lam "$q"
209+lamNull = lam "$q"
211−lamCase :: String -> [CaseAlternative] -> Expr
211+lamCase :: String -> [CaseAlternative] -> Expr
212−lamCase s = lam s . Case [mkVar s]
212+lamCase s = lam s . Case [mkVar s]
214−liftApplicative :: Expr -> [Expr] -> Expr
214+liftApplicative :: Expr -> [Expr] -> Expr
215−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
215+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
217−mkVarMn :: Maybe ModuleName -> String -> Expr
217+mkVarMn :: Maybe ModuleName -> String -> Expr
218−mkVarMn mn s = Var (Qualified mn (Ident s))
218+mkVarMn mn s = Var (Qualified mn (Ident s))
220−mkVar :: String -> Expr
220+mkVar :: String -> Expr
221−mkVar s = mkVarMn Nothing s
221+mkVar s = mkVarMn Nothing s
223−mkPrelVar :: String -> Expr
223+mkPrelVar :: String -> Expr
224−mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
224+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
226−mkGenVar :: String -> Expr
226+mkGenVar :: String -> Expr
227−mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
227+mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
229−decomposeRec :: Type -> [(String, Type)]
229+decomposeRec :: Type -> [(String, Type)]
230−decomposeRec = sortBy (comparing fst) . go
230+decomposeRec = sortBy (comparing fst) . go
231− where go (RCons str typ typs) = (str, typ) : decomposeRec typs
231+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
232− go _ = []
232+ go _ = []