88fdcee · rowtype-yoga/purescript-native

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

Solving CompareSymbol and AppendSymbol (#2511)

* update test support * Solve CompareSymbol and AppendSymbol * Pass foreign support through on testing + fix solving tests

commit88fdceeefb01bd6a3ff28e9fc8919b50308d8924 authorLiam Goodacre <goodacre.liam@gmail.com> dateFri 30 Dec 2016, 01:25 (10 years ago) parent144dd6f

7 files changed+178−37

compare with golang

unifiedsplit

examples/passing/SolvingAppendSymbol.purs+32 examples/passing/SolvingCompareSymbol.purs+30 src/Language/PureScript/Constants.hs+35−4 src/Language/PureScript/TypeChecker/Entailment.hs+23−4 tests/TestCompiler.hs+22−17 tests/TestUtils.hs+25−2 tests/support/bower.json+11−10

examples/passing/SolvingAppendSymbol.pursnew file+32

@@ -0,0 +1,32 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff.Console (log)

5+import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol)

7+sym :: SProxy ""

8+sym = SProxy

10+symA :: SProxy "A"

11+symA = SProxy

12+

13+symB :: SProxy "B"

14+symB = SProxy

15+

16+egAB :: SProxy "AB"

17+egAB = appendSymbol symA symB

18+

19+egBA :: SProxy "BA"

20+egBA = appendSymbol symB symA

21+

22+egA' :: SProxy "A"

23+egA' = appendSymbol sym (appendSymbol symA sym)

24+

25+main = do

26+ let gotAB = reflectSymbol egAB == "AB"

27+ gotBA = reflectSymbol egBA == "BA"

28+ gotA' = reflectSymbol egA' == "A"

29+ when (not gotAB) $ log "Did not get AB"

30+ when (not gotBA) $ log "Did not get BA"

