Skip to content

Commit 88fdcee

Browse files
LiamGoodacrepaf31
LiamGoodacre
authored and
paf31
committed
Solving CompareSymbol and AppendSymbol (purescript#2511)
* update test support * Solve CompareSymbol and AppendSymbol * Pass foreign support through on testing + fix solving tests
1 parent 144dd6f commit 88fdcee

File tree

7 files changed

+178
-37
lines changed

7 files changed

+178
-37
lines changed

‎examples/passing/SolvingAppendSymbol.purs‎

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
module Main where
2+
3+
import Prelude
4+
import Control.Monad.Eff.Console (log)
5+
import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol)
6+
7+
sym :: SProxy ""
8+
sym = SProxy
9+
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.purs‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
module Main where
2+
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)
7+
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‎

Lines changed: 35 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -314,10 +314,38 @@ fromSpine = "fromSpine"
314314
toSignature :: Text
315315
toSignature = "toSignature"
316316

317-
-- IsSymbol class
317+
-- Data.Symbol
318+
319+
pattern DataSymbol :: ModuleName
320+
pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"]
318321

319322
pattern 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"
329357
partial :: Text
330358
partial = "Partial"
331359

360+
pattern Prim :: ModuleName
361+
pattern Prim = ModuleName [ProperName "Prim"]
362+
332363
pattern Partial :: Qualified (ProperName 'ClassName)
333-
pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial")
364+
pattern Partial = Qualified (Just Prim) (ProperName "Partial")
334365

335366
pattern Fail :: Qualified (ProperName 'ClassName)
336-
pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail")
367+
pattern Fail = Qualified (Just Prim) (ProperName "Fail")
337368

338369
typ :: Text
339370
typ = "Type"

‎src/Language/PureScript/TypeChecker/Entailment.hs‎

Lines changed: 23 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 22 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -61,13 +61,13 @@ main = hspec spec
6161
spec :: Spec
6262
spec = 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

198198
compile
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

213214
assert
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

236238
assertCompiles
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

261264
assertCompilesWithWarnings
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

280284
assertDoesNotCompile
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‎

Lines changed: 25 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -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,25 +74,40 @@ 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"
7889
, "Data.CommutativeRing"
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,15 +121,21 @@ 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"
112130
, "Partial.Unsafe"
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

0 commit comments

Comments
 (0)