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