31+ when (not gotA') $ log "Did not get A"

32+ when (gotAB && gotBA && gotA') $ log "Done"

examples/passing/SolvingCompareSymbol.pursnew file+30

@@ -0,0 +1,30 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff.Console (log)

5+import Type.Data.Symbol (SProxy(..), class CompareSymbol, compareSymbol)

6+import Type.Data.Ordering (OProxy(..), kind Ordering, LT, EQ, GT, reflectOrdering)

8+symA :: SProxy "A"

9+symA = SProxy

10+

11+symB :: SProxy "B"

12+symB = SProxy

13+

14+egLT :: OProxy LT

15+egLT = compareSymbol symA symB

16+

17+egEQ :: OProxy EQ

18+egEQ = compareSymbol symA symA

19+

20+egGT :: OProxy GT

21+egGT = compareSymbol symB symA

22+

23+main = do

24+ let gotLT = reflectOrdering egLT == LT

25+ gotEQ = reflectOrdering egEQ == EQ

26+ gotGT = reflectOrdering egGT == GT

27+ when (not gotLT) $ log "Did not get LT"

28+ when (not gotEQ) $ log "Did not get EQ"

29+ when (not gotGT) $ log "Did not get GT"

30+ when (gotLT && gotEQ && gotGT) $ log "Done"

src/Language/PureScript/Constants.hs+35−4

@@ -314,10 +314,38 @@ fromSpine = "fromSpine"

314314toSignature :: Text

315315toSignature = "toSignature"

316316

317−-- IsSymbol class

317+-- Data.Symbol

318+

319+pattern DataSymbol :: ModuleName

320+pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"]

318321

319322pattern IsSymbol :: Qualified (ProperName 'ClassName)

320−pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol")

323+pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol")

324+

325+-- Type.Data.Symbol

326+

327+pattern TypeDataSymbol :: ModuleName

328+pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data", ProperName "Symbol"]

329+

330+pattern CompareSymbol :: Qualified (ProperName 'ClassName)

331+pattern CompareSymbol = Qualified (Just TypeDataSymbol) (ProperName "CompareSymbol")

332+

333+pattern AppendSymbol :: Qualified (ProperName 'ClassName)

334+pattern AppendSymbol = Qualified (Just TypeDataSymbol) (ProperName "AppendSymbol")

335+

336+-- Type.Data.Ordering

337+

338+typeDataOrdering :: ModuleName

339+typeDataOrdering = ModuleName [ProperName "Type", ProperName "Data", ProperName "Ordering"]

340+

341+orderingLT :: Qualified (ProperName 'TypeName)

342+orderingLT = Qualified (Just typeDataOrdering) (ProperName "LT")

343+

344+orderingEQ :: Qualified (ProperName 'TypeName)

345+orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ")

346+

347+orderingGT :: Qualified (ProperName 'TypeName)

348+orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT")

321349

322350-- Main module

323351

@@ -329,11 +357,14 @@ main = "main"

329357partial :: Text

330358partial = "Partial"

331359

360+pattern Prim :: ModuleName

361+pattern Prim = ModuleName [ProperName "Prim"]

362+

332363pattern Partial :: Qualified (ProperName 'ClassName)

333−pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial")

364+pattern Partial = Qualified (Just Prim) (ProperName "Partial")

334365

335366pattern Fail :: Qualified (ProperName 'ClassName)

336−pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail")

367+pattern Fail = Qualified (Just Prim) (ProperName "Fail")

337368

338369typ :: Text

339370typ = "Type"

src/Language/PureScript/TypeChecker/Entailment.hs+23−4

@@ -45,6 +45,10 @@ data Evidence

4545 -- ^ An existing named instance

4646 | IsSymbolInstance Text

4747 -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

48+ | CompareSymbolInstance

49+ -- ^ Computed instance of CompareSymbol

50+ | AppendSymbolInstance

51+ -- ^ Computed instance of AppendSymbol

4852 deriving (Eq)

4953

5054-- | Extract the identifier of a named instance

@@ -138,7 +142,18 @@ entails SolverOptions{..} constraint context hints =

138142 solve constraint

139143 where

140144 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

141− forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

145+ forClassName _ C.IsSymbol [TypeLevelString sym] =

146+ [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

147+ forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =

148+ let ordering = case compare lhs rhs of

149+ LT -> C.orderingLT

150+ EQ -> C.orderingEQ

151+ GT -> C.orderingGT

152+ args = [arg0, arg1, TypeConstructor ordering]

153+ in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing]

154+ forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =

155+ let args = [arg0, arg1, TypeLevelString (lhs <> rhs)]

156+ in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing]

142157 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))

143158 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

144159

@@ -293,9 +308,13 @@ entails SolverOptions{..} constraint context hints =

293308 -- Make a dictionary from subgoal dictionaries by applying the correct function

294309 mkDictionary :: Evidence -> Maybe [Expr] -> Expr

295310 mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

296− mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where

297− fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym)))

298− ]

311+ mkDictionary (IsSymbolInstance sym) _ =

312+ let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in

313+ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))

314+ mkDictionary CompareSymbolInstance _ =

315+ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

316+ mkDictionary AppendSymbolInstance _ =

317+ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

299318

300319 -- Turn a DictionaryValue into a Expr

301320 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

tests/TestCompiler.hs+22−17

@@ -61,13 +61,13 @@ main = hspec spec

6161spec :: Spec

6262spec = do

6363

64− (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do

64+ (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do

6565 cwd <- getCurrentDirectory

6666 let passing = cwd </> "examples" </> "passing"

6767 let warning = cwd </> "examples" </> "warning"

6868 let failing = cwd </> "examples" </> "failing"

6969 let supportDir = cwd </> "tests" </> "support" </> "bower_components"

70− let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir

70+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir

7171 passingFiles <- getTestFiles passing <$> testGlob passing

7272 warningFiles <- getTestFiles warning <$> testGlob warning

7373 failingFiles <- getTestFiles failing <$> testGlob failing

@@ -77,10 +77,10 @@ spec = do

7777 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

7878 foreigns <- inferForeignModules modules

7979 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

80− return (zip (map snd modules) externs)

80+ return (zip (map snd modules) externs, foreigns)

8181 case supportExterns of

8282 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)

83− Right externs -> return (externs, passingFiles, warningFiles, failingFiles)

83+ Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles)

8484

8585 outputFile <- runIO $ do

8686 tmp <- getTemporaryDirectory

@@ -90,21 +90,21 @@ spec = do

9090 context "Passing examples" $

9191 forM_ passingTestCases $ \testPurs ->

9292 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $

93− assertCompiles supportExterns testPurs outputFile

93+ assertCompiles supportExterns supportForeigns testPurs outputFile

9494

9595 context "Warning examples" $

9696 forM_ warningTestCases $ \testPurs -> do

9797 let mainPath = getTestMain testPurs

9898 expectedWarnings <- runIO $ getShouldWarnWith mainPath

9999 it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $

100− assertCompilesWithWarnings supportExterns testPurs expectedWarnings

100+ assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings

101101

102102 context "Failing examples" $

103103 forM_ failingTestCases $ \testPurs -> do

104104 let mainPath = getTestMain testPurs

105105 expectedFailures <- runIO $ getShouldFailWith mainPath

106106 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $

107− assertDoesNotCompile supportExterns testPurs expectedFailures

107+ assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures

108108

109109 where

110110

@@ -197,27 +197,29 @@ runTest = P.runMake P.defaultOptions

197197

198198compile

199199 :: [(P.Module, P.ExternsFile)]

200+ -> M.Map P.ModuleName FilePath

200201 -> [FilePath]

201202 -> ([P.Module] -> IO ())

202203 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

203−compile supportExterns inputFiles check = silence $ runTest $ do

204+compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do

204205 fs <- liftIO $ readInput inputFiles

205206 ms <- P.parseModulesFromFiles id fs

206207 foreigns <- inferForeignModules ms

207208 liftIO (check (map snd ms))

208− let actions = makeActions foreigns

209+ let actions = makeActions (foreigns `M.union` supportForeigns)

209210 case ms of

210211 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)

