9e32d43 · rowtype-yoga/purescript-native

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

Fix #886

commit9e32d4335c758511bf92f2351984a12442497aa8 authorPhil Freeman <paf31@cantab.net> dateSun 22 Feb 2015, 11:58 (12 years ago) parentf4375ae

4 files changed+27−4

compare with golang

unifiedsplit

examples/passing/InstanceBeforeClass.purs+9 src/Language/PureScript/AST/Declarations.hs+9−2 src/Language/PureScript/Sugar/BindingGroups.hs+1 src/Language/PureScript/Sugar/TypeClasses.hs+8−2

examples/passing/InstanceBeforeClass.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+instance fooNumber :: Foo Number where

4+ foo = 0

6+class Foo a where

7+ foo :: a

9+main = Debug.Trace.trace "Done"

src/Language/PureScript/AST/Declarations.hs+9−2

@@ -261,11 +261,18 @@ isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d

261261isExternDecl _ = False

262262

263263-- |

264−-- Test if a declaration is a type class or instance declaration

264+-- Test if a declaration is a type class instance declaration

265+--

266+isTypeClassInstanceDeclaration :: Declaration -> Bool

267+isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True

268+isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d

269+isTypeClassInstanceDeclaration _ = False

270+

271+-- |

272+-- Test if a declaration is a type class declaration

265273--

266274isTypeClassDeclaration :: Declaration -> Bool

267275isTypeClassDeclaration TypeClassDeclaration{} = True

268−isTypeClassDeclaration TypeInstanceDeclaration{} = True

269276isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d

270277isTypeClassDeclaration _ = False

271278

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

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

7878 filter isExternInstanceDecl ds ++

7979 dataBindingGroupDecls ++

8080 filter isTypeClassDeclaration ds ++

81+ filter isTypeClassInstanceDeclaration ds ++

8182 filter isFixityDecl ds ++

8283 filter isExternDecl ds ++

8384 bindingGroupDecls

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

@@ -38,7 +38,7 @@ import Control.Applicative

3838import Control.Arrow (first, second)

3939import Control.Monad.Except

4040import Control.Monad.State

41−import Data.List ((\\), find)

41+import Data.List ((\\), find, sortBy)

4242import Data.Maybe (catMaybes, mapMaybe, isJust)

4343

4444import qualified Data.Map as M

@@ -56,8 +56,14 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

5656

5757desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> Desugar m Module

5858desugarModule (Module coms name decls (Just exps)) = do

59− (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)

59+ (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

6060 return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

61+ where

62+ classesFirst :: Declaration -> Declaration -> Ordering

63+ classesFirst d1 d2

64+ | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT

65+ | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT

66+ | otherwise = EQ

6167desugarModule _ = error "Exports should have been elaborated in name desugaring"

6268

6369{- Desugar type class and type class instance declarations