ColumnUniverse.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Frames.ColumnUniverse (
    CoRec,
    Columns,
    ColumnUniverse,
    ColInfo,
    CommonColumns,
    CommonColumnsCat,
    parsedTypeRep,
) where

import Data.Maybe (fromMaybe)
#if __GLASGOW_HASKELL__ < 808
import Data.Semigroup (Semigroup((<>)))
#endif
import Data.Either (fromRight)
import qualified Data.Text as T
import Data.Vinyl
import Data.Vinyl.CoRec
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel (NatToInt, RIndex)
import Frames.Categorical
import Frames.ColumnTypeable
import Language.Haskell.TH

-- | Extract a function to test whether some value of a given type
-- could be read from some 'T.Text'.
inferParseable :: (Parseable a) => T.Text -> (Maybe :. Parsed) a
inferParseable = Compose . parse

-- | Helper to call 'inferParseable' on variants of a 'CoRec'.
inferParseable' :: (Parseable a) => ((->) T.Text :. (Maybe :. Parsed)) a
inferParseable' = Compose inferParseable

-- * Record Helpers

tryParseAll ::
    forall ts.
    (RecApplicative ts, RPureConstrained Parseable ts) =>
    T.Text
    -> Rec (Maybe :. Parsed) ts
tryParseAll = rtraverse getCompose funs
  where
    funs :: Rec (((->) T.Text) :. (Maybe :. Parsed)) ts
    funs = rpureConstrained @Parseable inferParseable'

-- * Column Type Inference

-- | Information necessary for synthesizing row types and comparing
-- types.
newtype ColInfo a = ColInfo (Either (String -> Q [Dec]) Type, Parsed a)

instance (Show a) => Show (ColInfo a) where
    show (ColInfo (t, p)) =
        "(ColInfo {"
            ++ either (const "cat") 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)
  where
    rep = representableAsType x

parsedTypeRep :: ColInfo a -> Parsed Type
parsedTypeRep (ColInfo (t, p)) =
    fromRight (ConT (mkName "Categorical")) t <$ p

-- | Map 'Type's we know about (with a special treatment of
-- synthesized types for categorical variables) to 'Int's for ordering
-- purposes.
orderParsePriorities :: Parsed (Maybe Type) -> Maybe Int
orderParsePriorities x =
    case discardConfidence x of
        Nothing -> Just (1 + 6) -- categorical variable
        Just t
            | t == tyText -> Just (0 + uncertainty)
            | t == tyDbl -> Just (2 + uncertainty)
            | t == tyInt -> Just (3 + uncertainty)
            | t == tyBool -> Just (4 + uncertainty)
            | otherwise -> Just (5 + uncertainty) -- Unknown type
  where
    tyText = ConT (mkName "Text")
    tyDbl = ConT (mkName "Double")
    tyInt = ConT (mkName "Int")
    tyBool = ConT (mkName "Bool")
    uncertainty = case x of Definitely _ -> 0; Possibly _ -> 6

-- | We use a join semi-lattice on types for representations. The
--  bottom of the lattice is effectively an error (we have nothing to
--  represent), @Bool < Int@, @Int < Double@, and @forall n. n <= Text@.
--
--  The high-level goal here is that we will pick the "greater" of two
--  choices in 'bestRep'. A 'Definitely' parse result is preferred over
--  a 'Possibly' parse result. If we have two distinct 'Possibly' parse
--  results, we give up. If we have two distinct 'Definitely' parse
--  results, we are in dangerous waters: all data is parseable at
--  /both/ types, so which do we default to? The defaulting choices
--  made here are described in the previous paragraph. If there is no
--  defaulting rule, we give up (i.e. use 'T.Text' as a
--  representation).
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))

-- | A helper For the 'Semigroup' instance below.
mergeEqTypeParses ::
    forall ts.
    (RPureConstrained Parseable ts, T.Text ∈ ts) =>
    CoRec ColInfo ts
    -> CoRec ColInfo ts
    -> CoRec ColInfo ts
