7d1bbfe · rowtype-yoga/purescript-native

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

on golang help sign in

Write some syb traversals by hand #367

7d1bbfePhil Freeman13 years ago

src/Language/PureScript.hs+1−2

compare with golang

unifiedsplit

@@ -36,7 +36,6 @@ import qualified Language.PureScript.Constants as C

36import Data.List (find, sortBy, groupBy, intercalate)

37import Data.Time.Clock

38import Data.Function (on)

39−import Data.Generics (mkQ, everything)

40import Data.Maybe (fromJust, fromMaybe)

39import Data.Maybe (fromJust, fromMaybe)

41import Control.Monad.Error

40import Control.Monad.Error

42import Control.Monad.State.Lazy

41import Control.Monad.State.Lazy

@@ -109,7 +108,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do

109

108

110 -- Find the type constructors exported from the current module used in a type

109 -- Find the type constructors exported from the current module used in a type

111 findTcons :: Type -> [ProperName]

110 findTcons :: Type -> [ProperName]

112− findTcons = everything (++) (mkQ [] go)

111+ findTcons = everythingOnTypes (++) go

113 where

112 where

114 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]

113 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]

115 go _ = []

114 go _ = []

src/Language/PureScript/Pretty/Types.hs+1−2

@@ -21,7 +21,6 @@ module Language.PureScript.Pretty.Types (

22import Data.Maybe (fromMaybe)

23import Data.List (intercalate)

24−import Data.Generics (mkT, everywhere, everywhere')

26import Control.Arrow ((<+>))

25import Control.Arrow ((<+>))

27import Control.PatternArrows

26import Control.PatternArrows

@@ -74,7 +73,7 @@ appliedFunction = mkPattern match

74 match _ = Nothing

73 match _ = Nothing

76insertPlaceholders :: Type -> Type

75insertPlaceholders :: Type -> Type

77−insertPlaceholders = everywhere' (mkT convertForAlls) . everywhere (mkT convert)

76+insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert

78 where

77 where

79 convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

78 convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

80 convert (TypeApp a el) | a == tyArray = PrettyPrintArray el

79 convert (TypeApp a el) | a == tyArray = PrettyPrintArray el

src/Language/PureScript/TypeChecker/Synonyms.hs+3−7

@@ -14,7 +14,6 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.TypeChecker.Synonyms (

17− saturateTypeSynonym,

18 saturateAllTypeSynonyms

17 saturateAllTypeSynonyms

19) where

18) where

@@ -23,9 +22,6 @@ import Language.PureScript.Names

24import Control.Applicative ((<$>))

23import Control.Applicative ((<$>))

25import Data.Maybe (fromMaybe)

24import Data.Maybe (fromMaybe)

26−import Data.Data

27−import Data.Generics

28−import Data.Generics.Extras

29import Control.Monad.Writer

25import Control.Monad.Writer

30import Control.Monad.Error

26import Control.Monad.Error

@@ -44,15 +40,15 @@ buildTypeSubstitution name n = go n []

44-- |

40-- |

45-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

41-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

46--

42--

47−saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d

43+saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type

48−saturateTypeSynonym name n = everywhereM' (mkM replace)

44+saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

49 where

45 where

50 replace t = fromMaybe t <$> buildTypeSubstitution name n t

46 replace t = fromMaybe t <$> buildTypeSubstitution name n t

52-- |

48-- |

53-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

49-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

54--

50--

55−saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d

51+saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type

56saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns

52saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns

src/Language/PureScript/TypeChecker/Types.hs+14−16

@@ -43,10 +43,8 @@ module Language.PureScript.TypeChecker.Types (

44import Data.List

45import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)

46−import qualified Data.Data as D

47import Data.Generics

46import Data.Generics

48− (everythingWithContext, mkM, everywhereM,

49− everything, mkT, something, everywhere, mkQ)

47+ (everythingWithContext, mkM, mkT, something, everywhere, mkQ)

50import Data.Generics.Extras

48import Data.Generics.Extras

52import Language.PureScript.Declarations

50import Language.PureScript.Declarations

@@ -373,7 +371,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

373 return $ map head grps

371 return $ map head grps

374 -- Apply a substitution to a type

372 -- Apply a substitution to a type

375 applySubst :: [(String, Type)] -> Type -> Maybe Type

373 applySubst :: [(String, Type)] -> Type -> Maybe Type

376− applySubst subst = everywhereM (mkM replace)

374+ applySubst subst = everywhereOnTypesM replace

377 where

375 where

378 replace (TypeVar v) = lookup v subst

376 replace (TypeVar v) = lookup v subst

379 replace other = Just other

377 replace other = Just other

@@ -463,7 +461,7 @@ skolemEscapeCheck root@TypedValue{} =

463 _ -> ([], scos)

461 _ -> ([], scos)

464 where

462 where

465 collectSkolems :: Type -> [SkolemScope]

463 collectSkolems :: Type -> [SkolemScope]

466− collectSkolems = nub . everything (++) (mkQ [] collect)

464+ collectSkolems = nub . everythingOnTypes (++) collect

467 where

465 where

468 collect (Skolem _ _ scope) = [scope]

466 collect (Skolem _ _ scope) = [scope]

469 collect _ = []

467 collect _ = []

@@ -484,8 +482,8 @@ setify = rowFromList . first (M.toList . M.fromList) . rowToList

484-- |

482-- |

485-- \"Setify\" all rows occuring inside a value

483-- \"Setify\" all rows occuring inside a value

486--

484--

487−setifyAll :: (D.Data d) => d -> d

485+setifyAll :: Type -> Type

488−setifyAll = everywhere (mkT setify)

486+setifyAll = everywhereOnTypes setify

489

487

490-- |

488-- |

491-- Replace outermost unsolved unification variables with named type variables

489-- Replace outermost unsolved unification variables with named type variables

@@ -494,7 +492,7 @@ varIfUnknown :: Type -> Type

494varIfUnknown ty =

492varIfUnknown ty =

495 let unks = nub $ unknowns ty

493 let unks = nub $ unknowns ty

496 toName = (:) 't' . show

494 toName = (:) 't' . show

497− ty' = everywhere (mkT typeToVar) ty

495+ ty' = everywhereOnTypes typeToVar ty

498 typeToVar :: Type -> Type

496 typeToVar :: Type -> Type

499 typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

497 typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

500 typeToVar t = t

498 typeToVar t = t

@@ -529,14 +527,14 @@ replaceVarWithUnknown ident ty = do

529-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

527-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

530-- better error messages during unification.

528-- better error messages during unification.

531--

529--

532−replaceAllTypeSynonyms' :: (D.Data d) => Environment -> d -> Either String d

530+replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type

533replaceAllTypeSynonyms' env d =

531replaceAllTypeSynonyms' env d =

534 let

532 let

535 syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

533 syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

536 in

534 in

537 saturateAllTypeSynonyms syns d

535 saturateAllTypeSynonyms syns d

538

536

539−replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => (D.Data d) => d -> m d

537+replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

540replaceAllTypeSynonyms d = do

538replaceAllTypeSynonyms d = do

541 env <- getEnv

539 env <- getEnv

542 either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

540 either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

@@ -544,8 +542,8 @@ replaceAllTypeSynonyms d = do

544-- |

542-- |

545-- \"Desaturate\" @SaturatedTypeSynonym@s

543-- \"Desaturate\" @SaturatedTypeSynonym@s

546--

544--

547−desaturateAllTypeSynonyms :: (D.Data d) => d -> d

545+desaturateAllTypeSynonyms :: Type -> Type

548−desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

546+desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym

549 where

547 where

550 replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

548 replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

551 replaceSaturatedTypeSynonym t = t

549 replaceSaturatedTypeSynonym t = t

@@ -566,8 +564,8 @@ expandTypeSynonym name args = do

566 env <- getEnv

564 env <- getEnv

567 either (throwError . strMsg) return $ expandTypeSynonym' env name args

565 either (throwError . strMsg) return $ expandTypeSynonym' env name args

568

566

569−expandAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

567+expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

570−expandAllTypeSynonyms = everywhereM' (mkM go)

568+expandAllTypeSynonyms = everywhereOnTypesTopDownM go

571 where

569 where

572 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

570 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

573 go other = return other

571 go other = return other

@@ -822,7 +820,7 @@ skolemizeTypesInValue ident sko scope = everywhere (mkT go)

822-- Introduce skolem scope at every occurence of a ForAll

820-- Introduce skolem scope at every occurence of a ForAll

823--

821--

824introduceSkolemScope :: Type -> UnifyT Type Check Type

822introduceSkolemScope :: Type -> UnifyT Type Check Type

825−introduceSkolemScope = everywhereM (mkM go)

823+introduceSkolemScope = everywhereOnTypesM go

826 where

824 where

827 go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)

