module Language.PureScript.CodeGen.Externs (
moduleToPs
) where
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (intercalate, find)
import qualified Data.Map as M
import Control.Monad.Writer
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Declarations
import Language.PureScript.Pretty
import Language.PureScript.Names
import Language.PureScript.Environment
moduleToPs :: Module -> Environment -> String
moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
tell [ "module " ++ runModuleName moduleName ++ " where"]
mapM_ declToPs ds
mapM_ exportToPs exts
where
declToPs :: Declaration -> Writer [String] ()
declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
declToPs (FixityDeclaration (Fixity assoc prec) ident) =
tell [ unwords [ show assoc, show prec, ident ] ]
declToPs (PositionedDeclaration _ d) = declToPs d
declToPs _ = return ()
exportToPs :: DeclarationRef -> Writer [String] ()
exportToPs (PositionedDeclarationRef _ r) = exportToPs r
exportToPs (TypeRef pn dctors) = do
case Qualified (Just moduleName) pn `M.lookup` types env of
Nothing -> error $ show pn ++ " has no kind in exportToPs"
Just (kind, ExternData) ->
tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
Just (_, DataType args tys) -> do
let dctors' = fromMaybe (map fst tys) dctors
printDctor dctor = case dctor `lookup` tys of
Nothing -> Nothing
Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
tell ["data " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
Just (_, TypeSynonym) ->
case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
Just (args, synTy) ->
tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]
_ -> error "Invalid input in exportToPs"
exportToPs (ValueRef ident) =
case (moduleName, ident) `M.lookup` names env of
Nothing -> error $ show ident ++ " has no type in exportToPs"
Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
_ -> return ()
exportToPs (TypeClassRef className) =
case Qualified (Just moduleName) className `M.lookup` typeClasses env of
Nothing -> error $ show className ++ " has no type class definition in exportToPs"
Just (args, members, implies) -> do
let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]
forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
exportToPs (TypeInstanceRef ident) = do
let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
let constraintsText = case fromMaybe [] deps of
[] -> ""
cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
isValueExported :: Ident -> Bool
isValueExported ident = ValueRef ident `elem` exts