7d1bbfe · rowtype-yoga/purescript-native

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

Write some syb traversals by hand #367

commit7d1bbfeafcdf9053b1c77aad7c9eae148b5ef9c9 authorPhil Freeman <paf31@cantab.net> dateMon 14 Apr 2014, 19:28 (13 years ago) parent5b97210

5 files changed+96−29

compare with golang

unifiedsplit

src/Language/PureScript.hs+1−2 src/Language/PureScript/Pretty/Types.hs+1−2 src/Language/PureScript/TypeChecker/Synonyms.hs+3−7 src/Language/PureScript/TypeChecker/Types.hs+14−16 src/Language/PureScript/Types.hs+77−2

src/Language/PureScript.hs+1−2

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

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

3737import Data.Time.Clock

3838import Data.Function (on)

39−import Data.Generics (mkQ, everything)

4039import Data.Maybe (fromJust, fromMaybe)

4140import Control.Monad.Error

4241import Control.Monad.State.Lazy

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

109108

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

111110 findTcons :: Type -> [ProperName]

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

111+ findTcons = everythingOnTypes (++) go

113112 where

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

115114 go _ = []

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

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

2121

2222import Data.Maybe (fromMaybe)

2323import Data.List (intercalate)

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

2524

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

2726import Control.PatternArrows

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

7473 match _ = Nothing

7574

7675insertPlaceholders :: Type -> Type

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

76+insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert

7877 where

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

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

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

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

1414-----------------------------------------------------------------------------

1515

1616module Language.PureScript.TypeChecker.Synonyms (

17− saturateTypeSynonym,

1817 saturateAllTypeSynonyms

1918) where

2019

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

2322

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

2524import Data.Maybe (fromMaybe)

26−import Data.Data

27−import Data.Generics

28−import Data.Generics.Extras

2925import Control.Monad.Writer

3026import Control.Monad.Error

3127

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

4440-- |

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

4642--

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

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

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

44+saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

4945 where

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

5147

5248-- |

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

5450--

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

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

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

5753

5854

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

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

4343

4444import Data.List

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

46−import qualified Data.Data as D

4746import Data.Generics

48− (everythingWithContext, mkM, everywhereM,

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

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

5048import Data.Generics.Extras

5149

5250import Language.PureScript.Declarations

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

373371 return $ map head grps

374372 -- Apply a substitution to a type

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

376− applySubst subst = everywhereM (mkM replace)

374+ applySubst subst = everywhereOnTypesM replace

377375 where

378376 replace (TypeVar v) = lookup v subst

379377 replace other = Just other

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

463461 _ -> ([], scos)

464462 where

465463 collectSkolems :: Type -> [SkolemScope]

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

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

467465 where

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

469467 collect _ = []

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

484482-- |

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

486484--

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

488−setifyAll = everywhere (mkT setify)

485+setifyAll :: Type -> Type

486+setifyAll = everywhereOnTypes setify

489487

490488-- |

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

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

494492varIfUnknown ty =

495493 let unks = nub $ unknowns ty

496494 toName = (:) 't' . show

497− ty' = everywhere (mkT typeToVar) ty

495+ ty' = everywhereOnTypes typeToVar ty

498496 typeToVar :: Type -> Type

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

500498 typeToVar t = t

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

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

530528-- better error messages during unification.

531529--

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

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

533531replaceAllTypeSynonyms' env d =

534532 let

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

536534 in

537535 saturateAllTypeSynonyms syns d

538536

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

540538replaceAllTypeSynonyms d = do

541539 env <- getEnv

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

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

544542-- |

545543-- \"Desaturate\" @SaturatedTypeSynonym@s

546544--

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

548−desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

545+desaturateAllTypeSynonyms :: Type -> Type

546+desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym

549547 where

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

551549 replaceSaturatedTypeSynonym t = t

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

566564 env <- getEnv

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

568566

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

570−expandAllTypeSynonyms = everywhereM' (mkM go)

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

568+expandAllTypeSynonyms = everywhereOnTypesTopDownM go

571569 where

572570 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

573571 go other = return other

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

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

823821--

824822introduceSkolemScope :: Type -> UnifyT Type Check Type

825−introduceSkolemScope = everywhereM (mkM go)

823+introduceSkolemScope = everywhereOnTypesM go

826824 where

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

828826 go other = return other

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

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

965963

966964containsTypeSynonyms :: Type -> Bool

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

965+containsTypeSynonyms = everythingOnTypes (||) go where

968966 go (SaturatedTypeSynonym _ _) = True

969967 go _ = False

970968

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

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

1919

2020import Data.Data

2121import Data.List (nub)

22−import Data.Generics (everything, mkQ)

2322

2423import Control.Monad.Unify

2524import Control.Arrow (second)

25+import Control.Applicative

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

2627

2728import Language.PureScript.Names

2829

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

157158-- Collect all type variables appearing in a type

158159--

159160usedTypeVariables :: Type -> [String]

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

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

161162 where

162163 go (TypeVar v) = [v]

163164 go _ = []

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

199200 [] -> constrained

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

201202

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

202234

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

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

203237

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