825 go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)

828 go other = return other

826 go other = return other

@@ -964,7 +962,7 @@ check' (PositionedValue pos val) ty =

964check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

962check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

965

963

966containsTypeSynonyms :: Type -> Bool

964containsTypeSynonyms :: Type -> Bool

967−containsTypeSynonyms = everything (||) (mkQ False go) where

965+containsTypeSynonyms = everythingOnTypes (||) go where

968 go (SaturatedTypeSynonym _ _) = True

966 go (SaturatedTypeSynonym _ _) = True

969 go _ = False

967 go _ = False

970

968

src/Language/PureScript/Types.hs+77−2

@@ -19,10 +19,11 @@ module Language.PureScript.Types where

20import Data.Data

21import Data.List (nub)

22−import Data.Generics (everything, mkQ)

24import Control.Monad.Unify

23import Control.Monad.Unify

25import Control.Arrow (second)

24import Control.Arrow (second)

25+import Control.Applicative

26+import Control.Monad ((<=<))

27import Language.PureScript.Names

28import Language.PureScript.Names

@@ -157,7 +158,7 @@ replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id

157-- Collect all type variables appearing in a type

158-- Collect all type variables appearing in a type

158--

159--

159usedTypeVariables :: Type -> [String]

160usedTypeVariables :: Type -> [String]

