72ce900 · rowtype-yoga/purescript-native

psci/Parser.hs−1

compare with golang

unifiedsplit

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

131acceptable P.TypeSynonymDeclaration{} = True

132acceptable P.ExternDeclaration{} = True

133acceptable P.ExternDataDeclaration{} = True

134−acceptable P.ExternInstanceDeclaration{} = True

135acceptable P.TypeClassDeclaration{} = True

134acceptable P.TypeClassDeclaration{} = True

136acceptable P.TypeInstanceDeclaration{} = True

135acceptable P.TypeInstanceDeclaration{} = True

137acceptable _ = False

136acceptable _ = False

purescript.cabal+1−1

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

68 Language.PureScript.AST.Traversals

69 Language.PureScript.AST.Exported

70 Language.PureScript.Bundle

71+ Language.PureScript.Externs

71 Language.PureScript.CodeGen

72 Language.PureScript.CodeGen

72− Language.PureScript.CodeGen.Externs

73 Language.PureScript.CodeGen.JS

74 Language.PureScript.CodeGen.JS.AST

75 Language.PureScript.CodeGen.JS.Common

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

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

14

15{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE TemplateHaskell #-}

17{-# LANGUAGE CPP #-}

18{-# LANGUAGE CPP #-}

18

19

19module Language.PureScript.AST.Declarations where

20module Language.PureScript.AST.Declarations where

20

21

22+import Data.Aeson.TH

23+

21import qualified Data.Data as D

24import qualified Data.Data as D

22import qualified Data.Map as M

25import qualified Data.Map as M

23

26

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

147 --

150 --

148 | ExternDataDeclaration ProperName Kind

151 | ExternDataDeclaration ProperName Kind

149 -- |

152 -- |

150− -- A type class instance foreign import

151− --

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

153− -- |

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

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

155 --

154 --

156 | FixityDeclaration Fixity String

155 | FixityDeclaration Fixity String

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

222isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

221isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

223isExternDataDecl _ = False

222isExternDataDecl _ = False

224

223

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−

233-- |

224-- |

234-- Test if a declaration is a fixity declaration

225-- Test if a declaration is a fixity declaration

235--

226--

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

442 -- A do notation element with source position information

433 -- A do notation element with source position information

443 --

434 --

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

435 | 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"

36showAssoc Infixr = "infixr"

37showAssoc Infix = "infix"

38

39+readAssoc :: String -> Associativity

40+readAssoc "infixl" = Infixl

41+readAssoc "infixr" = Infixr

42+readAssoc "infix" = Infix

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

44+

39instance A.ToJSON Associativity where

45instance A.ToJSON Associativity where

40 toJSON = A.toJSON . showAssoc

46 toJSON = A.toJSON . showAssoc

41

47

48+instance A.FromJSON Associativity where

49+ parseJSON = fmap readAssoc . A.parseJSON

50+

42-- |

51-- |

43-- Fixity data for infix operators

52-- Fixity data for infix operators

44--

53--

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

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

20module Language.PureScript.AST.SourcePos where

21

22import qualified Data.Data as D

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

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

24import qualified Data.Aeson as A

25

26-- |

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

46 toJSON SourcePos{..} =

47 A.toJSON [sourcePosLine, sourcePosColumn]

48

49+instance A.FromJSON SourcePos where

50+ parseJSON arr = do

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

52+ return $ SourcePos line col

53+

49data SourceSpan = SourceSpan

54data SourceSpan = SourceSpan

50 { -- |

55 { -- |

51 -- Source name

56 -- Source name

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

77 , "end" .= spanEnd

82 , "end" .= spanEnd

78 ]

83 ]

79

84

85+instance A.FromJSON SourceSpan where

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

87+ SourceSpan <$>

88+ o .: "name" <*>

89+ o .: "start" <*>

90+ o .: "end"

91+

80internalModuleSourceSpan :: String -> SourceSpan

92internalModuleSourceSpan :: String -> SourceSpan

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

93internalModuleSourceSpan 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

397 where

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

399 forDecls (ExternDeclaration _ ty) = f ty

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

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

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

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

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

403 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

402 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

src/Language/PureScript/CodeGen.hs−5

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

13--

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

15--

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

17−--

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

19−--

20-----------------------------------------------------------------------------

16-----------------------------------------------------------------------------

21

17

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

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

23

19

24import Language.PureScript.CodeGen.JS as C

20import 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 @@

14-----------------------------------------------------------------------------

15

16{-# LANGUAGE DeriveDataTypeable #-}

17+{-# LANGUAGE TemplateHaskell #-}

17

18

18module Language.PureScript.Comments where

19module Language.PureScript.Comments where

19

20

21+import Data.Aeson.TH

20import qualified Data.Data as D

22import qualified Data.Data as D

21

23

22data Comment

24data Comment

23 = LineComment String

25 = LineComment String

24 | BlockComment String

26 | BlockComment String

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

27 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

225--

226externToCoreFn :: A.Declaration -> Maybe ForeignDecl

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

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

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

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

230externToCoreFn _ = Nothing

229externToCoreFn _ = Nothing

231

230

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

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

122desugar = P.evalSupplyT 0 . desugar'

123 where

124 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 []

126 ignoreWarnings m = liftM fst (runWriterT m)

127

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

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

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

14

15{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE OverloadedStrings #-}

17+{-# LANGUAGE TemplateHaskell #-}

17

18

18module Language.PureScript.Environment where

19module Language.PureScript.Environment where

19

20

20import Data.Data

21import Data.Data

21import Data.Maybe (fromMaybe)

22import Data.Maybe (fromMaybe)

23+import Data.Aeson.TH

22import qualified Data.Map as M

24import qualified Data.Map as M

23import qualified Data.Text as T

25import qualified Data.Text as T

24import qualified Data.Aeson as A

26import qualified Data.Aeson as A

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

42 --

44 --

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

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

44 -- |

46 -- |

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

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

46− --

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

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

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

48 -- |

50 -- |

49 -- Type synonyms currently in scope

51 -- Type synonyms currently in scope

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

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

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

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

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

268lookupValue _ _ = Nothing

270lookupValue _ _ = 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_

48 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d

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

50 getDeclIdent (ExternDeclaration ident _) = Just ident

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

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

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

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

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

54 getDeclIdent _ = Nothing

53 getDeclIdent _ = Nothing

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

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

48import Control.Monad.Supply

49

50import Data.Function (on)

51+import Data.Either (partitionEithers)

51−import Data.List (sortBy, groupBy)

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

52import Data.Maybe (fromMaybe)

53import Data.Maybe (fromMaybe)

53import Data.Time.Clock

54import Data.Time.Clock

55+import Data.String (fromString)

54import Data.Foldable (for_)

56import Data.Foldable (for_)

55#if __GLASGOW_HASKELL__ < 710

57#if __GLASGOW_HASKELL__ < 710

56import Data.Traversable (traverse)

58import Data.Traversable (traverse)

57#endif

59#endif

58import Data.Version (showVersion)

60import Data.Version (showVersion)

61+import Data.Aeson (encode, decode)

62+import qualified Data.ByteString.Lazy as B

59import qualified Data.Map as M

63import qualified Data.Map as M

60import qualified Data.Set as S

64import qualified Data.Set as S

61

65

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

65import System.IO.Error (tryIOError)

69import System.IO.Error (tryIOError)

66

70

67import Language.PureScript.AST

71import Language.PureScript.AST

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

72+import Language.PureScript.Externs

69import Language.PureScript.Environment

73import Language.PureScript.Environment

70import Language.PureScript.Errors

74import Language.PureScript.Errors

71import Language.PureScript.Linter

75import Language.PureScript.Linter

72import Language.PureScript.ModuleDependencies

76import Language.PureScript.ModuleDependencies

73import Language.PureScript.Names

77import Language.PureScript.Names

74import Language.PureScript.Options

78import Language.PureScript.Options

75−import Language.PureScript.Parser

76import Language.PureScript.Pretty

79import Language.PureScript.Pretty

77import Language.PureScript.Renamer

80import Language.PureScript.Renamer

78import Language.PureScript.Sugar

81import Language.PureScript.Sugar

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

116 -- |

119 -- |

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

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

118 -- path for the file.

121 -- path for the file.

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

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

120 -- |

123 -- |

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

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

122 --

125 --

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

130-- |

133-- |

131-- Generated code for an externs file.

134-- Generated code for an externs file.

132--

135--

133−type Externs = String

136+type Externs = B.ByteString

134

137

135-- |

138-- |

136-- Determines when to rebuild a module

139-- Determines when to rebuild a module

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

161 (Left RebuildNever, Just _) -> s

164 (Left RebuildNever, Just _) -> s

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

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

163

166

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

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

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

168+ for_ toBuild lint

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

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

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

167− evalSupplyT nextVar $ go initEnvironment desugared

171+ evalSupplyT nextVar $ go env desugared

168 where

172 where

169

173

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

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

171 go env [] = return env

175 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

176 lift . progress $ CompilingModule moduleName'

177 lift . progress $ CompilingModule moduleName'

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

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

178 checkExhaustiveModule env' checked

179 checkExhaustiveModule env' checked

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

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

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

181 corefn = CF.moduleToCoreFn env' mod'

182 corefn = CF.moduleToCoreFn env' mod'

182 [renamed] = renameInModules [corefn]

183 [renamed] = renameInModules [corefn]

183− exts = moduleToPs mod' env'

184+ exts = encode $ moduleToExternsFile mod' env'

184 codegen renamed env' exts

185 codegen renamed env' exts

185 go env' ms'

186 go env' ms'

186

187

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

188+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Either ExternsFile 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

189+ rebuildIfNecessary graph = rebuildIfNecessary'

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

199 where

190 where

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

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

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

192+ rebuildIfNecessary' _ [] = return []

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

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

203− _ -> e

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'

204

206

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

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

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

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

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

268 getOutputTimestamp mn = do

270 getOutputTimestamp mn = do

269 let filePath = runModuleName mn

271 let filePath = runModuleName mn

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

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

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

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

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

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

273

275

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

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

275 readExterns mn = do

277 readExterns mn = do

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

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

277 (path, ) <$> readTextFile path

279 (path, ) <$> readTextFile path

278

280

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

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

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

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

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

291 let filePath = runModuleName mn

293 let filePath = runModuleName mn

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

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

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

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

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

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

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

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

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

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

297 lift $ do

299 lift $ do

298− writeTextFile jsFile js

300+ writeTextFile jsFile (fromString js)

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

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

300 writeTextFile externsFile exts

302 writeTextFile externsFile exts

301

303

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

307 exists <- doesFileExist path

309 exists <- doesFileExist path

308 traverse (const $ getModificationTime path) $ guard exists

310 traverse (const $ getModificationTime path) $ guard exists

309

311

310− readTextFile :: FilePath -> Make String

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

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

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

312

314

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

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

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

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

315 mkdirp path

317 mkdirp path

316− writeFile path text

318+ B.writeFile path text

317 where

319 where

318 mkdirp :: FilePath -> IO ()

320 mkdirp :: FilePath -> IO ()

319 mkdirp = createDirectoryIfMissing True . takeDirectory

321 mkdirp = createDirectoryIfMissing True . takeDirectory

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

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

15

16{-# LANGUAGE DeriveDataTypeable #-}

17{-# LANGUAGE DeriveFunctor #-}

18+{-# LANGUAGE TemplateHaskell #-}

18{-# LANGUAGE GADTs #-}

19{-# LANGUAGE GADTs #-}

19

20

20module Language.PureScript.Names where

21module Language.PureScript.Names where

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

22import Data.List

23import Data.List

23import Data.Data

24import Data.Data

24import Data.List.Split (splitOn)

25import Data.List.Split (splitOn)

26+import Data.Aeson.TH

25import qualified Data.Aeson as A

27import qualified Data.Aeson as A

26import qualified Data.Text as T

28import qualified Data.Text as T

27

29

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

54-- |

56-- |

55-- Module names

57-- Module names

56--

58--

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

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

58

60

59runModuleName :: ModuleName -> String

61runModuleName :: ModuleName -> String

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

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

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

89 where

91 where

90 reconstructModuleName = moduleNameFromString . intercalate "." . reverse

92 reconstructModuleName = moduleNameFromString . intercalate "." . reverse

91

93

92−

93-- |

94-- |

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

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

95--

96--

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

109isUnqualified :: Qualified a -> Bool

110isUnqualified :: Qualified a -> Bool

110isUnqualified (Qualified Nothing _) = True

111isUnqualified (Qualified Nothing _) = True

111isUnqualified _ = False

112isUnqualified _ = 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

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

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

117 <*> (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)

128 <|> (do ident <- parseIdent

118 <|> (do ident <- parseIdent

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

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

130 -- TODO: remove this deprecation warning in 0.8

120 -- TODO: remove this deprecation warning in 0.8

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

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

29

30import Language.PureScript.AST

31import Language.PureScript.Errors

32+import Language.PureScript.Externs

32

33

33import Language.PureScript.Sugar.BindingGroups as S

34import Language.PureScript.Sugar.BindingGroups as S

34import Language.PureScript.Sugar.CaseDeclarations as S

35import Language.PureScript.Sugar.CaseDeclarations as S

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

63--

64--

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

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

65--

66--

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

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

68+desugar externs =

67−desugar = map removeSignedLiterals

69+ map removeSignedLiterals

68− >>> mapM desugarObjectConstructors

70+ >>> mapM desugarObjectConstructors

69− >=> mapM desugarOperatorSections

71+ >=> mapM desugarOperatorSections

70− >=> mapM desugarDoModule

72+ >=> mapM desugarDoModule

71− >=> desugarCasesModule

73+ >=> desugarCasesModule

72− >=> desugarTypeDeclarationsModule

74+ >=> desugarTypeDeclarationsModule

73− >=> desugarImports

75+ >=> desugarImports externs

74− >=> rebracket

76+ >=> rebracket externs

75− >=> mapM deriveInstances

77+ >=> mapM deriveInstances

76− >=> desugarTypeClasses

78+ >=> desugarTypeClasses externs

77− >=> createBindingGroupsModule

79+ >=> createBindingGroupsModule

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

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

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

79 return $ filter isImportDecl ds ++

80 filter isExternDataDecl ds ++

81− filter isExternInstanceDecl ds ++

82 dataBindingGroupDecls ++

81 dataBindingGroupDecls ++

83 filter isTypeClassDeclaration ds ++

82 filter isTypeClassDeclaration ds ++

84 filter isTypeClassInstanceDeclaration ds ++

83 filter isTypeClassInstanceDeclaration ds ++

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

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

13

14{-# LANGUAGE CPP #-}

15{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE RecordWildCards #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

17

18

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

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

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

34import Language.PureScript.Types

35import Language.PureScript.Types

35import Language.PureScript.Errors

36import Language.PureScript.Errors

36import Language.PureScript.Traversals

37import Language.PureScript.Traversals

38+import Language.PureScript.Externs

37import Language.PureScript.Sugar.Names.Env

39import Language.PureScript.Sugar.Names.Env

38import Language.PureScript.Sugar.Names.Imports

40import Language.PureScript.Sugar.Names.Imports

39import Language.PureScript.Sugar.Names.Exports

41import Language.PureScript.Sugar.Names.Exports

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

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

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

43-- modules should be topologically sorted beforehand.

45-- modules should be topologically sorted beforehand.

44--

46--

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

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

46−desugarImports modules = do

48+desugarImports externs modules = do

49+ env <- foldM externsEnv primEnv externs

47− env <- foldM updateEnv initEnv modules

50+ env' <- foldM updateEnv env modules

48− mapM (renameInModule' env) modules

51+ mapM (renameInModule' env') modules

49 where

52 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+

50 updateEnv :: Env -> Module -> m Env

88 updateEnv :: Env -> Module -> m Env

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

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

52 case mn `M.lookup` env of

90 case mn `M.lookup` env of

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

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

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

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

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

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

160 (,) (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)

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

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

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

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

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

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

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

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

12-----------------------------------------------------------------------------

13

14{-# LANGUAGE FlexibleContexts #-}

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

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

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

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

19

15

20module Language.PureScript.Sugar.Names.Env

16module Language.PureScript.Sugar.Names.Env

21 ( Imports(..)

17 ( Imports(..)

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

23 , Exports(..)

19 , Exports(..)

24 , nullExports

20 , nullExports

25 , Env

21 , Env

26− , initEnv

22+ , primEnv

27 , envModuleSourceSpan

23 , envModuleSourceSpan

28 , envModuleImports

24 , envModuleImports

29 , envModuleExports

25 , envModuleExports

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

32 , exportValue

28 , exportValue

33 ) where

29 ) where

34

30

31+import qualified Data.Map as M

32+

35import Control.Monad

33import Control.Monad

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

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

37

35

38−import qualified Data.Map as M

39−

40import Language.PureScript.AST

36import Language.PureScript.AST

41import Language.PureScript.Names

37import Language.PureScript.Names

42import Language.PureScript.Environment

38import Language.PureScript.Environment

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

136 where

132 where

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

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

138

134

139−-- |

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

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

136+primEnv :: Env

141−--

142−initEnv :: Env

143−initEnv = M.singleton

137+primEnv = M.singleton

144 (ModuleName [ProperName "Prim"])

138 (ModuleName [ProperName "Prim"])

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

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

146

140

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

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

16{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE TupleSections #-}

18

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

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

20+ ( resolveImports

21+ , resolveModuleImport

22+ ) where

20

23

21import Data.List (find)

24import Data.List (find)

22import Data.Maybe (fromMaybe, isNothing)

25import Data.Maybe (fromMaybe, isNothing)

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

59-- |

62-- |

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

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

61--

64--

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

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

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

64 censor (onErrorMessages (ErrorInModule currentModule)) $ do

67 censor (onErrorMessages (ErrorInModule currentModule)) $ do

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

68 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

67 where

78 where

68−

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

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

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

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

71 where

84 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

85+ positioned err = case pos of

79− Nothing -> err

86+ Nothing -> err

80− Just pos' -> rethrowWithPosition pos' err

87+ Just pos' -> rethrowWithPosition pos' err

81

88

82-- |

89-- |

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

90-- 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 @@

20{-# LANGUAGE Rank2Types #-}

21{-# LANGUAGE FlexibleContexts #-}

22{-# LANGUAGE ScopedTypeVariables #-}

23+{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE CPP #-}

24{-# LANGUAGE CPP #-}

24

25

25module Language.PureScript.Sugar.Operators (

26module Language.PureScript.Sugar.Operators (

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

31import Language.PureScript.AST

32import Language.PureScript.AST

32import Language.PureScript.Errors

33import Language.PureScript.Errors

33import Language.PureScript.Names

34import Language.PureScript.Names

35+import Language.PureScript.Externs

34

36

35#if __GLASGOW_HASKELL__ < 710

37#if __GLASGOW_HASKELL__ < 710

36import Control.Applicative

38import Control.Applicative

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

52-- |

54-- |

53-- Remove explicit parentheses and reorder binary operator applications

55-- Remove explicit parentheses and reorder binary operator applications

54--

56--

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

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

56−rebracket ms = do

58+rebracket externs ms = do

57− let fixities = concatMap collectFixities ms

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

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

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

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

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

60 mapM (rebracketModule opTable) ms

62 mapM (rebracketModule opTable) ms

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

80 go (Parens val) = val

82 go (Parens val) = val

81 go val = val

83 go val = val

82

84

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+

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

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

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

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

85 where

93 where

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

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

15-----------------------------------------------------------------------------

16

17{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE RecordWildCards #-}

18{-# LANGUAGE CPP #-}

19{-# LANGUAGE CPP #-}

19

20

20module Language.PureScript.Sugar.TypeClasses

21module Language.PureScript.Sugar.TypeClasses

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

28import Language.PureScript.Errors

29import Language.PureScript.Errors

29import Language.PureScript.Kinds

30import Language.PureScript.Kinds

30import Language.PureScript.Names

31import Language.PureScript.Names

32+import Language.PureScript.Externs

31import Language.PureScript.Sugar.CaseDeclarations

33import Language.PureScript.Sugar.CaseDeclarations

32import Control.Monad.Supply.Class

34import Control.Monad.Supply.Class

33import Language.PureScript.Types

35import Language.PureScript.Types

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

45

47

46import qualified Data.Map as M

48import qualified Data.Map as M

47

49

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

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

49

51

50type Desugar = StateT MemberMap

52type Desugar = StateT MemberMap

51

53

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

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

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

54-- instance dictionary expressions.

56-- instance dictionary expressions.

55--

57--

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

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

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

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

58

67

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

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

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

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

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

166desugarDecl mn exps = go

175desugarDecl mn exps = go

167 where

176 where

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

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

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

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

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

179 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])

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

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

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

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

174 desugared <- desugarCases members

182 desugared <- desugarCases members

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

239 m <- get

247 m <- get

240

248

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

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

242− (TypeClassDeclaration _ args implies tyDecls) <-

250+ (args, implies, tyDecls) <-

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

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

244 M.lookup (qualify mn className) m

252 M.lookup (qualify mn className) m

245

253

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

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

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

213 return d

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

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

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

216− instances <- lookupTypeClassDictionaries $ Just importedModule

217− addTypeClassDictionaries (Just moduleName) instances

218− return d

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

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

220 addTypeClass moduleName pn args implies tys

217 addTypeClass moduleName pn args implies tys

221 return d

218 return d

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

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

223 goInstance d dictName deps className tys

220 goInstance d dictName deps className tys

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

225− goInstance d dictName deps className tys

226 go (PositionedDeclaration pos com d) =

221 go (PositionedDeclaration pos com d) =

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

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

228

223

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

239 mapM_ (checkTypeClassInstance moduleName) tys

234 mapM_ (checkTypeClassInstance moduleName) tys

240 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

235 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

241 checkOrphanInstance moduleName className tys

236 checkOrphanInstance moduleName className tys

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

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

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

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

244 return d

239 return d

245

240

246 where

241 where

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

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

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

296 exports (ValueRef id1) (ValueRef id2) = id1 == id2

291 exports (ValueRef id1) (ValueRef id2) = id1 == id2

297 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2

292 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2

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

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

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

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

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

301 exports _ _ = False

295 exports _ _ = False

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

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

22

23import Data.Function (on)

24import Data.List

25−import Data.Maybe (maybeToList)

25+import Data.Maybe (maybeToList, mapMaybe)

26#if __GLASGOW_HASKELL__ < 710

27import Data.Foldable (foldMap)

28#endif

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

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

55entails env moduleName context = solve

56 where

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

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

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

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

59

66

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

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

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

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

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

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

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

70 go work className' tys' = do

77 go work className' tys' = do

71 let instances = do

78 let instances = do

72− tcd <- forClassName className'

79+ tcd <- forClassName className' tys'

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

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

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

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

75 return (subst, tcd)

82 return (subst, tcd)

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

77 -- Solve any necessary subgoals

84 -- Solve any necessary subgoals

78 args <- solveSubgoals subst (tcdDependencies tcd)

85 args <- solveSubgoals subst (tcdDependencies tcd)

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

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

80− (mkDictionary (canonicalizeDictionary tcd) args)

87+ (mkDictionary (tcdName tcd) args)

81 (tcdPath tcd)

88 (tcdPath tcd)

82 where

89 where

83

90

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

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

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

77withTypeClassDictionaries entries action = do

78 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 ]

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

81 a <- action

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

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

276 let uust = unifyCurrentSubstitution ust

277 tell $ onErrorMessages (replace uust) w

278 return (a, uust)

279−

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

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

469 name

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

471 ) superclasses [0..]

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

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

473

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

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

src/Language/PureScript/TypeClassDictionaries.hs−22

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

36 , tcdInstanceTypes :: [Type]

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

38 , tcdDependencies :: Maybe [Constraint]

39− -- | The type of this dictionary

40− , tcdType :: TypeClassDictionaryType

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

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

42

40

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−

56-- |

41-- |

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

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

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

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

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

75 --

60 --

76 | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

61 | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

77 deriving (Show, Read, Ord, Eq)

62 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