72ce900 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

WIP: new externs file format

commit72ce9000b184fa660010deba20ee872bc71eab53 authorPhil Freeman <paf31@cantab.net> dateFri 11 Sep 2015, 18:04 (11 years ago) parente2385f4

29 files changed+378−316

compare with golang

unifiedsplit

psci/Parser.hs−1

@@ -131,7 +131,6 @@ acceptable P.DataDeclaration{} = True

131131acceptable P.TypeSynonymDeclaration{} = True

132132acceptable P.ExternDeclaration{} = True

133133acceptable P.ExternDataDeclaration{} = True

134−acceptable P.ExternInstanceDeclaration{} = True

135134acceptable P.TypeClassDeclaration{} = True

136135acceptable P.TypeInstanceDeclaration{} = True

137136acceptable _ = False

purescript.cabal+1−1

@@ -68,8 +68,8 @@ library

6868 Language.PureScript.AST.Traversals

6969 Language.PureScript.AST.Exported

7070 Language.PureScript.Bundle

71+ Language.PureScript.Externs

7172 Language.PureScript.CodeGen

72− Language.PureScript.CodeGen.Externs

7373 Language.PureScript.CodeGen.JS

7474 Language.PureScript.CodeGen.JS.AST

7575 Language.PureScript.CodeGen.JS.Common

src/Language/PureScript/AST/Declarations.hs+6−12

@@ -14,10 +14,13 @@

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

1616{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE TemplateHaskell #-}

1718{-# LANGUAGE CPP #-}

1819

1920module Language.PureScript.AST.Declarations where

2021

22+import Data.Aeson.TH

23+

2124import qualified Data.Data as D

2225import qualified Data.Map as M

2326

@@ -147,10 +150,6 @@ data Declaration

147150 --

148151 | ExternDataDeclaration ProperName Kind

149152 -- |

150− -- A type class instance foreign import

151− --

152− | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]

153− -- |

154153 -- A fixity declaration (fixity data, operator name)

155154 --

156155 | FixityDeclaration Fixity String

@@ -222,14 +221,6 @@ isExternDataDecl ExternDataDeclaration{} = True

222221isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

223222isExternDataDecl _ = False

224223

225−-- |

226−-- Test if a declaration is a type class instance foreign import

227−--

228−isExternInstanceDecl :: Declaration -> Bool

229−isExternInstanceDecl ExternInstanceDeclaration{} = True

230−isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d

231−isExternInstanceDecl _ = False

232−

233224-- |

234225-- Test if a declaration is a fixity declaration

235226--

@@ -442,3 +433,6 @@ data DoNotationElement

442433 -- A do notation element with source position information

443434 --

444435 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)

436+

437+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

438+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

src/Language/PureScript/AST/Operators.hs+9

@@ -36,9 +36,18 @@ showAssoc Infixl = "infixl"

3636showAssoc Infixr = "infixr"

3737showAssoc Infix = "infix"

3838

39+readAssoc :: String -> Associativity

40+readAssoc "infixl" = Infixl

41+readAssoc "infixr" = Infixr

42+readAssoc "infix" = Infix

43+readAssoc _ = error "readAssoc: no parse"

44+

3945instance A.ToJSON Associativity where

4046 toJSON = A.toJSON . showAssoc

4147

48+instance A.FromJSON Associativity where

49+ parseJSON = fmap readAssoc . A.parseJSON

50+

4251-- |

4352-- Fixity data for infix operators

4453--

src/Language/PureScript/AST/SourcePos.hs+13−1

@@ -20,7 +20,7 @@

2020module Language.PureScript.AST.SourcePos where

2121

2222import qualified Data.Data as D

23−import Data.Aeson ((.=))

23+import Data.Aeson ((.=), (.:))

2424import qualified Data.Aeson as A

2525

2626-- |

@@ -46,6 +46,11 @@ instance A.ToJSON SourcePos where

4646 toJSON SourcePos{..} =

4747 A.toJSON [sourcePosLine, sourcePosColumn]

4848

49+instance A.FromJSON SourcePos where

50+ parseJSON arr = do

51+ [line, col] <- A.parseJSON arr

52+ return $ SourcePos line col

53+

4954data SourceSpan = SourceSpan

5055 { -- |

5156 -- Source name

@@ -77,5 +82,12 @@ instance A.ToJSON SourceSpan where

7782 , "end" .= spanEnd

7883 ]

7984

85+instance A.FromJSON SourceSpan where

86+ parseJSON = A.withObject "SourceSpan" $ \o ->

87+ SourceSpan <$>

88+ o .: "name" <*>

89+ o .: "start" <*>

90+ o .: "end"

91+

8092internalModuleSourceSpan :: String -> SourceSpan

8193internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)

src/Language/PureScript/AST/Traversals.hs−1

@@ -397,7 +397,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

397397 where

398398 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

399399 forDecls (ExternDeclaration _ ty) = f ty

400− forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

401400 forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)

402401 forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

403402 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

src/Language/PureScript/CodeGen.hs−5

@@ -13,13 +13,8 @@

1313--

1414-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript

1515--

16−-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files

17−--

18−-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript

19−--

2016-----------------------------------------------------------------------------

2117

2218module Language.PureScript.CodeGen (module C) where

2319

2420import Language.PureScript.CodeGen.JS as C

25−import Language.PureScript.CodeGen.Externs as C

src/Language/PureScript/CodeGen/Externs.hsdeleted−144

@@ -1,144 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.Externs

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

13−--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.CodeGen.Externs (

17− moduleToPs

18−) where

19−

20−import Data.List (intercalate, find)

21−import Data.Maybe (fromMaybe, mapMaybe)

22−import qualified Data.Map as M

23−

24−import Control.Monad.Writer

25−

26−import Language.PureScript.AST

27−import Language.PureScript.Comments

28−import Language.PureScript.Environment

29−import Language.PureScript.Kinds

