{-# LANGUAGE BangPatterns, CPP, ConstraintKinds, DataKinds,
             FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs,
             KindSignatures, LambdaCase, MultiParamTypeClasses,
             OverloadedStrings, QuasiQuotes, RankNTypes,
             ScopedTypeVariables, TemplateHaskell, TypeApplications,
             TypeFamilies, TypeOperators, 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 qualified Data.Text as T
import Data.Vinyl
import Data.Vinyl.CoRec
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel (RIndex, NatToInt)
import Frames.ColumnTypeable
import Frames.Categorical
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 :: forall a. Parseable a => Text -> (:.) Maybe Parsed a
inferParseable = forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(Parseable a, MonadPlus m) =>
Text -> m (Parsed a)
parse

-- | Helper to call 'inferParseable' on variants of a 'CoRec'.
inferParseable' :: Parseable a => (((->) T.Text) :. (Maybe :. Parsed)) a
inferParseable' :: forall a. Parseable a => (:.) ((->) Text) (Maybe :. Parsed) a
inferParseable' = forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall a. Parseable a => Text -> (:.) Maybe Parsed a
inferParseable

-- * Record Helpers

tryParseAll :: forall ts. (RecApplicative ts, RPureConstrained Parseable ts)
            => T.Text -> Rec (Maybe :. Parsed) ts
tryParseAll :: forall (ts :: [*]).
(RecApplicative ts, RPureConstrained Parseable ts) =>
Text -> Rec (Maybe :. Parsed) ts
tryParseAll = forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose Rec ((->) Text :. (Maybe :. Parsed)) ts
funs
  where funs :: Rec (((->) T.Text) :. (Maybe :. Parsed)) ts
        funs :: Rec ((->) Text :. (Maybe :. Parsed)) ts
funs = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
rpureConstrained @Parseable forall a. Parseable a => (:.) ((->) Text) (Maybe :. Parsed) a
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 a -> String
show (ColInfo (Either (String -> Q [Dec]) Type
t,Parsed a
p)) = String
"(ColInfo {"
                         forall a. [a] -> [a] -> [a]
++ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const String
"cat") forall a. Show a => a -> String
show Either (String -> Q [Dec]) Type
t
                         forall a. [a] -> [a] -> [a]
++ String
", "
                         forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Parsed a -> a
discardConfidence Parsed a
p) forall a. [a] -> [a] -> [a]
++String
"})"

parsedToColInfo :: Parseable a => Parsed a -> ColInfo a
parsedToColInfo :: forall a. Parseable a => Parsed a -> ColInfo a
parsedToColInfo Parsed a
x = case forall k a (b :: k). Const a b -> a
getConst Const (Either (String -> Q [Dec]) Type) a
rep of
                      Left String -> Q [Dec]
dec -> forall a. (Either (String -> Q [Dec]) Type, Parsed a) -> ColInfo a
ColInfo (forall a b. a -> Either a b
Left String -> Q [Dec]
dec, Parsed a
x)
                      Right Type
ty ->
                        forall a. (Either (String -> Q [Dec]) Type, Parsed a) -> ColInfo a
ColInfo (forall a b. b -> Either a b
Right Type
ty, Parsed a
x)
  where rep :: Const (Either (String -> Q [Dec]) Type) a
rep = forall a.
Parseable a =>
Parsed a -> Const (Either (String -> Q [Dec]) Type) a
representableAsType Parsed a
x

parsedTypeRep :: ColInfo a -> Parsed Type
parsedTypeRep :: forall a. ColInfo a -> Parsed Type
parsedTypeRep (ColInfo (Either (String -> Q [Dec]) Type
t,Parsed a
p)) =
  forall a b. a -> b -> a
const (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (Name -> Type
ConT (String -> Name
mkName String
"Categorical"))) forall a. a -> a
id Either (String -> Q [Dec]) Type
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsed a
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 :: Parsed (Maybe Type) -> Maybe Int
orderParsePriorities Parsed (Maybe Type)
x =
  case forall a. Parsed a -> a
discardConfidence Parsed (Maybe Type)
x of
    Maybe Type
Nothing -> forall a. a -> Maybe a
Just Int
1 -- categorical variable
    Just Type
t
      | Type
t forall a. Eq a => a -> a -> Bool
== Type
tyText -> forall a. a -> Maybe a
Just (Int
0 forall a. Num a => a -> a -> a
+ Int
uncertainty)
      | Type
