@@ -17,55 +17,69 @@ module Language.PureScript.CodeGen.Externs (
1717 moduleToPs
1818) where
1919
20−import Data.List (intercalate)
20+import Data.Maybe (fromMaybe, mapMaybe)
21+import Data.List (intercalate, find)
2122
2223import qualified Data.Map as M
2324
2425import Control.Monad.Writer
2526
2627import Language.PureScript.Declarations
27−import Language.PureScript.TypeChecker.Monad
2828import Language.PureScript.Pretty
2929import Language.PureScript.Names
30−import Language.PureScript.Types
31−import Language.PureScript.Kinds
30+import Language.PureScript.Values
31+import Language.PureScript.Environment
3232
3333-- |
3434-- Generate foreign imports for all declarations in a module
3535--
3636moduleToPs :: Module -> Environment -> String
37−moduleToPs (Module moduleName _ exts) env = intercalate "\n" . execWriter $ do
37+moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
38+moduleToPs (Module moduleName _ (Just exts)) env = intercalate "\n" . execWriter $ do
3839 tell ["module " ++ runModuleName moduleName ++ " where"]
39− let typesExported = getTypesExportedFrom moduleName exts env
40− forM_ typesExported $ \(pn, kind) ->
41− tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
42− let namesExported = getNamesExportedFrom moduleName exts env
43− forM_ namesExported $ \(ident, ty) ->
44− tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
45−
46−getNamesExportedFrom :: ModuleName -> Maybe [DeclarationRef] -> Environment -> [(Ident, Type)]
47−getNamesExportedFrom moduleName exps env =
48− [ (ident, ty)
49− | ((moduleName', ident), (ty, nameKind)) <- M.toList . names $ env
50− , moduleName == moduleName'
51− , nameKind `elem` [Value, Extern ForeignImport]
52− , isExported ident exps
53− ]
40+ mapM_ exportToPs exts
5441 where
55− isExported :: Ident -> Maybe [DeclarationRef] -> Bool
56− isExported _ Nothing = True
57− isExported ident (Just exps') = ValueRef ident `elem` exps'
5842
59−getTypesExportedFrom :: ModuleName -> Maybe [DeclarationRef] -> Environment -> [(ProperName, Kind)]
60−getTypesExportedFrom moduleName exps env =
61− [ (pn, kind)
62− | ((Qualified (Just moduleName') pn), kind) <- M.toList . types $ env
63− , moduleName == moduleName'
64− , isExported pn exps
65− ]
66− where
67− isExported :: ProperName -> Maybe [DeclarationRef] -> Bool
68− isExported _ Nothing = True
69− isExported pn (Just exps') = flip any exps' $ \e -> case e of
70− TypeRef pn' _ | pn == pn' -> True
71− _ -> False
43+ exportToPs :: DeclarationRef -> Writer [String] ()
44+ exportToPs (TypeRef pn dctors) = do
45+ case Qualified (Just moduleName) pn `M.lookup` types env of
46+ Nothing -> error $ show pn ++ " has no kind in exportToPs"
47+ Just (kind, ExternData) ->
48+ tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
49+ Just (_, DataType args tys) -> do
50+ let dctors' = fromMaybe (map fst tys) dctors
51+ printDctor dctor = case dctor `lookup` tys of
52+ Nothing -> Nothing
53+ Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
54+ tell ["data " ++ show pn ++ " " ++ unwords args ++ " = " ++ intercalate " | " (mapMaybe printDctor dctors')]
55+ Just (_, TypeSynonym) ->
56+ case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
57+ Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
58+ Just (args, synTy) ->
59+ tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]
60+ _ -> error "Invalid input in exportToPs"
61+
62+ exportToPs (ValueRef ident) =
63+ case (moduleName, ident) `M.lookup` names env of
64+ Nothing -> error $ show ident ++ " has no type in exportToPs"
65+ Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport ->
66+ tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
67+ _ -> return ()
68+ exportToPs (TypeClassRef className) =
69+ case Qualified (Just moduleName) className `M.lookup` typeClasses env of
70+ Nothing -> error $ show className ++ " has no type class definition in exportToPs"
71+ Just (args, ds) -> do
72+ tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]
73+ forM_ (filter (isValueExported . fst) ds) $ \(member ,ty) ->
74+ tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
75+ exportToPs (TypeInstanceRef ident) = do
76+ let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
77+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
78+ let constraintsText = case fromMaybe [] deps of
79+ [] -> ""
80+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
81+ tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
82+
83+ isValueExported :: Ident -> Bool
84+ isValueExported ident = ValueRef ident `elem` exts
85+