160−usedTypeVariables = nub . everything (++) (mkQ [] go)

161+usedTypeVariables = nub . everythingOnTypes (++) go

161 where

162 where

162 go (TypeVar v) = [v]

163 go (TypeVar v) = [v]

163 go _ = []

164 go _ = []

@@ -199,5 +200,79 @@ moveQuantifiersToFront = go [] []

199 [] -> constrained

200 [] -> constrained

200 qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'

201 qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'

201

202

203+--

204+-- Traversals

205+--

206+

207+everywhereOnTypes :: (Type -> Type) -> Type -> Type

208+everywhereOnTypes f = go

209+ where

210+ go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))

211+ go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))

212+ go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)

213+ go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))

214+ go (RCons name ty rest) = f (RCons name (go ty) (go rest))

215+ go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

216+ go (PrettyPrintArray t) = f (PrettyPrintArray (go t))

217+ go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

218+ go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))

219+ go other = f other

220+

221+everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type

222+everywhereOnTypesTopDown f = go . f

223+ where

224+ go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))

225+ go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)

226+ go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco

227+ go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))

228+ go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))

229+ go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

230+ go (PrettyPrintArray t) = PrettyPrintArray (go (f t))

231+ go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

232+ go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

233+ go other = f other

202

234

235+sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)

236+sndM f (a, b) = (,) a <$> f b

203

237

238+everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

239+everywhereOnTypesM f = go

240+ where

241+ go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

242+ go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f

243+ go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f

244+ go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f

245+ go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f

246+ go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

247+ go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f

248+ go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f

249+ go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f

250+ go other = f other

251+

252+everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

253+everywhereOnTypesTopDownM f = go <=< f

254+ where

255+ go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)

256+ go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys

257+ go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco

258+ go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)

259+ go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)

260+ go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

261+ go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)

262+ go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)

263+ go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)

264+ go other = f other

265+

266+everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

267+everythingOnTypes (<>) f = go

268+ where

269+ go t@(TypeApp t1 t2) = f t <> go t1 <> go t2

270+ go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)

271+ go t@(ForAll _ ty _) = f t <> go ty

272+ go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty

273+ go t@(RCons _ ty rest) = f t <> go ty <> go rest

274+ go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

275+ go t@(PrettyPrintArray t1) = f t <> go t1

276+ go t@(PrettyPrintObject t1) = f t <> go t1

277+ go t@(PrettyPrintForAll _ t1) = f t <> go t1

278+ go other = f other