059bd9b · rowtype-yoga/purescript-native

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

Move case alternative out into its own type. Remove canonicalize code.

commit059bd9b410a7d260547d0de2ef765881eb3d7d84 authorPhil Freeman <paf31@cantab.net> dateTue 4 Mar 2014, 13:53 (13 years ago) parentdc14d2d

11 files changed+54−51

compare with golang

unifiedsplit

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

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

189189 where

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

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

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

193192 _ -> case qual' of

194193 Qualified Nothing _ -> var ident

195194 _ -> qualifiedToJS m id qual'

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

200196 isExtern _ = False

201197

202198-- |

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

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

212208-- and guards.

213209--

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

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

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

216212 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

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

219215 vals

220216 where

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

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

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

4444 where

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

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

4848 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'

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

5151 go _ = []

5252

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

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

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

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

5555 where

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

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

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

6060 values _ = []

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

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

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

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

7676

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

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

79− <*> P.optionMaybe parseGuard

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

81− P.<?> "case alternative"

77+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

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

79+ <*> P.optionMaybe parseGuard

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

81+ P.<?> "case alternative"

8282

8383parseIfThenElse :: P.Parsec String ParseState Value

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

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

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

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

4646 match _ = Nothing

4747

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

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

48+prettyPrintCaseAlternative :: CaseAlternative -> String

49+prettyPrintCaseAlternative (CaseAlternative binders grd val) =

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

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

5152

5253ifThenElse :: Pattern () Value ((Value, Value), Value)

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

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

4444 let

4545 ident = head $ unusedNames (binder, val)

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

4848 replace other = other

4949

5050-- |

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

7676 argPattern = length . fst . head $ alternatives

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

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

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

8181 in

8282 ValueDeclaration ident [] Nothing value

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

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

5555 go (DoNotationBind binder val : rest) = do

5656 rest' <- go rest

5757 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']))

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

6060 go (DoNotationLet binder val : rest) = do

6161 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

2828desugarLetBindings :: [Module] -> [Module]

2929desugarLetBindings = everywhere (mkT go)

3030 where

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

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

3232 go other = other

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

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

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

148148 where

149149 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

151151 updateDecl (ValueDeclaration name bs grd val) =

152152 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))

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

163164 updateValue (Constructor (Qualified Nothing nm)) =

164165 Constructor <$> updateDataConstructorName nm

165166 updateValue v = return v

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

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

4949 --

5050 | Extern ForeignImportType

5151 -- |

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

53− --

54− | Alias ModuleName Ident

55− -- |

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

5753 --

5854 | LocalVariable

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

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

177173 Just k -> return k

178174

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−

188175-- |

189176-- State required for type checking:

190177--

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

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

632632-- |

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

634634--

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

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

636636checkBinders _ _ [] = return []

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

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

638638 Just moduleName <- checkCurrentModule <$> get

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

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

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

642642 case grd of

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

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

644644 Just g -> do

645645 g' <- check g tyBoolean

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

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

647647 rs <- checkBinders nvals ret bs

648648 return $ r : rs

649649

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

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

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

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

9696 --

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

97+ | Case [Value] [CaseAlternative]

9898 -- |

9999 -- A value with a type annotation

100100 --

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

115115 --

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

117117

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+

118136-- |

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

120138--