e3cc156 · rowtype-yoga/purescript-native

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

on golang help sign in

Use a sum type instead of Maybe for instance bodies

e3cc156Phil Freeman11 years ago

src/Language/PureScript/AST/Declarations.hs+21−1

compare with golang

unifiedsplit

@@ -19,6 +19,10 @@ module Language.PureScript.AST.Declarations where

19import qualified Data.Data as D

20import qualified Data.Map as M

22+import Control.Monad.Identity

23+

24+import Control.Applicative

25+

22import Language.PureScript.AST.Binders

26import Language.PureScript.AST.Binders

23import Language.PureScript.AST.Operators

27import Language.PureScript.AST.Operators

24import Language.PureScript.AST.SourcePos

28import Language.PureScript.AST.SourcePos

@@ -154,13 +158,29 @@ data Declaration

154 -- A type instance declaration (name, dependencies, class name, instance types, member

158 -- A type instance declaration (name, dependencies, class name, instance types, member

155 -- declarations)

159 -- declarations)

156 --

160 --

157− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] (Maybe [Declaration])

161+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody

158 -- |

162 -- |

159 -- A declaration with source position information

163 -- A declaration with source position information

160 --

164 --

161 | PositionedDeclaration SourceSpan [Comment] Declaration

165 | PositionedDeclaration SourceSpan [Comment] Declaration

162 deriving (Show, D.Data, D.Typeable)

166 deriving (Show, D.Data, D.Typeable)

163

167

168+-- | The members of a type class instance declaration

169+data TypeInstanceBody

170+ -- | This is a derived instance

171+ = DerivedInstance

172+ -- | This is a regular (explicit) instance

173+ | ExplicitInstance [Declaration]

174+ deriving (Show, D.Data, D.Typeable)

175+

176+mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

177+mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

178+

179+-- | A traversal for TypeInstanceBody

180+traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody

181+traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance

182+traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds

183+

164-- |

184-- |

165-- Test if a declaration is a value declaration

185-- Test if a declaration is a value declaration

166--

186--

src/Language/PureScript/AST/Traversals.hs+6−6

@@ -38,7 +38,7 @@ everywhereOnValues f g h = (f', g', h')

38 f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))

39 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))

40 f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

41− f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (fmap (map f') ds))

41+ f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))

42 f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))

43 f' other = f other

@@ -96,7 +96,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

96 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

97 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

98 f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds

99− f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverse (traverse (f' <=< f)) ds

99+ f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds

100 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

101 f' other = f other

102

@@ -148,7 +148,7 @@ everywhereOnValuesM f g h = (f', g', h')

148 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f

149 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

150 f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f

151− f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverse (mapM f') ds) >>= f

151+ f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM f') ds) >>= f

152 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

153 f' other = f other

154

@@ -203,7 +203,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

203 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

204 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

205 f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

206− f' d@(TypeInstanceDeclaration _ _ _ _ (Just ds)) = foldl (<>) (f d) (map f' ds)

206+ f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)

207 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

208 f' d = f d

209

@@ -267,7 +267,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

267 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

268 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)

269 f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

270− f' s (TypeInstanceDeclaration _ _ _ _ (Just ds)) = foldl (<>) r0 (map (f'' s) ds)

270+ f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)

271 f' s (PositionedDeclaration _ _ d1) = f'' s d1

272 f' _ _ = r0

273

@@ -336,7 +336,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

336 f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

337 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds

338 f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds

339− f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverse (mapM (f'' s)) ds

339+ f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM (f'' s)) ds

340 f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1

341 f' _ other = return other

342

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -229,7 +229,7 @@ parseTypeInstanceDeclaration = do

229 members <- P.option [] . P.try $ do

230 indented *> reserved "where"

231 mark (P.many (same *> positioned parseValueDeclaration))

232− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (Just members)

232+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)

233

234parseDerivingInstanceDeclaration :: TokenParser Declaration

235parseDerivingInstanceDeclaration = do

@@ -243,7 +243,7 @@ parseDerivingInstanceDeclaration = do

243 return deps

244 className <- indented *> parseQualified properName

245 ty <- P.many (indented *> noWildcards parseTypeAtom)

246− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty Nothing

246+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty DerivedInstance

247

248positioned :: TokenParser Declaration -> TokenParser Declaration

249positioned = withSourceSpan PositionedDeclaration

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

@@ -69,7 +69,7 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro

69 where

70 desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

71 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

72− (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverse desugarCases ds) <*> desugarRest rest

72+ (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest

73 desugarRest (ValueDeclaration name nameKind bs result : rest) =

74 let (_, f, _) = everywhereOnValuesTopDownM return go return

75 f' (Left gs) = Left <$> mapM (pairM return f) gs

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

@@ -166,8 +166,8 @@ desugarDecl mn exps = go

166 modify (M.insert (mn, name) d)

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

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

169− go (TypeInstanceDeclaration _ _ _ _ Nothing) = error "Derived instanced should have been desugared"

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

170− go d@(TypeInstanceDeclaration name deps className tys (Just members)) = do

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

171 desugared <- desugarCases members

172 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

173 return (expRef name className tys, [d, dictDecl])

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+3−3

@@ -47,12 +47,12 @@ deriveInstances (Module coms mn ds exts) = Module coms mn <$> mapM (deriveInstan

47-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

48-- elaborates that into an instance declaration via code generation.

49deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

50−deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Nothing)

50+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

51 | className == Qualified (Just dataGeneric) (ProperName C.generic)

52 , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty

53 , mn == fromMaybe mn mn'

54− = TypeInstanceDeclaration nm deps className tys . Just <$> deriveGeneric mn ds tyCon

54+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon

55−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys Nothing)

55+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

56 = throwError . errorMessage $ CannotDerive className tys

57deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

58deriveInstance _ _ e = return e