{-# 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 :: 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 b a. b -> Either a b -> b
fromRight (Name -> Type
ConT (String -> Name
mkName String
"Categorical")) Either (String -> Q [Dec]) Type
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 forall a. Num a => a -> a -> a
+ Int
6) -- 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. a -> Maybe a
Just (Int
5 forall a. Num a => a -> a -> a
+ Int
uncertainty) -- Unknown type
  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
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 :: 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 (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 :: 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
    (<>) :: (T.Text ∈ ts, RPureConstrained Parseable ts) => CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts
    x :: CoRec ColInfo ts
x@(CoRec (ColInfo (Either (String -> Q [Dec]) Type
tyX, Parsed a1
pX))) <> :: (Text ∈ ts, RPureConstrained Parseable ts) =>
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 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 -> f b -> f a
<$ Parsed a1
pX)
            (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 -> f b -> f a
<$ 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. HasCallStack => a
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 :: forall (ts :: [*]).
(RPureConstrained Parseable ts,
 RPureConstrained (ShowF ColInfo) ts, FoldRec ts ts,
 RecApplicative ts, Text ∈ ts) =>
Text -> CoRec ColInfo ts
bestRep Text
t
    -- \| trace (show (aux t)) False = undefined
    | 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
-- 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 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,
 RPureConstrained (ShowF ColInfo) ts, FoldRec ts ts,
 RecApplicative ts, Text ∈ ts) =>
Text -> CoRec ColInfo ts
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