211212 _ -> P.make actions (map fst supportExterns ++ map snd ms)

212213

213214assert

214215 :: [(P.Module, P.ExternsFile)]

216+ -> M.Map P.ModuleName FilePath

215217 -> [FilePath]

216218 -> ([P.Module] -> IO ())

217219 -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))

218220 -> Expectation

219−assert supportExterns inputFiles check f = do

220− (e, w) <- compile supportExterns inputFiles check

221+assert supportExterns supportForeigns inputFiles check f = do

222+ (e, w) <- compile supportExterns supportForeigns inputFiles check

221223 maybeErr <- f (const w <$> e)

222224 maybe (return ()) expectationFailure maybeErr

223225

@@ -235,11 +237,12 @@ checkShouldFailWith expected errs =

235237

236238assertCompiles

237239 :: [(P.Module, P.ExternsFile)]

240+ -> M.Map P.ModuleName FilePath

238241 -> [FilePath]

239242 -> Handle

240243 -> Expectation

241−assertCompiles supportExterns inputFiles outputFile =

242− assert supportExterns inputFiles checkMain $ \e ->

244+assertCompiles supportExterns supportForeigns inputFiles outputFile =

245+ assert supportExterns supportForeigns inputFiles checkMain $ \e ->

243246 case e of

244247 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs

245248 Right _ -> do

@@ -260,11 +263,12 @@ assertCompiles supportExterns inputFiles outputFile =

260263

261264assertCompilesWithWarnings

262265 :: [(P.Module, P.ExternsFile)]

266+ -> M.Map P.ModuleName FilePath

263267 -> [FilePath]

264268 -> [String]

265269 -> Expectation

266−assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =

267− assert supportExterns inputFiles checkMain $ \e ->

270+assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith =

271+ assert supportExterns supportForeigns inputFiles checkMain $ \e ->

268272 case e of

269273 Left errs ->

270274 return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs

@@ -279,11 +283,12 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =

279283

280284assertDoesNotCompile

281285 :: [(P.Module, P.ExternsFile)]

286+ -> M.Map P.ModuleName FilePath

282287 -> [FilePath]

283288 -> [String]

284289 -> Expectation

285−assertDoesNotCompile supportExterns inputFiles shouldFailWith =

286− assert supportExterns inputFiles noPreCheck $ \e ->

290+assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith =

291+ assert supportExterns supportForeigns inputFiles noPreCheck $ \e ->

287292 case e of

288293 Left errs ->

289294 return $ if null shouldFailWith

tests/TestUtils.hs+25−2

@@ -57,6 +57,8 @@ supportModules =

