059bd9b · rowtype-yoga/purescript-native

src/Language/PureScript/CodeGen/JS.hs+2−6

compare with golang

unifiedsplit

@@ -189,14 +189,10 @@ varToJs m e qual@(Qualified _ ident) = go qual

189 where

190 go qual' = case M.lookup (qualify m qual') (names e) of

191 Just (_, ty) | isExtern ty -> var ident

192− Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)

193 _ -> case qual' of

192 _ -> case qual' of

194 Qualified Nothing _ -> var ident

193 Qualified Nothing _ -> var ident

195 _ -> qualifiedToJS m id qual'

194 _ -> qualifiedToJS m id qual'

196 isExtern (Extern ForeignImport) = True

195 isExtern (Extern ForeignImport) = True

197− isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

198− Just (_, ty') -> isExtern ty'

199− Nothing -> error "Undefined alias in varToJs"

200 isExtern _ = False

196 isExtern _ = False

201

197

202-- |

198-- |

@@ -211,10 +207,10 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

211-- Generate code in the simplified Javascript intermediate representation for pattern match binders

207-- Generate code in the simplified Javascript intermediate representation for pattern match binders

212-- and guards.

208-- and guards.

213--

209--

214−bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS

210+bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS

215bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do

211bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do

216 valNames <- replicateM (length vals) fresh

212 valNames <- replicateM (length vals) fresh

217− jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd

213+ jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd

218 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

214 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

219 vals

215 vals

220 where

216 where

src/Language/PureScript/DeadCodeElimination.hs+5−5

@@ -43,18 +43,18 @@ declarationsByModule :: Environment -> Module -> [(Key, [Key])]

43declarationsByModule env (Module moduleName ds) = concatMap go ds

44 where

45 go :: Declaration -> [(Key, [Key])]

46− go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env moduleName d)]

46+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

47 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

48 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

49− go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names'

49+ go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

50 go (DataBindingGroupDeclaration ds') = concatMap go ds'

51 go _ = []

52

53−dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]

53+dependencies :: (Data d) => ModuleName -> d -> [Key]

54−dependencies env moduleName = nub . everything (++) (mkQ [] values)

54+dependencies moduleName = nub . everything (++) (mkQ [] values)

55 where

56 values :: Value -> [Key]

57− values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]

57+ values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]

58 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]

59 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"

60 values _ = []

src/Language/PureScript/Parser/Values.hs+5−5

@@ -74,11 +74,11 @@ parseCase :: P.Parsec String ParseState Value

74parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

75 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

76

77−parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)

77+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

78−parseCaseAlternative = (,,) <$> (return <$> parseBinder)

78+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

79− <*> P.optionMaybe parseGuard

79+ <*> P.optionMaybe parseGuard

80− <*> (C.indented *> C.reservedOp "->" *> parseValue)

80+ <*> (C.indented *> C.reservedOp "->" *> parseValue)

81− P.<?> "case alternative"

81+ P.<?> "case alternative"

82

83parseIfThenElse :: P.Parsec String ParseState Value

84parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

src/Language/PureScript/Pretty/Values.hs+3−2

@@ -45,8 +45,9 @@ literals = mkPattern match

45 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

46 match _ = Nothing

47

48−prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

48+prettyPrintCaseAlternative :: CaseAlternative -> String

49+prettyPrintCaseAlternative (CaseAlternative binders grd val) =

49−prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

50+ "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

50 maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val

51 maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val

51

52

52ifThenElse :: Pattern () Value ((Value, Value), Value)

53ifThenElse :: Pattern () Value ((Value, Value), Value)

src/Language/PureScript/Sugar/CaseDeclarations.hs+2−2

@@ -44,7 +44,7 @@ desugarAbs = everywhere (mkT replace)

44 let

45 ident = head $ unusedNames (binder, val)

46 in

47− Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [([binder], Nothing, val)]

47+ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]

48 replace other = other

49

50-- |

@@ -76,7 +76,7 @@ makeCaseDeclaration ident alternatives =

76 argPattern = length . fst . head $ alternatives

77 args = take argPattern $ unusedNames (ident, alternatives)

78 vars = map (Var . Qualified Nothing) args

79− binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]

79+ binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

80 value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args

81 in

82 ValueDeclaration ident [] Nothing value

src/Language/PureScript/Sugar/DoNotation.hs+2−2

@@ -55,8 +55,8 @@ desugarDo = everywhereM (mkM replace)

55 go (DoNotationBind binder val : rest) = do

56 rest' <- go rest

57 let ident = head $ unusedNames rest'

58− return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))

58+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))

59 go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

60 go (DoNotationLet binder val : rest) = do

61 rest' <- go rest

