import Language.PureScript.Environment as P

import Data.Maybe (fromMaybe, mapMaybe)

import Data.List (intercalate, find)

import Language.PureScript.Values

import Language.PureScript.Environment

moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"

moduleToPs (Module moduleName _ (Just exts)) env = intercalate "\n" . execWriter $ do

mapM_ exportToPs exts

exportToPs :: DeclarationRef -> Writer [String] ()

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 ++ " = " ++ 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 ->

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, ds) -> do

tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]

forM_ (filter (isValueExported . fst) ds) $ \(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

import Language.PureScript.Environment

exportToJs (TypeInstanceRef name) = [export name]

filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r

typeExists _ _ = False

import Language.PureScript.Environment

| TypeInstanceRef Ident

-- |

{-# LANGUAGE DeriveDataTypeable #-}

module Language.PureScript.Environment where

import Data.Data

import Language.PureScript.Names

import Language.PureScript.Types

import Language.PureScript.Kinds

import Language.PureScript.Values

import qualified Language.PureScript.Constants as C

import qualified Data.Map as M

-- |

data Environment = Environment {

-- |

-- Value names currently in scope

--

names :: M.Map (ModuleName, Ident) (Type, NameKind)

-- |

-- Type names currently in scope

--

, types :: M.Map (Qualified ProperName) (Kind, TypeKind)

-- |

-- Data constructors currently in scope, along with their associated data type constructors

--

, dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)

-- |

-- Type synonyms currently in scope

--

, typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

-- |

-- Available type class dictionaries

--

, typeClassDictionaries :: [TypeClassDictionaryInScope]

-- |

-- Type classes

--

, typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])

} deriving (Show)

-- |

initEnvironment :: Environment

initEnvironment = Environment M.empty primTypes M.empty M.empty [] M.empty

-- |

data ForeignImportType

-- |

-- A regular foreign import

--

= ForeignImport

-- |

-- A foreign import which contains inline Javascript as a string literal

--

| InlineJavascript

-- |

-- A type class dictionary member accessor import, generated during desugaring of type class declarations

--

| TypeClassAccessorImport deriving (Show, Eq, Data, Typeable)

-- |

data NameKind

-- |

-- A value introduced as a binding in a module

--

= Value

-- |

-- A foreign import

--

| Extern ForeignImportType

-- |

-- A local name introduced using a lambda abstraction, variable introduction or binder

--

| LocalVariable

-- |

-- A data constructor

--

| DataConstructor

-- |

-- A type class dictionary, generated during desugaring of type class declarations

--

| TypeInstanceDictionaryValue

-- |

-- A type instance member, generated during desugaring of type class declarations

--

| TypeInstanceMember deriving (Show, Eq, Data, Typeable)

-- |

data TypeKind

-- |

-- Data type

--

= DataType [String] [(ProperName, [Type])]

-- |

-- Type synonym

--

| TypeSynonym

-- |

-- Foreign data

--

| ExternData

-- |

-- A local type variable

--

| LocalTypeVariable deriving (Show, Eq, Data, Typeable)

-- |

primName :: String -> Qualified ProperName

primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

-- |

primTy :: String -> Type

primTy = TypeConstructor . primName

-- |

tyFunction :: Type

tyFunction = primTy "Function"

-- |

tyString :: Type

tyString = primTy "String"

-- |

tyNumber :: Type

tyNumber = primTy "Number"

-- |

tyBoolean :: Type

tyBoolean = primTy "Boolean"

-- |

tyArray :: Type

tyArray = primTy "Array"

-- |

function :: Type -> Type -> Type

function t1 = TypeApp (TypeApp tyFunction t1)

-- |

primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))

, (primName "Array" , (FunKind Star Star, ExternData))

, (primName "String" , (Star, ExternData))

, (primName "Number" , (Star, ExternData))

, (primName "Boolean" , (Star, ExternData)) ]