v0.45.0 - explicit instance imports

In Haskell, all instances of polymorphic terms are imported implicitly
when the defining module is imported.

In Morloc, however, since terms are polymorphic both in type and in
language, it is often useful to more selectively import instances. So
now any terms defined in typeclasses must be specified. For example:

```
import base (show)
```

Where `show` is method of the `Show` typeclass.

Another part of my rational is that monomorphic and polymorphic
functions ought to be treated as similarly as possible. That said, even
finer control might be worthwhile. We could require that typeclasses are
imported explicitly, forexample:

```
import cppbase (Ord)
```

Or to import only specific terms:

```
import cppbase (Ord(ge, lt))
```

This would also allow one to make aliases for the polymorphic terms.

ChangeLog.md

@@ -57,6 +57,13 @@ handling for several very different languages (proofs-of-concept).
  - [ ] Ensure github actions passes
 
 
+0.45.0 [2024.02.14]
+-------------------
+
+ * Allow explicit import of polymorphic terms
+ * Fix infinite loop bug when two many arguments are applied to a function
+ * Synchronise tests with new core libraries type classes
+
 0.44.0 [2024.02.08]
 -------------------
 

README.md

@@ -275,5 +275,5 @@ List Real -> Real
 
 The concrete type of `mul` is currently written as a binary function of
 doubles. Ideally this function should accept any numbers (e.g., an `int` and a
-`double`). Eventually I will add typeclasses which will allow more useful
-definitions.
+`double`). This can be accomplished with typeclasses. These are now supported
+but still a tad experimental.

demos/02_flu/main.loc

@@ -47,8 +47,7 @@ import base
   , join
   , paste
   , keys
-  , length
-  , lengthS
+  , size
   , onFst
   , sleep
   , unique
@@ -115,14 +114,14 @@ classify
   = push id passClade setLeaf
   . pullNode snd pullClade where
 
-  passClade parent edge child = (edge, ifelse (eq 0 (lengthS child)) parent child)
+  passClade parent edge child = (edge, ifelse (eq 0 (size child)) parent child)
 
   -- setLeaf parent edge leaf = (edge, { accession = leaf@accession, clade = parent })
   setLeaf parent edge leaf = (edge, (fst leaf, parent))
 
   pullClade xs
-    = branch (eq 1 . length) head (const "") seenClades
+    = branch (eq 1 . size) head (const "") seenClades
     where
       seenClades = ( unique
-                   . filter (ne 0 . lengthS)
+                   . filter (ne 0 . size)
                    ) xs

executable/Subcommands.hs

@@ -107,23 +107,12 @@ cmdTypecheck args _ config = do
 
 writeFrontendTypecheckOutput :: Int -> ((Either MorlocError [AnnoS (Indexed TypeU) Many Int], [MT.Text]), MorlocState) -> MDoc
 writeFrontendTypecheckOutput _ ((Left e, _), _) = pretty e
-writeFrontendTypecheckOutput 0 ((Right xs, _), s) = vsep (map (writeFrontendTypes s) xs)
-writeFrontendTypecheckOutput 1 ((Right xs, _), s) = "\nExports:\n\n" <> vsep (map (writeFrontendTypes s) xs)
+writeFrontendTypecheckOutput 0 ((Right xs, _), _) = vsep (map writeFrontendTypes xs)
+writeFrontendTypecheckOutput 1 x = writeFrontendTypecheckOutput 0 x -- no difference in verbosity
 writeFrontendTypecheckOutput _ _ = "I don't know how to be that verbose"
 
-writeFrontendTypes :: MorlocState -> AnnoS (Indexed TypeU) Many Int -> MDoc
-writeFrontendTypes  s (AnnoS (Idx gidx t) _ _) = writeTerm s gidx (pretty t)
-
-writeTerm :: MorlocState -> Int -> MDoc -> MDoc
-writeTerm s i typeDoc =
-    case ( Map.lookup i (stateName s)
-         , GMap.lookup i (stateSignatures s))
-    of
-        (Just v, GMapJust (Monomorphic TermTypes{termGeneral = Just t'})) -> pretty v <+> "::" <+> pretty t'
-        (Just _, GMapJust (Polymorphic cls v t _)) -> "class" <+> pretty cls <+> pretty v <+> "::" <+> pretty (etype t)
-        (Just v, _) -> pretty v <+> "|-" <+> typeDoc
-        _ -> "MISSING"
-
+writeFrontendTypes :: AnnoS (Indexed TypeU) Many Int -> MDoc
+writeFrontendTypes  (AnnoS (Idx _ t) _ e) = pretty e <+> "::" <+> pretty t 
 
 writeTypecheckOutput :: Int -> ((Either MorlocError [(Lang, [SerialManifold])], [MT.Text]), MorlocState) -> MDoc
 writeTypecheckOutput _ ((Left e, _), _) = pretty e

executable/UI.hs

@@ -13,7 +13,7 @@ opts :: ParserInfo CliCommand
 opts = info (cliParser <**> helper)
   (    fullDesc
     <> progDesc "call 'morloc make -h', 'morloc install -h', etc for details"
-    <> header "morloc v0.44.0"  -- FIXME: HARDCODED VERSION NUMBER!!!
+    <> header "morloc v0.45.0"  -- FIXME: HARDCODED VERSION NUMBER!!!
   )
 
 

library/Morloc/CodeGenerator/Generate.hs

@@ -1098,18 +1098,22 @@ expressPolyExpr parentLang pc (AnnoS (Idx midx _) (_, args) (AppS (AnnoS (Idx _
   ----------------------------------------------------------------------------------------
   | sameLanguage = do
       MM.sayVVV $ "case #1 - m" <> pretty midx <> parens (pretty (srcName src)) <> ":" <+> pretty fc
-                <> "\n  " <> list (map pretty args)
+                <> "\n  (map (Idx cidxCall) inputs):" <+> list (map (pretty . Idx cidxCall) inputs)
+                <> "\n  xs:" <+> list (map pretty xs)
+                <> "\n  args:" <+> list (map pretty args)
+                <> "\n  fc:" <+> pretty fc
+                <> "\n  src:" <+> pretty src
 
       -- There should be an equal number of input types and input arguments
       -- That is, the function should be fully applied. If it were partially
       -- applied, the lambda case would have been entered previously instead.
-      xs' <- fromJust <$> safeZipWithM (expressPolyExpr callLang) (map (Idx cidxCall) inputs) xs
+      mayxs <- safeZipWithM (expressPolyExpr callLang) (map (Idx cidxCall) inputs) xs
 
       MM.sayVVV "  leaving case #1"
       return
           . PolyManifold callLang midx (ManifoldFull (map unvalue args))
           . PolyReturn
-          $ PolyApp f xs'
+          $ PolyApp f (fromJust mayxs)
 
   ----------------------------------------------------------------------------------------
   -- #5 trans applied                                          | contextArgs | boundArgs |

library/Morloc/CodeGenerator/Serial.hs

@@ -92,11 +92,11 @@ findPackers lang = do
             <> "\n  sigmap:" <+> viaShow sigmap
 
   packers <- case Map.lookup (EV "pack") sigmap of
-    (Just (_, _, _, ts)) -> return $ concatMap f ts
+    (Just (Instance _ _ _ ts)) -> return $ concatMap f ts
     Nothing -> return []
 
   unpackers <- case Map.lookup (EV "unpack") sigmap of
-    (Just (_, _, _, ts)) -> return $ concatMap f ts
+    (Just (Instance _ _ _ ts)) -> return $ concatMap f ts
     Nothing -> return []
 
   return (packers, unpackers)

library/Morloc/Data/DAG.hs

@@ -38,6 +38,7 @@ module Morloc.Data.DAG
   , lookupAliasedTerm
   , lookupAliasedTermM
   , synthesizeDAG
+  , foldDAG
   ) where
 
 import Morloc.Namespace
@@ -257,6 +258,24 @@ synthesizeDAG f d0 = synthesizeDAG' (Just Map.empty) where
           n2 <- f k1 n1 augmented
           return $ Map.insert k1 (n2, xs) dn
 
+foldDAG
+  :: (Ord k, Monad m)
+  => k -- initial key
+  -> Maybe e -- the edge to this node if not root
+  -> (k -> Maybe e -> n -> a -> m a) -- aggregation function
+  -> a -- initial accumulator
+  -> DAG k e n -- DAG folded over
+  -> m a
+foldDAG k e f b d =
+  case Map.lookup k d of
+    (Just (n, es)) -> do 
+      a <- foldlM (\b' (k', e') -> foldDAG k' (Just e') f b' d) b es
+      f k e n a
+    Nothing -> undefined
+
+
+-- type DAG key edge node = Map key (node, [(key, edge)])
+
 -- Inherit all imported values and their terminal aliases
 inherit
   :: (Ord k, Eq v)