t forall a. Eq a => a -> a -> Bool
== Type
tyDbl -> forall a. a -> Maybe a
Just (Int
2 forall a. Num a => a -> a -> a
+ Int
uncertainty)
      | Type
t forall a. Eq a => a -> a -> Bool
== Type
tyInt -> forall a. a -> Maybe a
Just (Int
3 forall a. Num a => a -> a -> a
+ Int
uncertainty)
      | Type
t forall a. Eq a => a -> a -> Bool
== Type
tyBool -> forall a. a -> Maybe a
Just (Int
4 forall a. Num a => a -> a -> a
+ Int
uncertainty)
      | Bool
otherwise -> forall a. Maybe a
Nothing
  where tyText :: Type
tyText = Name -> Type
ConT (String -> Name
mkName String
"Text")
        tyDbl :: Type
tyDbl = Name -> Type
ConT (String -> Name
mkName String
"Double")
        tyInt :: Type
tyInt = Name -> Type
ConT (String -> Name
mkName String
"Int")
        tyBool :: Type
tyBool = Name -> Type
ConT (String -> Name
mkName String
"Bool")
        uncertainty :: Int
uncertainty = case Parsed (Maybe Type)
x of Definitely Maybe Type
_ -> Int
0; Possibly Maybe Type
_ -> Int
5

-- | 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 :: Parsed (Maybe Type) -> Parsed (Maybe Type) -> Maybe Ordering
lubTypes Parsed (Maybe Type)
x Parsed (Maybe Type)
y = forall a. Ord a => a -> a -> Ordering
compare forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsed (Maybe Type) -> Maybe Int
orderParsePriorities Parsed (Maybe Type)
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsed (Maybe Type) -> Maybe Int
orderParsePriorities Parsed (Maybe Type)
x

instance (T.Text ∈ ts, RPureConstrained Parseable ts) => Monoid (CoRec ColInfo ts) where
  mempty :: CoRec ColInfo ts
mempty = forall {k} (a1 :: k) (b :: [k]) (a :: k -> *).
RElem a1 b (RIndex a1 b) =>
a a1 -> CoRec a b
CoRec (forall a. (Either (String -> Q [Dec]) Type, Parsed a) -> ColInfo a
ColInfo ( forall a b. b -> Either a b
Right (Name -> Type
ConT (String -> Name
mkName String
"Text")), forall a. a -> Parsed a
Possibly Text
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 :: forall (ts :: [*]).
(RPureConstrained Parseable ts, Text ∈ ts) =>
CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts
mergeEqTypeParses x :: CoRec ColInfo ts
x@(CoRec ColInfo a1
_) CoRec ColInfo ts
y = forall a. a -> Maybe a -> a
fromMaybe CoRec ColInfo ts
definitelyText
                                forall a b. (a -> b) -> a -> b
$ forall {k} (h :: * -> *) (f :: k -> *) (g :: k -> *) (ts :: [k]).
Functor h =>
(forall (x :: k). f x -> h (g x)) -> CoRec f ts -> h (CoRec g ts)
coRecTraverse forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose
                                                (forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *)
       (g :: k -> *).
RPureConstrained c ts =>
(forall (x :: k). (x ∈ ts, c x) => f x -> g x)
-> CoRec f ts -> CoRec g ts
coRecMapC @Parseable forall a.
(Parseable a, NatToInt (RIndex a ts)) =>
ColInfo a -> (:.) Maybe ColInfo a
aux CoRec ColInfo ts
x)
  where definitelyText :: CoRec ColInfo ts
definitelyText = forall {k} (a1 :: k) (b :: [k]) (a :: k -> *).
RElem a1 b (RIndex a1 b) =>
a a1 -> CoRec a b
CoRec (forall a. (Either (String -> Q [Dec]) Type, Parsed a) -> ColInfo a
ColInfo (forall a b. b -> Either a b
Right (Name -> Type
ConT (String -> Name
mkName String
"Text")), forall a. a -> Parsed a
Definitely Text
T.empty))
        aux :: forall a. (Parseable a, NatToInt (RIndex a ts))
            => ColInfo a -> (Maybe :. ColInfo) a
        aux :: forall a.
(Parseable a, NatToInt (RIndex a ts)) =>
ColInfo a -> (:.) Maybe ColInfo a
aux (ColInfo (Either (String -> Q [Dec]) Type
_, Parsed a
pX)) =
          case forall {k} (t :: k) (ts :: [k]) (f :: k -> *).
NatToInt (RIndex t ts) =>
CoRec f ts -> Maybe (f t)
asA' @a CoRec ColInfo ts
y of
            Maybe (ColInfo a)
Nothing -> forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall a. Maybe a
Nothing
            Just (ColInfo (Either (String -> Q [Dec]) Type
_, Parsed a
pY)) ->
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall a. Maybe a
Nothing)
                    (forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parseable a => Parsed a -> ColInfo a
parsedToColInfo)
                    (forall a (m :: * -> *).
(Parseable a, MonadPlus m) =>
Parsed a -> Parsed a -> m (Parsed a)
parseCombine Parsed a
pX Parsed a
pY)