5757 , "Control.Alternative"

5858 , "Control.Applicative"

5959 , "Control.Apply"

60+ , "Control.Biapplicative"

61+ , "Control.Biapply"

6062 , "Control.Bind"

6163 , "Control.Category"

6264 , "Control.Comonad"

@@ -72,6 +74,15 @@ supportModules =

7274 , "Control.MonadZero"

7375 , "Control.Plus"

7476 , "Control.Semigroupoid"

77+ , "Data.Bifoldable"

78+ , "Data.Bifunctor"

79+ , "Data.Bifunctor.Clown"

80+ , "Data.Bifunctor.Flip"

81+ , "Data.Bifunctor.Join"

82+ , "Data.Bifunctor.Joker"

83+ , "Data.Bifunctor.Product"

84+ , "Data.Bifunctor.Wrap"

85+ , "Data.Bitraversable"

7586 , "Data.Boolean"

7687 , "Data.BooleanAlgebra"

7788 , "Data.Bounded"

@@ -79,18 +90,24 @@ supportModules =

7990 , "Data.Eq"

8091 , "Data.EuclideanRing"

8192 , "Data.Field"

93+ , "Data.Foldable"

8294 , "Data.Function"

8395 , "Data.Function.Uncurried"

8496 , "Data.Functor"

8597 , "Data.Functor.Invariant"

8698 , "Data.Generic.Rep"

87− , "Data.Generic.Rep.Monoid"

8899 , "Data.Generic.Rep.Eq"

100+ , "Data.Generic.Rep.Monoid"

89101 , "Data.Generic.Rep.Ord"

90102 , "Data.Generic.Rep.Semigroup"

103+ , "Data.Generic.Rep.Show"

91104 , "Data.HeytingAlgebra"

105+ , "Data.Maybe"

106+ , "Data.Maybe.First"

107+ , "Data.Maybe.Last"

92108 , "Data.Monoid"

93109 , "Data.Monoid.Additive"

110+ , "Data.Monoid.Alternate"

94111 , "Data.Monoid.Conj"

95112 , "Data.Monoid.Disj"

96113 , "Data.Monoid.Dual"

@@ -104,8 +121,9 @@ supportModules =

104121 , "Data.Ring"

105122 , "Data.Semigroup"

106123 , "Data.Semiring"

107− , "Data.Symbol"

108124 , "Data.Show"

125+ , "Data.Symbol"

126+ , "Data.Traversable"

109127 , "Data.Unit"

110128 , "Data.Void"

111129 , "Partial"

@@ -113,6 +131,11 @@ supportModules =

113131 , "Prelude"

114132 , "Test.Assert"

115133 , "Test.Main"

134+ , "Type.Data.Ordering"

135+ , "Type.Data.Symbol"

136+ , "Type.Equality"

137+ , "Type.Prelude"

138+ , "Type.Proxy"

116139 , "Unsafe.Coerce"

117140 ]

118141

tests/support/bower.json+11−10

@@ -1,16 +1,17 @@

11{

22 "name": "purescript-test-suite-support",

33 "dependencies": {

4− "purescript-assert": "1.0.0-rc.1",

5− "purescript-console": "1.0.0-rc.1",

6− "purescript-eff": "1.0.0-rc.1",

7− "purescript-functions": "1.0.0-rc.1",

8− "purescript-prelude": "1.1.0",

9− "purescript-st": "1.0.0-rc.1",

4+ "purescript-assert": "2.0.0",

5+ "purescript-console": "2.0.0",

6+ "purescript-eff": "2.0.0",

7+ "purescript-functions": "2.0.0",

8+ "purescript-prelude": "2.1.0",

9+ "purescript-st": "2.0.0",

1010 "purescript-partial": "1.1.2",

11− "purescript-newtype": "0.1.0",

12− "purescript-generics-rep": "2.0.0",

13− "purescript-symbols": "^1.0.1",

14− "purescript-unsafe-coerce": "^1.0.0"

11+ "purescript-newtype": "1.1.0",

12+ "purescript-generics-rep": "4.0.0",

13+ "purescript-symbols": "^2.0.0",

14+ "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac",

15+ "purescript-unsafe-coerce": "^2.0.0"

1516 }

1617}