mergeEqTypeParses x@(CoRec _) y =
    fromMaybe definitelyText $
        coRecTraverse
            getCompose
            (coRecMapC @Parseable aux x)
  where
    definitelyText = CoRec (ColInfo (Right (ConT (mkName "Text")), Definitely T.empty))
    aux ::
        forall a.
        (Parseable a, NatToInt (RIndex a ts)) =>
        ColInfo a
        -> (Maybe :. ColInfo) a
    aux (ColInfo (_, pX)) =
        case asA' @a y of
            Nothing -> Compose Nothing
            Just (ColInfo (_, pY)) ->
                maybe
                    (Compose Nothing)
                    (Compose . Just . parsedToColInfo)
                    (parseCombine pX pY)

instance
    (T.Text ∈ ts, RPureConstrained Parseable ts) =>
    Semigroup (CoRec ColInfo ts)
    where
    (<>) :: (T.Text ∈ ts, RPureConstrained Parseable ts) => CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts
    x@(CoRec (ColInfo (tyX, pX))) <> y@(CoRec (ColInfo (tyY, pY))) =
        case lubTypes
            (either (const Nothing) Just tyX <$ pX)
            (either (const Nothing) Just tyY <$ pY) of
            Just GT -> x
            Just LT -> y
            Just EQ -> mergeEqTypeParses x y
            Nothing -> undefined -- mempty

-- | Find the best (i.e. smallest) 'CoRec' variant to represent a
--  parsed value. For inspection in GHCi after loading this module,
--  consider this example:
--
--  >>> :set -XTypeApplications
--  >>> :set -XOverloadedStrings
--  >>> import Data.Vinyl.CoRec (foldCoRec)
--  >>> foldCoRec parsedTypeRep (bestRep @CommonColumns "2.3")
--  Definitely Double
bestRep ::
    forall ts.
    ( RPureConstrained Parseable ts
    , RPureConstrained (ShowF ColInfo) ts
    , FoldRec ts ts
    , RecApplicative ts
    , T.Text ∈ ts
    ) =>
    T.Text
    -> CoRec ColInfo ts
bestRep t
    -- \| trace (show (aux t)) False = undefined
    | T.null t || t == "NA" = CoRec (parsedToColInfo (Possibly T.empty))
    | otherwise =
        coRecMapC @Parseable parsedToColInfo
            . fromMaybe (CoRec (Possibly T.empty :: Parsed T.Text))
            . firstField
            . (tryParseAll :: T.Text -> Rec (Maybe :. Parsed) ts)
            $ t
-- where
--   aux =
--       coRecMapC @Parseable parsedToColInfo
--           . fromMaybe (CoRec (Possibly T.empty :: Parsed T.Text))
--           . firstField
--           . (tryParseAll :: T.Text -> Rec (Maybe :. Parsed) ts)
{-# INLINEABLE bestRep #-}

instance
    ( RPureConstrained Parseable ts
    , FoldRec ts ts
    , RPureConstrained (ShowF ColInfo) ts
    , RecApplicative ts
    , T.Text ∈ ts
    ) =>
    ColumnTypeable (CoRec ColInfo ts)
    where
    colType (CoRec (ColInfo (t, _))) = t
    {-# INLINE colType #-}
    inferType = bestRep
    {-# INLINEABLE inferType #-}

#if !MIN_VERSION_vinyl(0,11,0)
instance forall ts. (RPureConstrained Show ts, RecApplicative ts)
  => Show (CoRec ColInfo ts) where
  show x = "(Col " ++ onCoRec @Show show x ++")"
#endif  

-- * Common Columns

-- | Common column types: 'Bool', 'Int', 'Double', 'T.Text'
type CommonColumns = [Bool, Int, Double, T.Text]

-- | Common column types including categorical types.
type CommonColumnsCat = [Bool, Int, Double, Categorical 8, T.Text]

-- | Define a set of variants that captures all possible column types.
type ColumnUniverse = CoRec ColInfo

-- | A universe of common column variants. These are the default
--  column types that @Frames@ can infer. See the
--  <http://acowley.github.io/Frames/#sec-4 Tutorial> for an example of
--  extending the default types with your own.
type Columns = ColumnUniverse CommonColumns