62− return $ Case [val] [([binder], Nothing, rest')]

62+ return $ Case [val] [CaseAlternative [binder] Nothing rest']

src/Language/PureScript/Sugar/Let.hs+1−1

@@ -28,5 +28,5 @@ import Language.PureScript.Declarations

28desugarLetBindings :: [Module] -> [Module]

29desugarLetBindings = everywhere (mkT go)

30 where

31− go (Let binder value result) = Case [value] [([binder], Nothing, result)]

31+ go (Let binder value result) = Case [value] [CaseAlternative [binder] Nothing result]

32 go other = other

src/Language/PureScript/Sugar/Names.hs+11−10

@@ -147,19 +147,20 @@ renameInModule imports (Module mn decls) =

147 Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

148 where

149 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) =

150− TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

150+ TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> updateVars ds

151 updateDecl (ValueDeclaration name bs grd val) =

152 ValueDeclaration name <$> updateVars bs <*> updateVars grd <*> updateVars val

153− where

154− updateVars :: (Data d) => d -> Either String d

155− updateVars = everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders)

156− where

157− bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)

158− bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)

159− bindFunctionArgs bound other = return (bound, other)

160− bindBinders :: [Ident] -> ([Binder], Maybe Guard, Value) -> Either String ([Ident], ([Binder], Maybe Guard, Value))

161− bindBinders bound (bs, grd, val) = return (binderNames bs ++ bound, (bs, grd, val))

162 updateDecl d = return d

153 updateDecl d = return d

154+

155+ updateVars :: (Data d) => d -> Either String d

156+ updateVars = everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders)

157+ where

158+ bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)

159+ bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)

160+ bindFunctionArgs bound other = return (bound, other)

161+ bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

162+ bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

163+

163 updateValue (Constructor (Qualified Nothing nm)) =

164 updateValue (Constructor (Qualified Nothing nm)) =

164 Constructor <$> updateDataConstructorName nm

165 Constructor <$> updateDataConstructorName nm

165 updateValue v = return v

166 updateValue v = return v

src/Language/PureScript/TypeChecker/Monad.hs−13

@@ -49,10 +49,6 @@ data NameKind

49 --

50 | Extern ForeignImportType

51 -- |

52− -- An alias for a value in another module, introduced using an import declaration

53− --

54− | Alias ModuleName Ident

55− -- |

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

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

57 --

53 --

58 | LocalVariable

54 | LocalVariable

@@ -176,15 +172,6 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

176 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

172 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

177 Just k -> return k

173 Just k -> return k

178

174

179−-- |

180−-- Canonicalize an identifier by resolving any aliases introduced by module imports

181−--

182−canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)

183−canonicalize _ _ (Qualified (Just mn) i) = (mn, i)

184−canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

185− Just (_, Alias mn' i') -> (mn', i')

186− _ -> (mn, i)

187−

188-- |

175-- |

189-- State required for type checking:

176-- State required for type checking:

190--

177--

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

@@ -632,18 +632,18 @@ inferBinder val (NamedBinder name binder) = do

632-- |

633-- Check the types of the return values in a set of binders in a case statement

634--

635−checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> UnifyT Type Check [([Binder], Maybe Guard, Value)]

635+checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]

636checkBinders _ _ [] = return []

637−checkBinders nvals ret ((binders, grd, val):bs) = do

637+checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

638 Just moduleName <- checkCurrentModule <$> get

639 m1 <- M.unions <$> zipWithM inferBinder nvals binders

640 r <- bindLocalVariables moduleName (M.toList m1) $ do

641 val' <- TypedValue True <$> check val ret <*> pure ret

642 case grd of

643− Nothing -> return (binders, Nothing, val')

643+ Nothing -> return $ CaseAlternative binders Nothing val'

644 Just g -> do

645 g' <- check g tyBoolean

646− return (binders, Just g', val')

646+ return $ CaseAlternative binders (Just g') val'

647 rs <- checkBinders nvals ret bs

648 return $ r : rs

649

src/Language/PureScript/Values.hs+19−1

@@ -94,7 +94,7 @@ data Value

94 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

95 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

96 --

97− | Case [Value] [([Binder], Maybe Guard, Value)]

97+ | Case [Value] [CaseAlternative]

98 -- |

99 -- A value with a type annotation

100 --

@@ -115,6 +115,24 @@ data Value

115 --

116 | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

117

118+-- |

119+-- An alternative in a case statement

120+--

121+data CaseAlternative = CaseAlternative

122+ { -- |

123+ -- A collection of binders with which to match the inputs

124+ --

125+ caseAlternativeBinders :: [Binder]

126+ -- |

127+ -- An optional guard

128+ --

129+ , caseAlternativeGuard :: Maybe Guard

130+ -- |

131+ -- The result expression

132+ --

133+ , caseAlternativeResult :: Value

134+ } deriving (Show, Data, Typeable)

135+

118-- |

136-- |

119-- Data representing a type class dictionary which is in scope

137-- Data representing a type class dictionary which is in scope

120--

138--