Initial work on desugaring type classes into dictionaries

paf31 · paf31 · commit 0604bc187857 · 2014-01-12T12:02:29.000-08:00
diff --git a/purescript.cabal b/purescript.cabal
@@ -34,6 +34,7 @@ library
                      Language.PureScript.Sugar.TypeDeclarations
                      Language.PureScript.Sugar.BindingGroups
                      Language.PureScript.Sugar.Operators
+                     Language.PureScript.Sugar.TypeClasses
                      Language.PureScript.CodeGen
                      Language.PureScript.CodeGen.Externs
                      Language.PureScript.CodeGen.JS
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
@@ -23,9 +23,11 @@ import Language.PureScript.Sugar.DoNotation as S
 import Language.PureScript.Sugar.CaseDeclarations as S
 import Language.PureScript.Sugar.TypeDeclarations as S
 import Language.PureScript.Sugar.BindingGroups as S
+import Language.PureScript.Sugar.TypeClasses as S
 
 desugar :: [Module] -> Either String [Module]
-desugar = rebracket
+desugar = return . desugarTypeClasses
+          >=> rebracket
           >=> desugarDo
           >=> desugarCasesModule
           >=> desugarTypeDeclarationsModule
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -0,0 +1,28 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Language.PureScript.Sugar.TypeClasses
+-- Copyright   :  (c) Phil Freeman 2013
+-- License     :  MIT
+--
+-- Maintainer  :  Phil Freeman <paf31@cantab.net>
+-- Stability   :  experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Sugar.TypeClasses (
+  desugarTypeClasses
+) where
+
+import Language.PureScript.Declarations
+
+desugarTypeClasses :: [Module] -> [Module]
+desugarTypeClasses = map desugarModule
+
+desugarModule :: Module -> Module
+desugarModule (Module name decls) = Module name $ concatMap desugarDecl decls
+
+desugarDecl :: Declaration -> [Declaration]
+desugarDecl other = [other]
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -185,6 +185,10 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
        constructs (Function _ ty) pn = ty `constructs` pn
        constructs (TypeApp ty _) pn = ty `constructs` pn
        constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
+typeCheckAll moduleName (TypeClassDeclaration name arg decls : rest) = do
+  typeCheckAll moduleName rest
+typeCheckAll moduleName (TypeInstanceDeclaration name ty decls : rest) = do
+  typeCheckAll moduleName rest
 
 qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
 qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
