Create TypeInfo, add type inference unit tests

Frames.cabal

@@ -230,7 +230,7 @@ test-suite spec
                        Categorical Chunks
   build-depends:       base, text, hspec, Frames, template-haskell,
                        temporary, directory, htoml, regex-applicative, pretty,
-                       unordered-containers, pipes, HUnit, vinyl,
+                       unordered-containers, pipes, HUnit, vector, vinyl,
                        foldl >= 1.3 && < 1.5,
                        attoparsec, lens
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall

src/Frames/Categorical.hs

@@ -129,4 +129,5 @@ instance KnownNat n => Parseable (Categorical n) where
           maxVariants :: Int
           maxVariants = fromIntegral (toInteger (natVal' (proxy# :: Proxy# n)))
   representableAsType (S.toList . categories . parsedValue -> cats) =
-    Const (Left (\n -> declareCategorical n (Just n) (map T.unpack cats)))
+    Const . TypeGenerator $
+      \n -> declareCategorical n (Just n) (map T.unpack cats)

src/Frames/ColumnTypeable.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, DefaultSignatures, LambdaCase,
+{-# LANGUAGE BangPatterns, DefaultSignatures, LambdaCase, TypeApplications,
              ScopedTypeVariables #-}
 module Frames.ColumnTypeable where
 import Control.Monad (MonadPlus)
@@ -42,12 +42,12 @@ class Parseable a where
   default parseCombine :: MonadPlus m => Parsed a -> Parsed a -> m (Parsed a)
   parseCombine = const . return
 
-  representableAsType :: Parsed a -> Const (Either (String -> Q [Dec]) Type) a
+  representableAsType :: Parsed a -> Const TypeInfo a
   default
     representableAsType :: Typeable a
-                        => Parsed a -> Const (Either (String -> Q [Dec]) Type) a
+                        => Parsed a -> Const TypeInfo a
   representableAsType =
-    const (Const (Right (ConT (mkName (show (typeRep (Proxy :: Proxy a)))))))
+    const . Const . ExistingType . ConT . mkName . show . typeRep $ Proxy @a
 
 -- | Discard any estimate of a parse's ambiguity.
 discardConfidence :: Parsed a -> a
@@ -85,5 +85,35 @@ instance Parseable T.Text where
 -- types, and provides a mechanism to infer which type best represents
 -- some textual data.
 class ColumnTypeable a where
-  colType :: a -> Either (String -> Q [Dec]) Type
+  colType :: a -> TypeInfo
   inferType :: T.Text -> a
+
+data TypeInfo
+  = TypeGenerator (String -> Q [Dec])
+  | ExistingType Type
+
+instance Show TypeInfo where
+  show (TypeGenerator _) = "cat"
+  show (ExistingType t) = show t
+
+existingTypeWithName :: Name -> TypeInfo
+existingTypeWithName = ExistingType . ConT
+
+existingTypeNamed :: String -> TypeInfo
+existingTypeNamed = existingTypeWithName . mkName
+
+getType :: TypeInfo -> Type
+getType (TypeGenerator _) = ConT . mkName $ "Categorical"
+getType (ExistingType t) = t
+
+getExistingType :: TypeInfo -> Maybe Type
+getExistingType (TypeGenerator _) = Nothing
+getExistingType (ExistingType t) = Just t
+
+getColType :: String -> TypeInfo -> Type
+getColType qualName (TypeGenerator _) = ConT (mkName qualName)
+getColType _ (ExistingType t) = t
+
+getExtraDecs :: String -> TypeInfo -> Q [Dec]
+getExtraDecs qualName (TypeGenerator typeGen) = typeGen qualName
+getExtraDecs _ _ = pure []

src/Frames/ColumnUniverse.hs

@@ -6,8 +6,8 @@
              TypeFamilies, TypeOperators, UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Frames.ColumnUniverse (
-  CoRec, Columns, ColumnUniverse, ColInfo,
-  CommonColumns, CommonColumnsCat, parsedTypeRep
+  CoRec, Columns, ColumnUniverse, ColInfo(..),
+  CommonColumns, CommonColumnsCat, parsedTypeRep, bestRep
 ) where
 import Data.Maybe (fromMaybe)
 import Data.Semigroup (Semigroup((<>)))
@@ -41,23 +41,21 @@ tryParseAll = rtraverse getCompose funs
 
 -- | Information necessary for synthesizing row types and comparing
 -- types.
-newtype ColInfo a = ColInfo (Either (String -> Q [Dec]) Type, Parsed a)
+newtype ColInfo a = ColInfo (TypeInfo, Parsed a)
 instance Show a => Show (ColInfo a) where
   show (ColInfo (t,p)) = "(ColInfo {"
-                         ++ either (const "cat") show t
+                         ++ show t
                          ++ ", "
                          ++ show (discardConfidence p) ++"})"
 
 parsedToColInfo :: Parseable a => Parsed a -> ColInfo a
-parsedToColInfo x = case getConst rep of
-                      Left dec -> ColInfo (Left dec, x)
-                      Right ty ->
-                        ColInfo (Right ty, x)
+parsedToColInfo x =
+  let ty = getConst rep
+  in ColInfo (ty, x)
   where rep = representableAsType x
 
 parsedTypeRep :: ColInfo a -> Parsed Type
-parsedTypeRep (ColInfo (t,p)) =
-  const (either (const (ConT (mkName "Categorical"))) id t) <$> p
+parsedTypeRep (ColInfo (t,p)) = getType t <$ p
 
 -- | Map 'Type's we know about (with a special treatment of
 -- synthesized types for categorical variables) to 'Int's for ordering
@@ -95,7 +93,7 @@ lubTypes :: Parsed (Maybe Type) -> Parsed (Maybe Type) -> Maybe Ordering
 lubTypes x y = compare <$> orderParsePriorities y <*> orderParsePriorities x
 
 instance (T.Text ∈ ts, RPureConstrained Parseable ts) => Monoid (CoRec ColInfo ts) where
-  mempty = CoRec (ColInfo ( Right (ConT (mkName "Text")), Possibly T.empty))
+  mempty = CoRec (ColInfo (existingTypeNamed "Text", Possibly T.empty))
   mappend x y = x <> y
 
 -- | A helper For the 'Semigroup' instance below.
@@ -104,7 +102,7 @@ mergeEqTypeParses :: forall ts. (RPureConstrained Parseable ts, T.Text ∈ ts)
 mergeEqTypeParses x@(CoRec _) y = fromMaybe definitelyText
                                 $ coRecTraverse getCompose
                                                 (coRecMapC @Parseable aux x)
-  where definitelyText = CoRec (ColInfo (Right (ConT (mkName "Text")), Definitely T.empty))
+  where definitelyText = CoRec (ColInfo (existingTypeNamed "Text", Definitely T.empty))
         aux :: forall a. (Parseable a, NatToInt (RIndex a ts))
             => ColInfo a -> (Maybe :. ColInfo) a
         aux (ColInfo (_, pX)) =
@@ -118,8 +116,8 @@ mergeEqTypeParses x@(CoRec _) y = fromMaybe definitelyText
 instance (T.Text ∈ ts, RPureConstrained Parseable ts)
   => Semigroup (CoRec ColInfo ts) where
   x@(CoRec (ColInfo (tyX, pX))) <> y@(CoRec (ColInfo (tyY, pY))) =
-    case lubTypes (const (either (const Nothing) Just tyX) <$> pX)
-                  (const (either (const Nothing) Just tyY) <$> pY) of
+    case lubTypes (getExistingType tyX <$ pX)
+                  (getExistingType tyY <$ pY) of
       Just GT -> x
       Just LT -> y
       Just EQ -> mergeEqTypeParses x y

src/Frames/TH.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP, DataKinds, GADTs, KindSignatures, OverloadedStrings,
              QuasiQuotes, RecordWildCards, RoleAnnotations,
-             ScopedTypeVariables, TemplateHaskell, TupleSections,
+             ScopedTypeVariables, TemplateHaskell, TupleSections, FlexibleContexts,
              TypeApplications, TypeOperators #-}
 -- | Code generation of types relevant to Frames use-cases. Generation
 -- may be driven by an automated inference process or manual use of
@@ -90,21 +90,18 @@ lowerHead = fmap aux . T.uncons
 
 -- | For each column, we declare a type synonym for its type, and a
 -- Proxy value of that type.
-colDec :: T.Text -> String -> T.Text
-       -> (Either (String -> Q [Dec]) Type)
-       -> Q (Type, [Dec])
+colDec :: T.Text -> String -> T.Text -> TypeInfo -> Q (Type, [Dec])
 colDec prefix rowName colName colTypeGen = do
-  (colTy, extraDecs) <- either colDecsHelper (pure . (,[])) colTypeGen
+  let qualName = rowName <> T.unpack (capitalize1 colName)
+  let colTy = getColType qualName colTypeGen
+  extraDecs <- getExtraDecs qualName colTypeGen
   let colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $(return colTy)|]
   syn <- mkColSynDec colTypeQ colTName'
   lenses <- mkColLensDec colTName' colTy colPName
   return (ConT colTName', syn : extraDecs ++ lenses)
   where colTName = sanitizeTypeName (prefix <> capitalize1 colName)
         colPName = fromMaybe "colDec impossible" (lowerHead colTName)
         colTName' = mkName $ T.unpack colTName
-        colDecsHelper f =
-          let qualName = rowName ++ T.unpack (capitalize1 colName)
-          in (ConT (mkName qualName),) <$> f qualName
 
 -- | Splice for manually declaring a column of a given type. For
 -- example, @declareColumn "x2" ''Double@ will declare a type synonym
@@ -214,13 +211,13 @@ colNamesP src = either (const []) fst <$> P.next src
 tableTypesText' :: forall a c.
                    (c ~ CoRec ColInfo a, ColumnTypeable c, Monoid c)
                 => RowGen a -> DecsQ
-tableTypesText' (RowGen {..}) =
+tableTypesText' RowGen {..} =
   do colNames <- runIO . P.runSafeT $
                  maybe (colNamesP (lineReader separator))
                        pure
                        (headerOverride opts)
      let headers = zip colNames (repeat (ConT ''T.Text))
-     (colTypes, colDecs) <- (second concat . unzip)
+     (colTypes, colDecs) <- second concat . unzip
                             <$> mapM (uncurry mkColDecs) headers
      let recTy = TySynD (mkName rowTypeName) [] (recDec colTypes)
          optsName = case rowTypeName of
@@ -238,7 +235,7 @@ tableTypesText' (RowGen {..}) =
           mColNm <- lookupTypeName (tablePrefix ++ safeName)
           case mColNm of
             Just n -> pure (ConT n, [])
-            Nothing -> colDec (T.pack tablePrefix) rowTypeName colNm (Right colTy)
+            Nothing -> colDec (T.pack tablePrefix) rowTypeName colNm (ExistingType colTy)
 
 -- | Generate a type for a row of a table. This will be something like
 -- @Record ["x" :-> a, "y" :-> b, "z" :-> c]@. Additionally generates
@@ -248,12 +245,12 @@ tableTypesText' (RowGen {..}) =
 -- rlens \@Foo@, and @foo' = rlens' \@Foo@.
 tableTypes' :: forall a c. (c ~ CoRec ColInfo a, ColumnTypeable c, Monoid c)
             => RowGen a -> DecsQ
-tableTypes' (RowGen {..}) =
+tableTypes' RowGen {..} =
   do headers <- runIO . P.runSafeT
                 $ readColHeaders opts lineSource :: Q [(T.Text, c)]
-     (colTypes, colDecs) <- (second concat . unzip)
-                            <$> mapM (uncurry mkColDecs)
-                                     (map (second colType) headers)
+     (colTypes, colDecs) <- second concat . unzip
+                            <$> mapM (uncurry mkColDecs . second colType)
+                                     headers
      let recTy = TySynD (mkName rowTypeName) [] (recDec colTypes)
          optsName = case rowTypeName of
                       [] -> error "Row type name shouldn't be empty"
@@ -267,7 +264,7 @@ tableTypes' (RowGen {..}) =
                   | otherwise = Just (map T.pack columnNames)
         opts = ParserOptions colNames' separator (RFC4180Quoting '\"')
         lineSource = lineReader separator P.>-> P.take prefixSize
-        mkColDecs :: T.Text -> Either (String -> Q [Dec]) Type -> Q (Type, [Dec])
+        mkColDecs :: T.Text -> TypeInfo -> Q (Type, [Dec])
         mkColDecs colNm colTy = do
           let safeName = tablePrefix ++ (T.unpack . sanitizeTypeName $ colNm)
           mColNm <- lookupTypeName safeName