30−import Language.PureScript.Names

31−import Language.PureScript.Pretty

32−import Language.PureScript.TypeClassDictionaries

33−import Language.PureScript.Types

34−

35−-- |

36−-- Generate foreign imports for all declarations in a module

37−--

38−moduleToPs :: Module -> Environment -> String

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

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

41− let exps = listRefs exts

42− tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]

43− mapM_ declToPs ds

44− mapM_ exportToPs exts

45− where

46−

47− listRefs :: [DeclarationRef] -> String

48− listRefs = intercalate ", " . mapMaybe listRef

49−

50− listRef :: DeclarationRef -> Maybe String

51− listRef (PositionedDeclarationRef _ _ d) = listRef d

52− listRef (TypeRef name Nothing) = Just $ runProperName name ++ "()"

53− listRef (TypeRef name (Just dctors)) = Just $ runProperName name ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

54− listRef (ValueRef name) = Just $ showIdent name

55− listRef (TypeClassRef name) = Just $ runProperName name

56− listRef (ModuleRef name) = Just $ "module " ++ runModuleName name

57− listRef _ = Nothing

58−

59− declToPs :: Declaration -> Writer [String] ()

60− declToPs (ImportDeclaration mn imp Nothing) =

61− tell ["import " ++ runModuleName mn ++ importToPs imp]

62− declToPs (ImportDeclaration mn imp (Just qual)) =

63− tell ["import qualified " ++ runModuleName mn ++ importToPs imp ++ " as " ++ runModuleName qual]

64− declToPs (FixityDeclaration (Fixity assoc prec) op) =

65− case find exportsOp exts of

66− Nothing -> return ()

67− Just _ -> tell [ unwords [ showAssoc assoc, show prec, op ] ]

68− where

69− exportsOp :: DeclarationRef -> Bool

70− exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

71− exportsOp (ValueRef ident') = ident' == Op op

72− exportsOp _ = False

73− declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d

74− declToPs _ = return ()

75−

76− importToPs :: ImportDeclarationType -> String

77− importToPs Implicit = ""

78− importToPs (Explicit refs) = " (" ++ listRefs refs ++ ")"

79− importToPs (Hiding refs) = " hiding (" ++ listRefs refs ++ ")"

80−

81− commentToPs :: Comment -> Writer [String] ()

82− commentToPs (LineComment s) = tell ["-- " ++ s]

83− commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]

84−

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

86− exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r

87− exportToPs (TypeRef pn dctors) =

88− case Qualified (Just moduleName) pn `M.lookup` types env of

89− Nothing -> error $ runProperName pn ++ " has no kind in exportToPs"

90− Just (kind, ExternData) ->

91− tell ["foreign import data " ++ runProperName pn ++ " :: " ++ prettyPrintKind kind]

92− Just (_, DataType args tys) -> do

93− let dctors' = fromMaybe (map fst tys) dctors

94− printDctor dctor = case dctor `lookup` tys of

95− Nothing -> Nothing

96− Just tyArgs -> Just $ runProperName dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)

97− let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')

98− then "newtype"

99− else "data"

100− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)

101− tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

102− Just (_, TypeSynonym) ->

103− case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

104− Nothing -> error $ runProperName pn ++ " has no type synonym info in exportToPs"

105− Just (args, synTy) ->

106− let

107− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)

108− in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]

109− _ -> error "Invalid input in exportToPs"

110−

111− exportToPs (ValueRef ident) =

112− case (moduleName, ident) `M.lookup` names env of

113− Nothing -> error $ showIdent ident ++ " has no type in exportToPs"

114− Just (ty, nk, _) | nk == Public || nk == External ->

115− tell ["foreign import " ++ showIdent ident ++ " :: " ++ prettyPrintType ty]

116− _ -> return ()

117− exportToPs (TypeClassRef className) =

118− case Qualified (Just moduleName) className `M.lookup` typeClasses env of

119− Nothing -> error $ runProperName className ++ " has no type class definition in exportToPs"

120− Just (args, members, implies) -> do

121− let impliesString = if null implies

122− then ""

