e3cc156 · rowtype-yoga/purescript-native

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

Use a sum type instead of Maybe for instance bodies

commite3cc15683c19519aa9cfee4ac7ddd68567f80f1f authorPhil Freeman <paf31@cantab.net> dateThu 13 Aug 2015, 10:48 (11 years ago) parent1db4a4f

6 files changed+35−15

compare with golang

unifiedsplit

src/Language/PureScript/AST/Declarations.hs+21−1 src/Language/PureScript/AST/Traversals.hs+6−6 src/Language/PureScript/Parser/Declarations.hs+2−2 src/Language/PureScript/Sugar/CaseDeclarations.hs+1−1 src/Language/PureScript/Sugar/TypeClasses.hs+2−2 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+3−3

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

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

1919import qualified Data.Data as D

2020import qualified Data.Map as M

2121

22+import Control.Monad.Identity

23+

24+import Control.Applicative

25+

2226import Language.PureScript.AST.Binders

2327import Language.PureScript.AST.Operators

2428import Language.PureScript.AST.SourcePos

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

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

155159 -- declarations)

156160 --

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

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

158162 -- |

159163 -- A declaration with source position information

160164 --

161165 | PositionedDeclaration SourceSpan [Comment] Declaration

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

163167

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+

164184-- |

165185-- Test if a declaration is a value declaration

166186--

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

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

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

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

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

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

4343 f' other = f other

4444

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

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

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

9898 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

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

101101 f' other = f other

102102

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

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

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

150150 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

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

153153 f' other = f other

154154

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

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

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

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

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

208208 f' d = f d

209209

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

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

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

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

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

272272 f' _ _ = r0

273273

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

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

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

338338 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

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

341341 f' _ other = return other

342342

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

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

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

230230 indented *> reserved "where"

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

233233

234234parseDerivingInstanceDeclaration :: TokenParser Declaration

235235parseDerivingInstanceDeclaration = do

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

243243 return deps

244244 className <- indented *> parseQualified properName

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

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

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

247247

248248positioned :: TokenParser Declaration -> TokenParser Declaration

249249positioned = withSourceSpan PositionedDeclaration

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

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

6969 where

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

7171 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

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

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

7575 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

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

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

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

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

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

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

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

171171 desugared <- desugarCases members

172172 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

173173 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

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

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

4949deriveInstance :: (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)

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

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

5353 , mn == fromMaybe mn mn'

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

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

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

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

5656 = throwError . errorMessage $ CannotDerive className tys

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

5858deriveInstance _ _ e = return e