@@ -0,0 +1,224 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.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@[TypeConstructor tyName] Nothing)
51+ | className == Qualified (Just dataGeneric) (ProperName C.generic)
52+ , Qualified mn' tyCon <- tyName
53+ , mn == fromMaybe mn mn'
54+ = TypeInstanceDeclaration nm deps className tys . Just <$> deriveGeneric mn ds tyCon
55+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys Nothing)
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+dataGeneric :: ModuleName
61+dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
62+
63+dataMaybe :: ModuleName
64+dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
65+
66+deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
67+deriveGeneric mn ds tyConNm = do
68+ tyCon <- findTypeDecl tyConNm ds
69+ toSpine <- mkSpineFunction mn tyCon
70+ fromSpine <- mkFromSpineFunction mn tyCon
71+ let toSignature = mkSignatureFunction mn tyCon
72+ return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
73+ , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
74+ , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
75+ ]
76+
77+findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
78+findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
79+ where
80+ isTypeDecl :: Declaration -> Bool
81+ isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True
82+ isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
83+ isTypeDecl _ = False
84+
85+mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
86+mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
87+ where
88+ prodConstructor :: Expr -> Expr
89+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
90+
91+ recordConstructor :: Expr -> Expr
92+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
93+
94+ mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
95+ mkCtorClause (ctorName, tys) = do
96+ idents <- replicateM (length tys) (fmap Ident freshName)
97+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
98+ where
99+ caseResult idents =
100+ App (prodConstructor (StringLiteral . runProperName $ ctorName))
101+ . ArrayLiteral
102+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
103+
104+ toSpineFun :: Expr -> Type -> Expr
105+ toSpineFun i r | Just rec <- objectType r =
106+ lamNull . recordConstructor . ArrayLiteral .
107+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
108+ $ decomposeRec rec
109+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
110+mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
111+mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"
112+
113+mkSignatureFunction :: ModuleName -> Declaration -> Expr
114+mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
115+ where
116+ mkSigProd :: [Expr] -> Expr
117+ mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
118+
119+ mkSigRec :: [Expr] -> Expr
120+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
121+
122+ proxy :: Type -> Type
123+ proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
124+
125+ mkProdClause :: (ProperName, [Type]) -> Expr
126+ mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
127+ , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
128+ ]
129+
130+ mkProductSignature :: Type -> Expr
131+ mkProductSignature r | Just rec <- objectType r =
132+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
133+ , ("recValue", mkProductSignature typ)
134+ ]
135+ | (str, typ) <- decomposeRec rec
136+ ]
137+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
138+ (TypedValue False (mkGenVar "anyProxy") (proxy typ))
139+mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
140+mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"
141+
142+mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
143+mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
144+ where
145+ mkJust :: Expr -> Expr
146+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
147+
148+ mkNothing :: Expr
149+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
150+
151+ prodBinder :: [Binder] -> Binder
152+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
153+
154+ recordBinder :: [Binder] -> Binder
155+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
156+
157+ mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
158+ mkAlternative (ctorName, tys) = do
159+ idents <- replicateM (length tys) (fmap Ident freshName)
160+ return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
161+ . Right
162+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
163+ (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
164+
165+ addCatch :: [CaseAlternative] -> [CaseAlternative]
166+ addCatch = (++ [catchAll])
167+ where
168+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)
169+
170+ fromSpineFun e r
171+ | Just rec <- objectType r
172+ = App (lamCase "r" [ mkRecCase (decomposeRec rec)
173+ , CaseAlternative [NullBinder] (Right mkNothing)
174+ ])
175+ (App e (mkPrelVar "unit"))
176+
177+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
178+
179+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
180+ ]
181+ ]
182+ . Right
183+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
184+
185+ mkRecFun :: [(String, Type)] -> Expr
186+ mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
187+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
188+mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
189+mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration"
190+
191+-- Helpers
192+
193+objectType :: Type -> Maybe Type
194+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
195+objectType _ = Nothing
196+
197+lam :: String -> Expr -> Expr
198+lam s = Abs (Left (Ident s))
199+
200+lamNull :: Expr -> Expr
201+lamNull = lam "$q"
202+
203+lamCase :: String -> [CaseAlternative] -> Expr
204+lamCase s = lam s . Case [mkVar s]
205+
206+liftApplicative :: Expr -> [Expr] -> Expr
207+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
208+
209+mkVarMn :: Maybe ModuleName -> String -> Expr
210+mkVarMn mn s = Var (Qualified mn (Ident s))
211+
212+mkVar :: String -> Expr
213+mkVar s = mkVarMn Nothing s
214+
215+mkPrelVar :: String -> Expr
216+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
217+
218+mkGenVar :: String -> Expr
219+mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
220+
221+decomposeRec :: Type -> [(String, Type)]
222+decomposeRec = sortBy (comparing fst) . go
223+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
224+ go _ = []