@@ -49,13 +49,9 @@ elaborateInstance e = return e
49mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
49mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
50mkSpineFunction t = do
50mkSpineFunction t = do
51 ctors <- M.toList . dataConstructors <$> getEnv
51 ctors <- M.toList . dataConstructors <$> getEnv
52− tcs <- M.toList . typeClasses <$> getEnv
53 let prodConstructor = App (Constructor $ findName "SProd" ctors)
52 let prodConstructor = App (Constructor $ findName "SProd" ctors)
54 recordConstructor = App (Constructor $ findName "SRecord" ctors)
53 recordConstructor = App (Constructor $ findName "SRecord" ctors)
56− --TODO always set this
57− genericModule = case findName C.generic tcs of (Qualified mn _) -> mn
59 mkCtorClause (ctorName, (_,_,typ,idents)) = CaseAlternative [ConstructorBinder ctorName (map VarBinder idents)] (Right caseResult)
55 mkCtorClause (ctorName, (_,_,typ,idents)) = CaseAlternative [ConstructorBinder ctorName (map VarBinder idents)] (Right caseResult)
60 where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)
56 where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)
@@ -64,7 +60,7 @@ mkSpineFunction t = do
64 lamNull . recordConstructor . ArrayLiteral .
60 lamNull . recordConstructor . ArrayLiteral .
65 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
61 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
66 $ decomposeRec rec
62 $ decomposeRec rec
67− toSpineFun i _ = lamNull $ App (mkVarMn genericModule C.toSpine) i
63+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
69 return . lamCase "$x" . map mkCtorClause . constructorsForType t $ ctors
65 return . lamCase "$x" . map mkCtorClause . constructorsForType t $ ctors
@@ -72,33 +68,26 @@ mkSignatureFunction :: (Functor m, MonadState CheckState m) => Qualified ProperN
72mkSignatureFunction t = do
68mkSignatureFunction t = do
73 ctors <- M.toList . dataConstructors <$> getEnv
69 ctors <- M.toList . dataConstructors <$> getEnv
74 envtyps <- M.toList . types <$> getEnv
70 envtyps <- M.toList . types <$> getEnv
75− tcs <- M.toList . typeClasses <$> getEnv
76 let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral
71 let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral
77 mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral
72 mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral
79− -- TODO always fix this
80− genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
82 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
74 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
84 mkProductSignature (ObjectType rec) =
76 mkProductSignature (ObjectType rec) =
85 lamNull . mkSigRec .
77 lamNull . mkSigRec .
86 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
78 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
87 $ decomposeRec rec
79 $ decomposeRec rec
88− mkProductSignature typ = lamNull $ App (mkVarMn genericModule "toSignature")
80+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
89− (TypedValue False (mkVarMn genericModule "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))
81+ (TypedValue False (mkGenVar "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))
91 return . lamNull . mkSigProd . map mkProdClause . constructorsForType t $ ctors
83 return . lamNull . mkSigProd . map mkProdClause . constructorsForType t $ ctors
93mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
85mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
94mkFromSpineFunction t = do
86mkFromSpineFunction t = do
95 ctors <- M.toList . dataConstructors <$> getEnv
87 ctors <- M.toList . dataConstructors <$> getEnv
96− tcs <- M.toList . typeClasses <$> getEnv
98 mkJust = App (Constructor $ findName "Just" ctors)
89 mkJust = App (Constructor $ findName "Just" ctors)
99 mkNothing = Constructor $ findName "Nothing" ctors
90 mkNothing = Constructor $ findName "Nothing" ctors
100− --TODO hardwire this
101− genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
103 mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =
92 mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =
104 CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]
93 CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]
@@ -106,7 +95,7 @@ mkFromSpineFunction t = do
107 fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
96 fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
109− fromSpineFun e _ = App (mkVarMn genericModule C.fromSpine) (App e (mkPrelVar "unit"))
98+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
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)
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)
@@ -124,7 +113,7 @@ lam :: String -> Expr -> Expr
124lam s = Abs (Left (Ident s))
113lam s = Abs (Left (Ident s))
126lamNull :: Expr -> Expr
115lamNull :: Expr -> Expr
127−lamNull = Abs (Right NullBinder)
116+lamNull = lam "$q"
129lamCase :: String -> [CaseAlternative] -> Expr
118lamCase :: String -> [CaseAlternative] -> Expr
130lamCase s = lam s . Case [mkVar s]
119lamCase s = lam s . Case [mkVar s]
@@ -141,6 +130,9 @@ mkVar s = mkVarMn Nothing s
141mkPrelVar :: String -> Expr
130mkPrelVar :: String -> Expr
142mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
131mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
133+mkGenVar :: String -> Expr
134+mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
144decomposeRec :: Type -> [(String, Type)]
136decomposeRec :: Type -> [(String, Type)]
145decomposeRec = sortBy (comparing fst) . go
137decomposeRec = sortBy (comparing fst) . go
146 where go (RCons str typ typs) = (str, typ) : decomposeRec typs
138 where go (RCons str typ typs) = (str, typ) : decomposeRec typs