A somewhat working version of deriving via & co.

Needs more work for correct handling of super-classes.

README.md

@@ -51,6 +51,7 @@ Differences:
    * BinaryLiterals
    * ConstraintKinds
    * DefaultSignatures
+   * DeriveAnyClass
    * DerivingStrategies
    * DerivingVia
    * DoAndIfThenElse

src/MicroHs/Deriving.hs

@@ -380,8 +380,9 @@ newtypeDer mctx lhs c cls mvia = do
           Constr [] [] _ (Left [(False, t)]) -> t
           Constr [] [] _ (Right [(_, (_, t))]) -> t
           _ -> error "newtypeDer"
-  traceM ("newtypeDer: " ++ show hdr)
-  return [Instance hdr $ InstanceVia (tApp cls cty) mvia]
+      mvia' = fmap (tApp cls) mvia
+--  traceM ("newtypeDer: " ++ show hdr)
+  return [Instance hdr $ InstanceVia (tApp cls cty) mvia']
 
 anyclassDer :: Maybe EConstraint -> LHS -> EConstraint -> T [EDef]
 anyclassDer mctx lhs cls = do

src/MicroHs/Parse.hs

@@ -399,11 +399,11 @@ pDerivings :: P [Deriving]
 pDerivings = many pDeriving
 
 pDeriving :: P Deriving
-pDeriving = pKeyword "deriving" *> (    (Deriving <$> pStrat <*> pDer)
-                                    <|> (flip Deriving <$> pDer <*> pVia) )
+pDeriving = pKeyword "deriving" *> (    (flip Deriving <$> pDer <*> pVia)
+                                    <|> (Deriving <$> pStrat <*> pDer) )
   where pDer =     pParens (esepBy pType (pSpec ','))
-               <|< ((:[]) <$> pType)
-        pVia = DerVia <$> (pKeyword "via" *> pType)
+               <|< ((:[]) <$> pAType)
+        pVia = DerVia <$> (pKeyword "via" *> pAType)
         pStrat = (DerStock <$ pKeyword "stock") <|< (DerNewtype <$ pKeyword "newtype")
              <|< (DerAnyClass <$ pKeyword "anyclass") <|< pure DerNone
 

src/MicroHs/TypeCheck.hs

@@ -1122,9 +1122,12 @@ tcDefType def = do
 tcDeriving :: Deriving -> T Deriving
 tcDeriving (Deriving strat cs) = do
   let tcDerive = tCheckTypeT (kType `kArrow` kConstraint)
+  --traceM $ "tcDerive 1 " ++ show cs
   cs' <- mapM tcDerive cs
   strat' <- case strat of
-              DerVia t -> DerVia <$> tcDerive t
+              DerVia t -> do
+                --traceM $ "tcDerive 2 " ++ show t
+                DerVia <$> tCheckTypeT kType t
               _        -> return strat
   return $ Deriving strat' cs'
 
@@ -1903,7 +1906,8 @@ tcExprAp mt ae args =
       (f, t) <- tInferExpr ae
       tcExprApFn mt f t args
 
-tcExprApFn :: Expected -> Expr -> EType -> [Expr] -> T Expr
+tcExprApFn :: HasCallStack =>
+              Expected -> Expr -> EType -> [Expr] -> T Expr
 --tcExprApFn _ fn fnt args | trace (show (fn, fnt, args)) False = undefined
 tcExprApFn mt fn (EForall {-True-}_ (IdKind i _:iks) ft) (ETypeArg t : args) = do
   t' <- if t `eqEType` EVar dummyIdent then newUVar else tcType (Check kType) t

tests/Makefile

@@ -86,6 +86,7 @@ test:
 	$(TMHS) LocalFix   && $(EVAL) > LocalFix.out   && diff LocalFix.ref LocalFix.out
 	$(TMHS) TypeApp    && $(EVAL) > TypeApp.out    && diff TypeApp.ref TypeApp.out
 	$(TMHS) Do         && $(EVAL) > Do.out         && diff Do.ref Do.out
+	$(TMHS) Via        && $(EVAL) > Via.out        && diff Via.ref Via.out
 
 errtest:
 	sh errtester.sh $(MHS) < errmsg.test

tests/Via.hs

@@ -0,0 +1,69 @@
+module Via where
+
+newtype B = B Bool
+  deriving newtype Eq
+
+newtype N = N Int
+  deriving newtype (Eq, Ord)
+  deriving stock (Show)
+  deriving newtype Num
+
+data Id a = Id a
+  deriving stock Eq
+
+newtype BI = BI (Id Int)
+  deriving newtype Eq
+
+newtype Id2 a = Id2 (Id a)
+  deriving newtype Eq
+
+------
+
+import Numeric
+
+newtype Hex a = Hex a
+
+instance (Integral a, Show a) => Show (Hex a) where
+  show (Hex a) = "0x" ++ showHex a ""
+
+newtype Unicode = U Int
+  deriving Show via (Hex Int)
+
+-- >>> euroSign
+-- 0x20ac
+euroSign :: Unicode
+euroSign = U 0x20ac
+
+-------
+
+class SPretty a where
+  sPpr :: a -> String
+  default sPpr :: Show a => a -> String
+  sPpr = show
+
+data S = S String
+  deriving stock Show
+  deriving anyclass SPretty
+
+-------
+
+main :: IO ()
+main = do
+  print $ B True == B True
+
+  let x = N 1
+      y = N 2
+  print $ x == x
+  print $ x == y
+  print $ x < y
+  print $ x + y
+
+  print $ BI (Id 1) == BI (Id 1)
+
+  print $ Id2 (Id False) == Id2 (Id False)
+
+  print euroSign
+
+  print $ sPpr $ S "hello"
+
+  putStrLn "done"

tests/Via.ref

@@ -0,0 +1,10 @@
+True
+True
+False
+True
+N 3
+True
+True
+0x20AC
+"S \"hello\""
+done