123− else "(" ++ intercalate ", " (map (\(pn, tys') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "

124− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)

125− tell ["class " ++ impliesString ++ typeName ++ " where"]

126− forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

127− tell [ " " ++ showIdent member ++ " :: " ++ prettyPrintType ty ]

128−

129− exportToPs (TypeInstanceRef ident) = do

130− let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =

131− fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] (M.elems >=> M.elems) . M.lookup (Just moduleName) $ typeClassDictionaries env

132− let constraintsText = case fromMaybe [] deps of

133− [] -> ""

134− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

135− tell ["foreign import instance " ++ showIdent ident ++ " :: " ++ constraintsText ++ showQualified runProperName className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

136−

137− exportToPs (ModuleRef _) = return ()

138−

139− toTypeVar :: (String, Maybe Kind) -> Type

140− toTypeVar (s, Nothing) = TypeVar s

141− toTypeVar (s, Just k) = KindedType (TypeVar s) k

142−

143− isValueExported :: Ident -> Bool

144− isValueExported ident = ValueRef ident `elem` exts

src/Language/PureScript/Comments.hs+4

@@ -14,12 +14,16 @@

1414-----------------------------------------------------------------------------

1515

1616{-# LANGUAGE DeriveDataTypeable #-}

17+{-# LANGUAGE TemplateHaskell #-}

1718

1819module Language.PureScript.Comments where

1920

21+import Data.Aeson.TH

2022import qualified Data.Data as D

2123

2224data Comment

2325 = LineComment String

2426 | BlockComment String

2527 deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

28+

29+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

src/Language/PureScript/CoreFn/Desugar.hs−1

@@ -225,7 +225,6 @@ importToCoreFn _ = Nothing

225225--

226226externToCoreFn :: A.Declaration -> Maybe ForeignDecl

227227externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty)

228−externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, tyObject)

229228externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d

230229externToCoreFn _ = Nothing

231230

src/Language/PureScript/Docs/ParseAndDesugar.hs+1−1

@@ -122,7 +122,7 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

122122desugar = P.evalSupplyT 0 . desugar'

123123 where

124124 desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

125− desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports

125+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []

126126 ignoreWarnings m = liftM fst (runWriterT m)

127127

128128parseFile :: FilePath -> IO (FilePath, String)

src/Language/PureScript/Environment.hs+6−2

@@ -14,11 +14,13 @@

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

1616{-# LANGUAGE OverloadedStrings #-}

17+{-# LANGUAGE TemplateHaskell #-}

1718

1819module Language.PureScript.Environment where

1920

2021import Data.Data

2122import Data.Maybe (fromMaybe)

23+import Data.Aeson.TH

2224import qualified Data.Map as M

2325import qualified Data.Text as T

2426import qualified Data.Aeson as A

@@ -42,8 +44,8 @@ data Environment = Environment {

4244 --

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

4446 -- |

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

46− --

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

48+ -- constructor name, argument types and return type.

4749 , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

4850 -- |

4951 -- Type synonyms currently in scope

@@ -266,3 +268,5 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of

266268lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)

267269lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env

268270lookupValue _ _ = Nothing

271+

272+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)

src/Language/PureScript/Externs.hsnew file+163

@@ -0,0 +1,163 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Externs

5+-- License : MIT (http://opensource.org/licenses/MIT)

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE CPP #-}

17+{-# LANGUAGE RecordWildCards #-}

18+{-# LANGUAGE PatternGuards #-}

19+{-# LANGUAGE TemplateHaskell #-}

20+

21+module Language.PureScript.Externs

22+ ( ExternsFile(..)

23+ , ExternsDeclaration(..)

24+ , moduleToExternsFile

25+ , applyExternsFileToEnvironment

26+ ) where

27+

28+import Data.List (find, foldl')

29+import Data.Maybe (mapMaybe, maybeToList, fromMaybe)

30+import Data.Foldable (fold)

31+import Data.Version (showVersion)

32+#if __GLASGOW_HASKELL__ < 710

33+import Data.Monoid

34+#endif

35+import Data.Aeson.TH

36+

37+import qualified Data.Map as M

38+

39+import Language.PureScript.AST

40+import Language.PureScript.Environment

41+import Language.PureScript.Names

42+import Language.PureScript.Types

43+import Language.PureScript.Kinds

44+import Language.PureScript.TypeClassDictionaries

45+

46+import Paths_purescript as Paths

47+

48+-- | The data which will be serialized to an externs file

49+data ExternsFile = ExternsFile

50+ {

51+ -- ^ The externs version

52+ efVersion :: String

53+ -- ^ Module name

54+ , efModuleName :: ModuleName

55+ -- ^ List of module exports

56+ , efExports :: [DeclarationRef]

57+ -- ^ List of module imports

58+ , efImports :: [(ModuleName, ImportDeclarationType, Maybe ModuleName)]

59+ -- ^ List of operators and their fixities

60+ , efFixities :: [(Associativity, Precedence, String)]

61+ -- ^ List of type and value declaration

62+ , efDeclarations :: [ExternsDeclaration]

63+ } deriving (Show, Read)

64+

65+-- | A type or value declaration appearing in an externs file

66+data ExternsDeclaration =

67+ -- ^ A type declaration

68+ EDType ProperName Kind TypeKind

69+ -- ^ A type synonym

70+ | EDTypeSynonym ProperName [(String, Maybe Kind)] Type

71+ -- ^ A data construtor

72+ | EDDataConstructor ProperName DataDeclType ProperName Type [Ident]

73+ -- ^ A value declaration

74+ | EDValue Ident Type

75+ -- ^ A type class declaration

76+ | EDClass ProperName [(String, Maybe Kind)] [(Ident, Type)] [Constraint]

77+ -- ^ An instance declaration

78+ | EDInstance (Qualified ProperName) Ident [Type] (Maybe [Constraint])

79+ deriving (Show, Read)

80+

81+-- | Convert an externs file back into a module

82+applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment

83+applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations

84+ where

85+ applyDecl :: Environment -> ExternsDeclaration -> Environment

86+ applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }

87+ applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }

88+ applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

89+ applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }

90+ applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }

91+ applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

92+ where

93+ dict :: TypeClassDictionaryInScope

94+ dict = TypeClassDictionaryInScope (qual ident) [] className tys cs

95+

96+ updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a

97+ updateMap f = M.alter (Just . f . fold)

98+

99+ qual :: a -> Qualified a

100+ qual = Qualified (Just efModuleName)

101+

102+-- | Generate an externs file for all declarations in a module

103+moduleToExternsFile :: Module -> Environment -> ExternsFile

104+moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"

105+moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

106+ where

107+ efVersion = showVersion Paths.version

108+ efModuleName = mn

109+ efExports = exps

110+ efImports = mapMaybe importDecl ds

111+ efFixities = mapMaybe fixityDecl ds

112+ efDeclarations = concatMap toExternsDeclaration efExports

113+

114+ fixityDecl :: Declaration -> Maybe (Associativity, Precedence, String)

115+ fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (assoc, prec, op)) (find exportsOp exps)

116+ where

117+ exportsOp :: DeclarationRef -> Bool

118+ exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

119+ exportsOp (ValueRef ident') = ident' == Op op

120+ exportsOp _ = False

121+ fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d

122+ fixityDecl _ = Nothing

123+

124+ importDecl :: Declaration -> Maybe (ModuleName, ImportDeclarationType, Maybe ModuleName)

125+ importDecl (ImportDeclaration m mt qmn) = Just (m, mt, qmn)

126+ importDecl (PositionedDeclaration _ _ d) = importDecl d

127+ importDecl _ = Nothing

128+

129+ toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]

130+ toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r

131+ toExternsDeclaration (TypeRef pn dctors) =

132+ case Qualified (Just mn) pn `M.lookup` types env of

133+ Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration"

134+ Just (kind, TypeSynonym)

135+ | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]

136+ Just (kind, ExternData) -> [ EDType pn kind ExternData ]

137+ Just (kind, tk@(DataType _ tys)) ->

138+ EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args

139+ | dctor <- fromMaybe (map fst tys) dctors

140+ , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

141+ ]

142+ _ -> error "toExternsDeclaration: Invalid input"

143+ toExternsDeclaration (ValueRef ident)

144+ | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

145+ = [ EDValue ident ty ]

146+ toExternsDeclaration (TypeClassRef className)

147+ | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

148+ , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)

