@@ -0,0 +1,154 @@
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 typechecking.
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, PatternGuards #-}
17+
18+module Language.PureScript.TypeChecker.Deriving (
19+ elaborateInstance
20+) where
21+
22+import Data.List
23+import Data.Maybe (fromMaybe)
24+import Data.Ord (comparing)
25+import qualified Data.Map as M
26+
27+import Control.Applicative
28+import Control.Monad.State
29+import Control.Monad.Error.Class (MonadError(..))
30+
31+import Language.PureScript.AST
32+import Language.PureScript.Environment
33+import Language.PureScript.Errors
34+import Language.PureScript.Names
35+import Language.PureScript.TypeChecker.Monad
36+import Language.PureScript.Types
37+import qualified Language.PureScript.Constants as C
38+
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.
40+elaborateInstance :: (Functor m, MonadState CheckState m, MonadError MultipleErrors m) => Expr -> m Expr
41+elaborateInstance (TypeClassInstanceMemberFunction funName className t) =
42+ fromMaybe noInstanceError $ lookup (unQualify className, funName) derivingList
43+ where noInstanceError = throwError $ MultipleErrors [ErrorInInstance className [TypeConstructor t] (SimpleErrorWrapper $ MissingClassMember funName)]
44+ derivingList = [((ProperName C.generic, Ident C.toSpine), mkSpineFunction t)
45+ ,((ProperName C.generic, Ident C.fromSpine), mkFromSpineFunction t)
46+ ,((ProperName C.generic, Ident C.toSignature), mkSignatureFunction t)]
47+elaborateInstance e = return e
48+
49+mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
50+mkSpineFunction t = do
51+ ctors <- M.toList . dataConstructors <$> getEnv
52+ let prodConstructor = App (Constructor $ findName "SProd" ctors)
53+ recordConstructor = App (Constructor $ findName "SRecord" ctors)
54+
55+ 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)
57+
58+ toSpineFun :: Expr -> Type -> Expr
59+ toSpineFun i r | Just rec <- objectType r =
60+ lamNull . recordConstructor . ArrayLiteral .
61+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
62+ $ decomposeRec rec
63+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
64+
65+ return . lamCase "$x" . map mkCtorClause . constructorsForType t $ ctors
66+
67+mkSignatureFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
68+mkSignatureFunction t = do
69+ ctors <- M.toList . dataConstructors <$> getEnv
70+ envtyps <- M.toList . types <$> getEnv
71+ let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral
72+ mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral
73+
74+ mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
75+
76+ mkProductSignature r | Just rec <- objectType r =
77+ lamNull . mkSigRec .
78+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
79+ $ decomposeRec rec
80+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
81+ (TypedValue False (mkGenVar "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))
82+
83+ return . lamNull . mkSigProd . map mkProdClause . constructorsForType t $ ctors
84+
85+mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
86+mkFromSpineFunction t = do
87+ ctors <- M.toList . dataConstructors <$> getEnv
88+ let
89+ mkJust = App (Constructor $ findName "Just" ctors)
90+ mkNothing = Constructor $ findName "Nothing" ctors
91+
92+ mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =
93+ CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]
94+ . Right $ liftApplicative (mkJust $ Constructor ctor) (zipWith fromSpineFun (map (Var . (Qualified Nothing))idents) (argTypes typ))
95+
96+ fromSpineFun e r | Just rec <- objectType r = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
97+
98+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
99+
100+ 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)
101+
102+ mkRecFun :: [(String,Type)] -> Expr
103+ mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
104+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
105+
106+ return . lamCase "$x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]
107+
108+-- Helpers
109+
110+objectType :: Type -> Maybe Type
111+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
112+objectType _ = Nothing
113+
114+lam :: String -> Expr -> Expr
115+lam s = Abs (Left (Ident s))
116+
117+lamNull :: Expr -> Expr
118+lamNull = lam "$q"
119+
120+lamCase :: String -> [CaseAlternative] -> Expr
121+lamCase s = lam s . Case [mkVar s]
122+
123+liftApplicative :: Expr -> [Expr] -> Expr
124+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
125+
126+mkVarMn :: Maybe ModuleName -> String -> Expr
127+mkVarMn mn s = Var (Qualified mn (Ident s))
128+
129+mkVar :: String -> Expr
130+mkVar s = mkVarMn Nothing s
131+
132+mkPrelVar :: String -> Expr
133+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
134+
135+mkGenVar :: String -> Expr
136+mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
137+
138+decomposeRec :: Type -> [(String, Type)]
139+decomposeRec = sortBy (comparing fst) . go
140+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
141+ go _ = []
142+
143+argTypes :: Type -> [Type]
144+argTypes (TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Function"))) a) b) = a : argTypes b
145+argTypes _ = []
146+
147+findName :: String -> [(Qualified ProperName, a)] -> Qualified ProperName
148+findName s lst = fromMaybe (Qualified Nothing (ProperName s)) . find ((== ProperName s) . unQualify) . map fst $ lst
149+
150+unQualify :: Qualified a -> a
151+unQualify (Qualified _ x) = x
152+
153+constructorsForType :: Qualified ProperName -> [(Qualified ProperName, (a, ProperName, b, c))] -> [(Qualified ProperName, (a, ProperName, b, c))]
154+constructorsForType t = filter (\(Qualified mn _ ,(_,typeName,_,_)) -> t == Qualified mn typeName)