instance (T.Text ∈ ts, RPureConstrained Parseable ts)
  => Semigroup (CoRec ColInfo ts) where
  x :: CoRec ColInfo ts
x@(CoRec (ColInfo (Either (String -> Q [Dec]) Type
tyX, Parsed a1
pX))) <> :: CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts
<> y :: CoRec ColInfo ts
y@(CoRec (ColInfo (Either (String -> Q [Dec]) Type
tyY, Parsed a1
pY))) =
    case Parsed (Maybe Type) -> Parsed (Maybe Type) -> Maybe Ordering
lubTypes (forall a b. a -> b -> a
const (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either (String -> Q [Dec]) Type
tyX) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsed a1
pX)
                  (forall a b. a -> b -> a
const (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either (String -> Q [Dec]) Type
tyY) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsed a1
pY) of
      Just Ordering
GT -> CoRec ColInfo ts
x
      Just Ordering
LT -> CoRec ColInfo ts
y
      Just Ordering
EQ -> forall (ts :: [*]).
(RPureConstrained Parseable ts, Text ∈ ts) =>
CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts
mergeEqTypeParses CoRec ColInfo ts
x CoRec ColInfo ts
y
      Maybe Ordering
Nothing -> forall a. Monoid a => a
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,
            FoldRec ts ts,
            RecApplicative ts, T.Text ∈ ts)
        => T.Text -> CoRec ColInfo ts
bestRep :: forall (ts :: [*]).
(RPureConstrained Parseable ts, FoldRec ts ts, RecApplicative ts,
 Text ∈ ts) =>
Text -> CoRec ColInfo ts
bestRep Text
t
  | Text -> Bool
T.null Text
t Bool -> Bool -> Bool
|| Text
t forall a. Eq a => a -> a -> Bool
== Text
"NA" = (forall {k} (a1 :: k) (b :: [k]) (a :: k -> *).
RElem a1 b (RIndex a1 b) =>
a a1 -> CoRec a b
CoRec (forall a. Parseable a => Parsed a -> ColInfo a
parsedToColInfo (forall a. a -> Parsed a
Possibly Text
T.empty)))
  | Bool
otherwise = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *)
       (g :: k -> *).
RPureConstrained c ts =>
(forall (x :: k). (x ∈ ts, c x) => f x -> g x)
-> CoRec f ts -> CoRec g ts
coRecMapC @Parseable forall a. Parseable a => Parsed a -> ColInfo a
parsedToColInfo
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (forall {k} (a1 :: k) (b :: [k]) (a :: k -> *).
RElem a1 b (RIndex a1 b) =>
a a1 -> CoRec a b
CoRec (forall a. a -> Parsed a
Possibly Text
T.empty :: Parsed T.Text))
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ts :: [k]) (f :: k -> *).
FoldRec ts ts =>
Rec (Maybe :. f) ts -> Maybe (CoRec f ts)
firstField
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (ts :: [*]).
(RecApplicative ts, RPureConstrained Parseable ts) =>
Text -> Rec (Maybe :. Parsed) ts
tryParseAll :: T.Text -> Rec (Maybe :. Parsed) ts)
              forall a b. (a -> b) -> a -> b
$ Text
t
{-# INLINABLE bestRep #-}

instance (RPureConstrained Parseable ts, FoldRec ts ts,
          RecApplicative ts, T.Text ∈ ts) =>
    ColumnTypeable (CoRec ColInfo ts) where
  colType :: CoRec ColInfo ts -> Either (String -> Q [Dec]) Type
colType (CoRec (ColInfo (Either (String -> Q [Dec]) Type
t, Parsed a1
_))) = Either (String -> Q [Dec]) Type
t
  {-# INLINE colType #-}
  inferType :: Text -> CoRec ColInfo ts
inferType = forall (ts :: [*]).
(RPureConstrained Parseable ts, FoldRec ts ts, RecApplicative ts,
 Text ∈ ts) =>
Text -> CoRec ColInfo ts
bestRep
  {-# INLINABLE 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