149+ , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env

150+ = [ EDType className kind TypeSynonym

151+ , EDTypeSynonym className args synTy

152+ , EDClass className args members implies

153+ ]

154+ toExternsDeclaration (TypeInstanceRef ident)

155+ = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies

156+ | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))

157+ , m2 <- M.elems m1

158+ , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)

159+ ]

160+ toExternsDeclaration _ = []

161+

162+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)

163+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)

src/Language/PureScript/Linter.hs−1

@@ -48,7 +48,6 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_

4848 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d

4949 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

5050 getDeclIdent (ExternDeclaration ident _) = Just ident

51− getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident

5251 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident

5352 getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."

5453 getDeclIdent _ = Nothing

src/Language/PureScript/Make.hs+42−40

@@ -48,14 +48,18 @@ import Control.Monad.Writer.Strict

4848import Control.Monad.Supply

4949

5050import Data.Function (on)

51−import Data.List (sortBy, groupBy)

51+import Data.Either (partitionEithers)

52+import Data.List (sortBy, groupBy, foldl')

5253import Data.Maybe (fromMaybe)

5354import Data.Time.Clock

55+import Data.String (fromString)

5456import Data.Foldable (for_)

5557#if __GLASGOW_HASKELL__ < 710

5658import Data.Traversable (traverse)

5759#endif

5860import Data.Version (showVersion)

61+import Data.Aeson (encode, decode)

62+import qualified Data.ByteString.Lazy as B

5963import qualified Data.Map as M

6064import qualified Data.Set as S

6165

@@ -65,14 +69,13 @@ import System.FilePath ((</>), takeDirectory)

6569import System.IO.Error (tryIOError)

6670

6771import Language.PureScript.AST

68−import Language.PureScript.CodeGen.Externs (moduleToPs)

72+import Language.PureScript.Externs

6973import Language.PureScript.Environment

7074import Language.PureScript.Errors

7175import Language.PureScript.Linter

7276import Language.PureScript.ModuleDependencies

7377import Language.PureScript.Names

7478import Language.PureScript.Options

75−import Language.PureScript.Parser

7679import Language.PureScript.Pretty

7780import Language.PureScript.Renamer

7881import Language.PureScript.Sugar

@@ -116,7 +119,7 @@ data MakeActions m = MakeActions {

116119 -- |

117120 -- Read the externs file for a module as a string and also return the actual

118121 -- path for the file.

119− , readExterns :: ModuleName -> m (FilePath, String)

122+ , readExterns :: ModuleName -> m (FilePath, B.ByteString)

120123 -- |

121124 -- Run the code generator for the module and write any required output files.

122125 --

@@ -130,7 +133,7 @@ data MakeActions m = MakeActions {

130133-- |

131134-- Generated code for an externs file.

132135--

133−type Externs = String

136+type Externs = B.ByteString

134137

135138-- |

136139-- Determines when to rebuild a module

@@ -161,18 +164,16 @@ make MakeActions{..} ms = do

161164 (Left RebuildNever, Just _) -> s

162165 _ -> S.insert moduleName' s) S.empty sorted

163166

164− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

165− for_ marked $ \(willRebuild, m) -> when willRebuild (lint m)

166− (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

167− evalSupplyT nextVar $ go initEnvironment desugared

167+ (externs, toBuild) <- partitionEithers <$> rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

168+ for_ toBuild lint

169+ (desugared, nextVar) <- runSupplyT 0 $ desugar externs toBuild

170+ let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

171+ evalSupplyT nextVar $ go env desugared

168172 where

169173

170− go :: Environment -> [(Bool, Module)] -> SupplyT m Environment

174+ go :: Environment -> [Module] -> SupplyT m Environment

171175 go env [] = return env

172− go env ((False, m) : ms') = do

173− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

174− go env' ms'

175− go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do

176+ go env (m@(Module ss coms moduleName' _ exps) : ms') = do

176177 lift . progress $ CompilingModule moduleName'

177178 (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m

178179 checkExhaustiveModule env' checked

@@ -180,27 +181,28 @@ make MakeActions{..} ms = do

180181 let mod' = Module ss coms moduleName' regrouped exps

181182 corefn = CF.moduleToCoreFn env' mod'

182183 [renamed] = renameInModules [corefn]

183− exts = moduleToPs mod' env'

184+ exts = encode $ moduleToExternsFile mod' env'

184185 codegen renamed env' exts

185186 go env' ms'

186187

187− rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

188− rebuildIfNecessary _ _ [] = return []

189− rebuildIfNecessary graph toRebuild (m@(Module _ _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do

190− let deps = fromMaybe [] $ moduleName' `M.lookup` graph

191− toRebuild' = toRebuild `S.union` S.fromList deps

192− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'

193− rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do

194− (path, externs) <- readExterns moduleName'

195− externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]

196− case externsModules of

197− [m'@(Module _ _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

198− _ -> throwError . errorMessage . InvalidExternsFile $ path

188+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Either ExternsFile Module]

189+ rebuildIfNecessary graph = rebuildIfNecessary'

199190 where

200− alterErrors = flip catchError $ \(MultipleErrors errs) ->

201− throwError . MultipleErrors $ flip map errs $ \e -> case e of

202− SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)

203− _ -> e

191+ rebuildIfNecessary' :: S.Set ModuleName -> [Module] -> m [Either ExternsFile Module]

192+ rebuildIfNecessary' _ [] = return []

193+ rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms')

194+ | moduleName' `S.member` toRebuild = rebuild toRebuild m moduleName' ms'

195+ rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms') = do

196+ (_, externsJson) <- readExterns moduleName'

197+ case decode externsJson of

198+ Just externs

199+ | efVersion externs == showVersion Paths.version -> (Left externs :) <$> rebuildIfNecessary' toRebuild ms'

200+ _ -> rebuild toRebuild m moduleName' ms'

201+

202+ rebuild :: S.Set ModuleName -> Module -> ModuleName -> [Module] -> m [Either ExternsFile Module]

203+ rebuild toRebuild m moduleName ms' = do

204+ let deps = fromMaybe [] $ moduleName `M.lookup` graph

205+ (Right m :) <$> rebuildIfNecessary' (toRebuild `S.union` S.fromList deps) ms'

204206

205207reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]

206208reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

@@ -268,12 +270,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

268270 getOutputTimestamp mn = do

269271 let filePath = runModuleName mn

270272 jsFile = outputDir </> filePath </> "index.js"

271− externsFile = outputDir </> filePath </> "externs.purs"

273+ externsFile = outputDir </> filePath </> "externs.json"

272274 min <$> getTimestamp jsFile <*> getTimestamp externsFile

273275

274− readExterns :: ModuleName -> Make (FilePath, String)

276+ readExterns :: ModuleName -> Make (FilePath, B.ByteString)

275277 readExterns mn = do

276− let path = outputDir </> runModuleName mn </> "externs.purs"

278+ let path = outputDir </> runModuleName mn </> "externs.json"

277279 (path, ) <$> readTextFile path

278280

279281 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()

@@ -290,12 +292,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

290292 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude

291293 let filePath = runModuleName mn

292294 jsFile = outputDir </> filePath </> "index.js"

293− externsFile = outputDir </> filePath </> "externs.purs"

295+ externsFile = outputDir </> filePath </> "externs.json"

294296 foreignFile = outputDir </> filePath </> "foreign.js"

295297 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

296298 js = unlines $ map ("// " ++) prefix ++ [pjs]

297299 lift $ do

298− writeTextFile jsFile js

300+ writeTextFile jsFile (fromString js)

299301 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

300302 writeTextFile externsFile exts

301303

@@ -307,13 +309,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

307309 exists <- doesFileExist path

308310 traverse (const $ getModificationTime path) $ guard exists

309311

310− readTextFile :: FilePath -> Make String

311− readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path

312+ readTextFile :: FilePath -> Make B.ByteString

313+ readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ B.readFile path

312314

313− writeTextFile :: FilePath -> String -> Make ()

315+ writeTextFile :: FilePath -> B.ByteString -> Make ()

314316 writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do

315317 mkdirp path

316− writeFile path text

318+ B.writeFile path text

317319 where

318320 mkdirp :: FilePath -> IO ()

319321 mkdirp = createDirectoryIfMissing True . takeDirectory

src/Language/PureScript/Names.hs+7−2

@@ -15,6 +15,7 @@

1515

1616{-# LANGUAGE DeriveDataTypeable #-}

1717{-# LANGUAGE DeriveFunctor #-}

18+{-# LANGUAGE TemplateHaskell #-}

1819{-# LANGUAGE GADTs #-}

1920

2021module Language.PureScript.Names where

@@ -22,6 +23,7 @@ module Language.PureScript.Names where

2223import Data.List

2324import Data.Data

2425import Data.List.Split (splitOn)

26+import Data.Aeson.TH

2527import qualified Data.Aeson as A

2628import qualified Data.Text as T

2729

@@ -54,7 +56,7 @@ newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read

5456-- |

5557-- Module names

5658--

57−data ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)

59+newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)

5860

5961runModuleName :: ModuleName -> String

6062runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

@@ -89,7 +91,6 @@ instance (a ~ ProperName) => A.FromJSON (Qualified a) where

8991 where

9092 reconstructModuleName = moduleNameFromString . intercalate "." . reverse

9193

92−

9394-- |

9495-- Provide a default module name, if a name is unqualified

9596--

@@ -109,3 +110,7 @@ mkQualified name mn = Qualified (Just mn) name

109110isUnqualified :: Qualified a -> Bool

110111isUnqualified (Qualified Nothing _) = True

111112isUnqualified _ = False

113+

114+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)

115+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)

116+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

src/Language/PureScript/Parser/Declarations.hs−10

@@ -115,16 +115,6 @@ parseExternDeclaration :: TokenParser Declaration

115115parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>

116116 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

117117 <*> (indented *> doubleColon *> parseKind)

118− <|> (do reserved "instance"

119− name <- parseIdent <* indented <* doubleColon

120− deps <- P.option [] $ do

121− deps' <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

122− indented

123− rfatArrow

124− return deps'

125− className <- indented *> parseQualified properName

126− tys <- P.many (indented *> noWildcards parseTypeAtom)

127− return $ ExternInstanceDeclaration name deps className tys)

128118 <|> (do ident <- parseIdent

129119 -- TODO: add a wiki page link with migration info

130120 -- TODO: remove this deprecation warning in 0.8

src/Language/PureScript/Sugar.hs+14−12

@@ -29,6 +29,7 @@ import Control.Monad.Supply.Class

2929

3030import Language.PureScript.AST

3131import Language.PureScript.Errors

32+import Language.PureScript.Externs

3233

3334import Language.PureScript.Sugar.BindingGroups as S

3435import Language.PureScript.Sugar.CaseDeclarations as S

@@ -63,15 +64,16 @@ import Language.PureScript.Sugar.TypeDeclarations as S

6364--

6465-- * Group mutually recursive value and data declarations into binding groups.

6566--

66−desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

67−desugar = map removeSignedLiterals

68− >>> mapM desugarObjectConstructors

69− >=> mapM desugarOperatorSections

70− >=> mapM desugarDoModule

71− >=> desugarCasesModule

72− >=> desugarTypeDeclarationsModule

73− >=> desugarImports

74− >=> rebracket

75− >=> mapM deriveInstances

76− >=> desugarTypeClasses

77− >=> createBindingGroupsModule

67+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

68+desugar externs =

69+ map removeSignedLiterals

70+ >>> mapM desugarObjectConstructors

71+ >=> mapM desugarOperatorSections

72+ >=> mapM desugarDoModule

73+ >=> desugarCasesModule

74+ >=> desugarTypeDeclarationsModule

75+ >=> desugarImports externs

76+ >=> rebracket externs

77+ >=> mapM deriveInstances

78+ >=> desugarTypeClasses externs

79+ >=> createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs−1

@@ -78,7 +78,6 @@ createBindingGroups moduleName = mapM f <=< handleDecls

7878 bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)

7979 return $ filter isImportDecl ds ++

8080 filter isExternDataDecl ds ++

81− filter isExternInstanceDecl ds ++

8281 dataBindingGroupDecls ++

8382 filter isTypeClassDeclaration ds ++

8483 filter isTypeClassInstanceDeclaration ds ++

src/Language/PureScript/Sugar/Names.hs+42−6

@@ -13,6 +13,7 @@

1313

1414{-# LANGUAGE CPP #-}

1515{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE RecordWildCards #-}

1617{-# LANGUAGE ScopedTypeVariables #-}

1718

1819module Language.PureScript.Sugar.Names (desugarImports) where

@@ -34,6 +35,7 @@ import Language.PureScript.Names

3435import Language.PureScript.Types

3536import Language.PureScript.Errors

3637import Language.PureScript.Traversals

38+import Language.PureScript.Externs

3739import Language.PureScript.Sugar.Names.Env

3840import Language.PureScript.Sugar.Names.Imports

3941import Language.PureScript.Sugar.Names.Exports

@@ -42,11 +44,47 @@ import Language.PureScript.Sugar.Names.Exports

4244-- Replaces all local names with qualified names within a list of modules. The

4345-- modules should be topologically sorted beforehand.

4446--

45−desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

46−desugarImports modules = do

47− env <- foldM updateEnv initEnv modules

48− mapM (renameInModule' env) modules

47+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

48+desugarImports externs modules = do

49+ env <- foldM externsEnv primEnv externs

50+ env' <- foldM updateEnv env modules

51+ mapM (renameInModule' env') modules

4952 where

53+ -- | Create an environment from a collection of externs files

54+ externsEnv :: Env -> ExternsFile -> m Env

55+ externsEnv env ExternsFile{..} = do

56+ let members = Exports{..}

57+ ss = internalModuleSourceSpan "<Externs>"

58+ env' = M.insert efModuleName (ss, nullImports, members) env

59+ fromEFImport (mn, mt, qmn) = (mn, [(Nothing, mt, qmn)])

60+ imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports)

61+ exps <- resolveExports env' efModuleName imps members efExports

62+ return $ M.insert efModuleName (ss, imps, exps) env

63+ where

64+

65+ exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

66+ exportedTypes = mapMaybe toExportedType efExports

67+ where

68+ toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

69+ where

70+ forTyCon :: ExternsDeclaration -> Maybe ProperName

71+ forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

72+ forTyCon _ = Nothing

73+ toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

74+ toExportedType _ = Nothing

75+ exportedTypeClasses :: [(ProperName, ModuleName)]

76+ exportedTypeClasses = mapMaybe toExportedTypeClass efExports

77+ where

78+ toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

79+ toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r

80+ toExportedTypeClass _ = Nothing

81+ exportedValues :: [(Ident, ModuleName)]

82+ exportedValues = mapMaybe toExportedValue efExports

83+ where

84+ toExportedValue (ValueRef ident) = Just (ident, efModuleName)

85+ toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

86+ toExportedValue _ = Nothing

87+

5088 updateEnv :: Env -> Module -> m Env

5189 updateEnv env m@(Module ss _ mn _ refs) =

5290 case mn `M.lookup` env of

@@ -120,8 +158,6 @@ renameInModule env imports (Module ss coms mn decls exps) =

120158 (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)

121159 updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =

122160 (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)

123− updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =

124− (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)

125161 updateDecl (pos, bound) (TypeDeclaration name ty) =

126162 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

127163 updateDecl (pos, bound) (ExternDeclaration name ty) =

src/Language/PureScript/Sugar/Names/Env.hs+6−12

@@ -12,10 +12,6 @@

1212-----------------------------------------------------------------------------

1313

1414{-# LANGUAGE FlexibleContexts #-}

15−--{-# LANGUAGE ScopedTypeVariables #-}

16−--{-# LANGUAGE PatternGuards #-}

17−--{-# LANGUAGE RankNTypes #-}

18−--{-# LANGUAGE TupleSections #-}

1915

2016module Language.PureScript.Sugar.Names.Env

2117 ( Imports(..)

@@ -23,7 +19,7 @@ module Language.PureScript.Sugar.Names.Env

2319 , Exports(..)

2420 , nullExports

2521 , Env

26− , initEnv

22+ , primEnv

2723 , envModuleSourceSpan

2824 , envModuleImports

2925 , envModuleExports

@@ -32,11 +28,11 @@ module Language.PureScript.Sugar.Names.Env

3228 , exportValue

3329 ) where

3430

31+import qualified Data.Map as M

32+

3533import Control.Monad

3634import Control.Monad.Error.Class (MonadError(..))

3735

38−import qualified Data.Map as M

39−

4036import Language.PureScript.AST

4137import Language.PureScript.Names

4238import Language.PureScript.Environment

@@ -136,11 +132,9 @@ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []

136132 where

137133 mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])

138134

139−-- |

140−-- The initial global import/export environment containing the @Prim@ module.

141−--

142−initEnv :: Env

143−initEnv = M.singleton

135+-- | Environment which only contains the Prim module.

136+primEnv :: Env

137+primEnv = M.singleton

144138 (ModuleName [ProperName "Prim"])

145139 (internalModuleSourceSpan "<Prim>", nullImports, primExports)

146140

src/Language/PureScript/Sugar/Names/Imports.hs+22−15

@@ -16,7 +16,10 @@

1616{-# LANGUAGE ScopedTypeVariables #-}

1717{-# LANGUAGE TupleSections #-}

1818

19−module Language.PureScript.Sugar.Names.Imports (resolveImports) where

19+module Language.PureScript.Sugar.Names.Imports

20+ ( resolveImports

21+ , resolveModuleImport

22+ ) where

2023

2124import Data.List (find)

2225import Data.Maybe (fromMaybe, isNothing)

@@ -59,25 +62,29 @@ findImports = foldM (go Nothing) M.empty

5962-- |

6063-- Constructs a set of imports for a module.

6164--

62−resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports

65+resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports

6366resolveImports env (Module _ _ currentModule decls _) =

6467 censor (onErrorMessages (ErrorInModule currentModule)) $ do

6568 scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls

66− foldM resolveImport' nullImports (M.toList scope)

69+ foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

70+

71+-- | Constructs a set of imports for a single module import.

72+resolveModuleImport ::

73+ forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

74+ ModuleName -> Env -> Imports ->

75+ (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) ->

76+ m Imports

77+resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

6778 where

68−

69− resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports

70− resolveImport' ie (mn, imps) = foldM go ie imps

79+ go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

80+ go ie' (pos, typ, impQual) = do

81+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

82+ let ie'' = ie' { importedModules = mn : importedModules ie' }

83+ positioned $ resolveImport currentModule mn modExports ie'' impQual typ

7184 where

72− go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

73− go ie' (pos, typ, impQual) = do

74− modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

75− let ie'' = ie' { importedModules = mn : importedModules ie' }

76− positioned $ resolveImport currentModule mn modExports ie'' impQual typ

77− where

78− positioned err = case pos of

79− Nothing -> err

80− Just pos' -> rethrowWithPosition pos' err

85+ positioned err = case pos of

86+ Nothing -> err

87+ Just pos' -> rethrowWithPosition pos' err

8188

8289-- |

8390-- Extends the local environment for a module by resolving an import of another module.

src/Language/PureScript/Sugar/Operators.hs+11−3

@@ -20,6 +20,7 @@

2020{-# LANGUAGE Rank2Types #-}

2121{-# LANGUAGE FlexibleContexts #-}

2222{-# LANGUAGE ScopedTypeVariables #-}

23+{-# LANGUAGE RecordWildCards #-}

2324{-# LANGUAGE CPP #-}

2425

2526module Language.PureScript.Sugar.Operators (

@@ -31,6 +32,7 @@ module Language.PureScript.Sugar.Operators (

3132import Language.PureScript.AST

3233import Language.PureScript.Errors

3334import Language.PureScript.Names

35+import Language.PureScript.Externs

3436

3537#if __GLASGOW_HASKELL__ < 710

3638import Control.Applicative

@@ -52,9 +54,9 @@ import qualified Language.PureScript.Constants as C

5254-- |

5355-- Remove explicit parentheses and reorder binary operator applications

5456--

55−rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

56−rebracket ms = do

57− let fixities = concatMap collectFixities ms

57+rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

58+rebracket externs ms = do

59+ let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

5860 ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities

5961 let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities

6062 mapM (rebracketModule opTable) ms

@@ -80,6 +82,12 @@ removeParens =

8082 go (Parens val) = val

8183 go val = val

8284

85+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]

86+externsFixities ExternsFile{..} =

87+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)

88+ | (assoc, prec, op) <- efFixities

89+ ]

90+

8391collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]

8492collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

8593 where

src/Language/PureScript/Sugar/TypeClasses.hs+14−6

@@ -15,6 +15,7 @@

1515-----------------------------------------------------------------------------

1616

1717{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE RecordWildCards #-}

1819{-# LANGUAGE CPP #-}

1920

2021module Language.PureScript.Sugar.TypeClasses

@@ -28,6 +29,7 @@ import Language.PureScript.Environment

2829import Language.PureScript.Errors

2930import Language.PureScript.Kinds

3031import Language.PureScript.Names

32+import Language.PureScript.Externs

3133import Language.PureScript.Sugar.CaseDeclarations

3234import Control.Monad.Supply.Class

3335import Language.PureScript.Types

@@ -45,7 +47,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)

4547

4648import qualified Data.Map as M

4749

48−type MemberMap = M.Map (ModuleName, ProperName) Declaration

50+type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])

4951

5052type Desugar = StateT MemberMap

5153

@@ -53,8 +55,15 @@ type Desugar = StateT MemberMap

5355-- Add type synonym declarations for type class dictionary types, and value declarations for type class

5456-- instance dictionary expressions.

5557--

56−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

57−desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

58+desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

59+desugarTypeClasses externs = flip evalStateT initialState . mapM desugarModule

60+ where

61+ initialState :: MemberMap

62+ initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

63+

64+ fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

65+ fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

66+ fromExternsDecl _ _ = Nothing

5867

5968desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module

6069desugarModule (Module ss coms name decls (Just exps)) = do

@@ -166,9 +175,8 @@ desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErro

166175desugarDecl mn exps = go

167176 where

168177 go d@(TypeClassDeclaration name args implies members) = do

169− modify (M.insert (mn, name) d)

178+ modify (M.insert (mn, name) (args, implies, members))

170179 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

171− go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])

172180 go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"

173181 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

174182 desugared <- desugarCases members

@@ -239,7 +247,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

239247 m <- get

240248

241249 -- Lookup the type arguments and member types for the type class

242− (TypeClassDeclaration _ args implies tyDecls) <-

250+ (args, implies, tyDecls) <-

243251 maybe (throwError . errorMessage $ UnknownTypeClass className) return $

244252 M.lookup (qualify mn className) m

245253

src/Language/PureScript/TypeChecker.hs+3−9

@@ -212,17 +212,12 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

212212 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

213213 return d

214214 go (d@(FixityDeclaration{})) = return d

215− go (d@(ImportDeclaration importedModule _ _)) = do

216− instances <- lookupTypeClassDictionaries $ Just importedModule

217− addTypeClassDictionaries (Just moduleName) instances

218− return d

215+ go (d@(ImportDeclaration{})) = return d

219216 go (d@(TypeClassDeclaration pn args implies tys)) = do

220217 addTypeClass moduleName pn args implies tys

221218 return d

222219 go (d@(TypeInstanceDeclaration dictName deps className tys _)) =

223220 goInstance d dictName deps className tys

224− go (d@(ExternInstanceDeclaration dictName deps className tys)) =

225− goInstance d dictName deps className tys

226221 go (PositionedDeclaration pos com d) =

227222 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

228223

@@ -239,8 +234,8 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

239234 mapM_ (checkTypeClassInstance moduleName) tys

240235 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

241236 checkOrphanInstance moduleName className tys

242− let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) TCDRegular

243− addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict

237+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

238+ addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict

244239 return d

245240

246241 where

@@ -295,7 +290,6 @@ typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRe

295290 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

296291 exports (ValueRef id1) (ValueRef id2) = id1 == id2

297292 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2

298− exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2

299293 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2

300294 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2

301295 exports _ _ = False

src/Language/PureScript/TypeChecker/Entailment.hs+12−5

@@ -22,7 +22,7 @@ module Language.PureScript.TypeChecker.Entailment (

2222

2323import Data.Function (on)

2424import Data.List

25−import Data.Maybe (maybeToList)

25+import Data.Maybe (maybeToList, mapMaybe)

2626#if __GLASGOW_HASKELL__ < 710

2727import Data.Foldable (foldMap)

2828#endif

@@ -54,8 +54,15 @@ import qualified Language.PureScript.Constants as C

5454entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr

5555entails env moduleName context = solve

5656 where

57− forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]

58− forClassName cn = findDicts cn Nothing ++ findDicts cn (Just moduleName)

57+ forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

58+ forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

59+ forClassName _ _ = error "forClassName: expected qualified class name"

60+

61+ ctorModules :: Type -> Maybe ModuleName

62+ ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

63+ ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name"

64+ ctorModules (TypeApp ty _) = ctorModules ty

65+ ctorModules _ = Nothing

5966

6067 findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]

6168 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

@@ -69,7 +76,7 @@ entails env moduleName context = solve

6976 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

7077 go work className' tys' = do

7178 let instances = do

72− tcd <- forClassName className'

79+ tcd <- forClassName className' tys'

7380 -- Make sure the type unifies with the type in the type instance definition

7481 subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

7582 return (subst, tcd)

@@ -77,7 +84,7 @@ entails env moduleName context = solve

7784 -- Solve any necessary subgoals

7885 args <- solveSubgoals subst (tcdDependencies tcd)

7986 return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)

80− (mkDictionary (canonicalizeDictionary tcd) args)

87+ (mkDictionary (tcdName tcd) args)

8188 (tcdPath tcd)

8289 where

8390

src/Language/PureScript/TypeChecker/Monad.hs+1−2

@@ -76,7 +76,7 @@ withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified

7676withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

7777withTypeClassDictionaries entries action = do

7878 orig <- get

79− let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (canonicalizeDictionary entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

79+ let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

8080 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }

8181 a <- action

8282 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

@@ -276,4 +276,3 @@ liftUnifyWarnings replace unify = do

276276 let uust = unifyCurrentSubstitution ust

277277 tell $ onErrorMessages (replace uust) w

278278 return (a, uust)

279−

src/Language/PureScript/TypeChecker/Types.hs+1−1

@@ -469,7 +469,7 @@ check' val t@(ConstrainedType constraints ty) = do

469469 name

470470 (supName, instantiateSuperclass (map fst args) supArgs instanceTy)

471471 ) superclasses [0..]

472− return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts)

472+ return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)

473473

474474 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]

475475 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

src/Language/PureScript/TypeClassDictionaries.hs−22

@@ -36,23 +36,8 @@ data TypeClassDictionaryInScope

3636 , tcdInstanceTypes :: [Type]

3737 -- | Type class dependencies which must be satisfied to construct this dictionary

3838 , tcdDependencies :: Maybe [Constraint]

39− -- | The type of this dictionary

40− , tcdType :: TypeClassDictionaryType

4139 } deriving (Show, Read, Data, Typeable)

4240

43−-- |

44−-- The type of a type class dictionary

45−--

46−data TypeClassDictionaryType

47− -- |

48− -- A regular type class dictionary

49− --

50− = TCDRegular

51− -- |

52− -- A type class dictionary which is an alias for an imported dictionary from another module

53− --

54− | TCDAlias (Qualified Ident) deriving (Show, Read, Eq, Data, Typeable)

55−

5641-- |

5742-- A simplified representation of expressions which are used to represent type

5843-- class dictionaries at runtime, which can be compared for equality

@@ -75,10 +60,3 @@ data DictionaryValue

7560 --

7661 | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

7762 deriving (Show, Read, Ord, Eq)

78−

79−-- |

80−-- Find the original dictionary which a type class dictionary in scope refers to

81−--

82−canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

83−canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

84−canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm