Remove special handling for generic packers/unpackers

morloc-project · May 1, 2019 · b5f23df · b5f23df
1 parent 836c18d
commit b5f23df
Show file tree

Hide file tree

Showing 3 changed files with 57 additions and 64 deletions.
diff --git a/library/Morloc/Component/Serializer.hs b/library/Morloc/Component/Serializer.hs
@@ -30,7 +30,6 @@ import qualified Data.Map.Strict as Map
 type SerialData =
   ( Key  -- type_id - 
   , Name -- property - "packs" or "unpackes"
-  , Bool -- is_generic - is this a generic packer/unpacker
   , Name -- name
   , Path -- path
   , Path -- module path
@@ -47,35 +46,49 @@ fromSparqlDb l db = do
     tuplify :: [Maybe MT.Text] -> MorlocMonad SerialData
     tuplify [ Just t -- typename
             , Just p -- property
-            , Just g -- is_generic
             , Just n -- name
             , Just s -- path (e.g., "rbase.R")
             , Just m -- module path (e.g., "$HOME/.morloc/lib/rbase/main.loc")
-            ] = return (t,p,g == "true",n,s,m)
+            ] = return (t,p,n,s,m)
     tuplify e = MM.throwError . SparqlFail $ "Unexpected SPARQL result: " <> MT.pretty e
 
+
     toSerialMap
-      :: Map.Map Key ConcreteType 
+      :: Map.Map Key ConcreteType
       -> [SerialData]
       -> MorlocMonad SerialMap
-    toSerialMap h xs = do
-      packers   <- sequence [lookupOrDie t h >>= getIn  p | (t, "packs"  , False, p, _, _) <- xs]
-      unpackers <- sequence [lookupOrDie t h >>= getOut p | (t, "unpacks", False, p, _, _) <- xs]
-      case ( Map.fromList packers
-           , Map.fromList unpackers
-           , [p | (_, "packs"  , True, p, _, _) <- xs]
-           , [p | (_, "unpacks", True, p, _, _) <- xs]
-           , MU.unique [makePath m s | (_, _, _, _, s, m) <- xs]
-           ) of
-        (phash, uhash, [p], [u], srcs) -> return $ SerialMap
-          { serialLang = l
-          , serialPacker = phash
-          , serialUnpacker = uhash
-          , serialGenericPacker = p
-          , serialGenericUnpacker = u
-          , serialSources = srcs
-          }
-        _ -> MM.throwError . TypeError $ "Expected exactly one generic packer/unpacker: " <> MT.pretty xs
+    toSerialMap h xs
+      =   SerialMap
+      <$> pure l -- language
+      <*> (fmap Map.fromList . sequence $
+            [lookupOrDie t h >>= getIn  p | (t, "packs"  , p, _, _) <- xs]) -- packers
+      <*> (fmap Map.fromList . sequence $
+            [lookupOrDie t h >>= getOut p | (t, "unpacks", p, _, _) <- xs]) -- unpackers
+      <*> pure (MU.unique [makePath m s | (_, _, _, s, m) <- xs]) -- sources
+
+
+    -- toSerialMap
+    --   :: Map.Map Key ConcreteType
+    --   -> [SerialData]
+    --   -> MorlocMonad SerialMap
+    -- toSerialMap h xs = do
+    --   packers   <- sequence [lookupOrDie t h >>= getIn  p | (t, "packs"  , False, p, _, _) <- xs]
+    --   unpackers <- sequence [lookupOrDie t h >>= getOut p | (t, "unpacks", False, p, _, _) <- xs]
+    --   case ( Map.fromList packers
+    --        , Map.fromList unpackers
+    --        , [p | (_, "packs"  , True, p, _, _) <- xs]
+    --        , [p | (_, "unpacks", True, p, _, _) <- xs]
+    --        , MU.unique [makePath m s | (_, _, _, _, s, m) <- xs]
+    --        ) of
+    --     (phash, uhash, [p], [u], srcs) -> return $ SerialMap
+    --       { serialLang = l
+    --       , serialPacker = phash
+    --       , serialUnpacker = uhash
+    --       , serialGenericPacker = p
+    --       , serialGenericUnpacker = u
+    --       , serialSources = srcs
+    --       }
+    --     _ -> MM.throwError . TypeError $ "Expected exactly one generic packer/unpacker: " <> MT.pretty xs
 
     makePath
       :: MT.Text -- module path
@@ -105,7 +118,6 @@ hsparql lang' = do
   basetype_      <- var
   id_            <- var
   importId_      <- var
-  isGeneric_     <- var
   name_          <- var
   output_        <- var
   packerInput_   <- var
@@ -152,8 +164,6 @@ hsparql lang' = do
         filterExpr (basetype_ .!=. OType)
     )
 
-  bind (basetype_ .==. OAtomicGenericType) isGeneric_
-
   optional_
     ( do
         triple_ sourceId_ PType OSource
@@ -170,26 +180,4 @@ hsparql lang' = do
   orderNextAsc typeId_
   orderNextAsc property_
 
-  selectVars [rhs_, property_, isGeneric_, name_, path_, modulePath_]
-
----- expected output for `sample.loc`
--- -----------------------------------------------------------------------------------------------------------------------
--- | rhs                    | property  | isGeneric | name              | path      | modulePath                         |
--- =======================================================================================================================
--- | mlc:rbase__main.loc_55 | "packs"   | true      | "packGeneric"     | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_20 | "packs"   | false     | "packCharacter"   | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_25 | "packs"   | false     | "packDataFrame"   | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_30 | "packs"   | false     | "packDataTable"   | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_35 | "packs"   | false     | "packList"        | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_40 | "packs"   | false     | "packLogical"     | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_45 | "packs"   | false     | "packMatrix"      | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_50 | "packs"   | false     | "packNumeric"     | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_60 | "unpacks" | true      | "unpackGeneric"   | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_65 | "unpacks" | false     | "unpackCharacter" | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_70 | "unpacks" | false     | "unpackDataFrame" | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_75 | "unpacks" | false     | "unpackDataTable" | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_80 | "unpacks" | false     | "unpackList"      | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_85 | "unpacks" | false     | "unpackLogical"   | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_90 | "unpacks" | false     | "unpackMatrix"    | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- | mlc:rbase__main.loc_95 | "unpacks" | false     | "unpackNumeric"   | "rbase.R" | "$HOME/.morloc/lib/rbase/main.loc" |
--- -----------------------------------------------------------------------------------------------------------------------
+  selectVars [rhs_, property_, name_, path_, modulePath_]
diff --git a/library/Morloc/Global.hs b/library/Morloc/Global.hs
@@ -199,8 +199,6 @@ data SerialMap = SerialMap {
       serialLang :: Lang
     , serialPacker   :: Map MType Name
     , serialUnpacker :: Map MType Name
-    , serialGenericPacker   :: Name
-    , serialGenericUnpacker :: Name
     , serialSources :: [Path] -- ^ The absolute paths to the source files
   }
   deriving(Show, Eq, Ord)

diff --git a/library/Morloc/Pools/Common.hs b/library/Morloc/Pools/Common.hs
@@ -230,18 +230,6 @@ makeSourceManifold g h m = do
             , udFile = text' (MS.makePoolName (gLang g))
           }))
 
--- find a packer for each argument
-getUnpackers :: SerialMap -> Manifold -> MorlocMonad [Doc]
-getUnpackers h m = case mConcreteType m of
-  (Just (MFuncType _ ts _)) -> return $ map (unpackerName h . return) ts 
-  (Just _) -> MM.throwError . GeneratorError $ "Expected a function type for:" <> MT.pretty m
-  Nothing -> return $ take (length (mArgs m)) (repeat (unpackerName h Nothing))
-  where
-    unpackerName :: SerialMap -> Maybe MType -> Doc 
-    unpackerName h' n' = case (n' >>= (flip Map.lookup) (serialUnpacker h')) of 
-      (Just f) -> text' f
-      Nothing  -> text' (serialGenericUnpacker h')
-
 callIdToName :: Manifold -> MorlocMonad Doc
 callIdToName m = text' <$> MS.makeManifoldName (mCallId m)
 
@@ -292,17 +280,36 @@ getUsedManifolds g ms = MM.filterM isBuilt ms >>= mapM callIdToName
 fname :: Manifold -> Doc
 fname m = text' (mCallName m)
 
+-- find a packer for each argument
+getUnpackers :: SerialMap -> Manifold -> MorlocMonad [Doc]
+getUnpackers hash m = case mConcreteType m of
+  (Just (MFuncType _ ts _)) -> mapM (getUnpacker hash) ts
+  Nothing -> case mAbstractType m of
+    (Just (MFuncType _ ts _)) -> mapM (getUnpacker hash) ts
+    Nothing -> MM.throwError . TypeError $
+      "Expected a function for the following manifold: " <> MT.pretty m
+
+getUnpacker :: SerialMap -> MType -> MorlocMonad Doc
+getUnpacker smap t =
+  case (MTH.findMostSpecificType
+         . Map.keys
+         . Map.filterWithKey (\p _ -> MTH.childOf t p)
+         $ (serialUnpacker smap)
+       ) >>= (flip Map.lookup) (serialUnpacker smap)
+  of
+    (Just x) -> return (text' x)
+    Nothing -> MM.throwError TrulyWeird
+
 -- | If a language-specific signature is given for the manifold, choose a
 -- packer that matches the language-specific output type. Otherwise, search for
 -- a packer that matches the morloc type.
 -- TODO: make the MorlocMonad
--- TODO: special handling of generic packers and unpackers is no longer necessary
 getPacker :: SerialMap -> Manifold -> Doc
 getPacker hash m = case packerType of
   (Just t) -> case Map.lookup t (serialPacker hash) of
     (Just n) -> text' n
     Nothing -> error "You should not be reading this"
-  Nothing -> text' $ serialGenericPacker hash
+  Nothing -> error "No packer found for this type"
   where
     packerType :: Maybe MType
     packerType = case cPacker of