{-# LANGUAGE RecordWildCards #-}

-- | Parsed form of a row type in the source
--
-- Intended for qualified import.
--
-- import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields)
-- import qualified Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow as ParsedRow
module Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (
    -- * Definition
    Fields     -- opaque
  , FieldLabel(..)
    -- * Query
  , lookup
  , allKnown
    -- * Parsing
  , parseFields
  , parseFieldLabel
  ) where

import Prelude hiding (lookup)

import Control.Monad (mzero)
import Data.Foldable (asum)

import Data.Record.Anon.Internal.Core.FieldName (FieldName)

import qualified Data.Record.Anon.Internal.Core.FieldName as FieldName

import Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (KnownField(..))
import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRow(..))
import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI
import Data.Record.Anon.Internal.Plugin.TC.NameResolution (ResolvedNames(..))
import Data.Record.Anon.Internal.Plugin.TC.Parsing
import Data.Record.Anon.Internal.Plugin.TC.TyConSubst (TyConSubst)

import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow as KnownRow

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

data Fields =
    FieldsCons Field Fields
  | FieldsNil
  | FieldsVar TyVar
  | FieldsMerge Fields Fields

data Field = Field FieldLabel Type

data FieldLabel =
    FieldKnown FieldName
  | FieldVar   TyVar
  deriving (FieldLabel -> FieldLabel -> Bool
(FieldLabel -> FieldLabel -> Bool)
-> (FieldLabel -> FieldLabel -> Bool) -> Eq FieldLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldLabel -> FieldLabel -> Bool
$c/= :: FieldLabel -> FieldLabel -> Bool
== :: FieldLabel -> FieldLabel -> Bool
$c== :: FieldLabel -> FieldLabel -> Bool
Eq)

{-------------------------------------------------------------------------------
  Query
-------------------------------------------------------------------------------}

-- | Find field type by name
--
-- Since records are left-biased, we report the /first/ match, independent of
-- what is in the record tail. If however we encounter an unknown (variable)
-- field, we stop the search: even if a later field matches the one we're
-- looking for, the unknown field might too and, crucially, might not have the
-- same type.
--
-- Put another way: unlike in 'checkAllFieldsKnown', we do not insist that /all/
-- fields are known here, but only the fields up to (including) the one we're
-- looking for.
--
-- Returns the index and the type of the field, if found.
lookup :: FieldName -> Fields -> Maybe (Int, Type)
lookup :: FieldName -> Fields -> Maybe (Int, Type)
lookup FieldName
nm = Int -> [Fields] -> Maybe (Int, Type)
go Int
0 ([Fields] -> Maybe (Int, Type))
-> (Fields -> [Fields]) -> Fields -> Maybe (Int, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:[])
  where
    go :: Int -> [Fields] -> Maybe (Int, Type)
    go :: Int -> [Fields] -> Maybe (Int, Type)
go Int
_ []       = Maybe (Int, Type)
forall a. Maybe a
Nothing
    go Int
i (Fields
fs:[Fields]
fss) =
        case Fields
fs of
          Fields
FieldsNil ->
            Int -> [Fields] -> Maybe (Int, Type)
go Int
i [Fields]
fss
          FieldsVar TyVar
_ ->
            -- The moment we encounter a variable (unknown part of the record),
            -- we must say that the field is unknown (see discussion above)
            Maybe (Int, Type)
forall a. Maybe a
Nothing
          FieldsCons (Field (FieldKnown FieldName
nm') Type
typ) Fields
fs' ->
            if FieldName
nm FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
nm' then
              (Int, Type) -> Maybe (Int, Type)
forall a. a -> Maybe a
Just (Int
i, Type
typ)
            else
              Int -> [Fields] -> Maybe (Int, Type)
go (Int -> Int
forall a. Enum a => a -> a
succ Int
i) (Fields
fs'Fields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:[Fields]
fss)
          FieldsCons (Field (FieldVar TyVar
_) Type
_) Fields
_ ->
            -- We must also stop when we see a field with an unknown name
            Maybe (Int, Type)
forall a. Maybe a
Nothing
          FieldsMerge Fields
l Fields
r ->
            Int -> [Fields] -> Maybe (Int, Type)
go Int
i (Fields
lFields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:Fields
rFields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:[Fields]
fss)


-- | Return map from field name to type, /if/ all fields are statically known
allKnown :: Fields -> Maybe (KnownRow Type)
allKnown :: Fields -> Maybe (KnownRow Type)
allKnown
 = [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go [] ([Fields] -> Maybe (KnownRow Type))
-> (Fields -> [Fields]) -> Fields -> Maybe (KnownRow Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:[])
  where
    go :: [KnownField Type]
       -> [Fields]
       -> Maybe (KnownRow Type)
    go :: [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go [KnownField Type]
acc []       = KnownRow Type -> Maybe (KnownRow Type)
forall a. a -> Maybe a
Just (KnownRow Type -> Maybe (KnownRow Type))
-> KnownRow Type -> Maybe (KnownRow Type)
forall a b. (a -> b) -> a -> b
$ [KnownField Type] -> KnownRow Type
forall a. [KnownField a] -> KnownRow a
KnownRow.fromList ([KnownField Type] -> [KnownField Type]
forall a. [a] -> [a]
reverse [KnownField Type]
acc)
    go [KnownField Type]
acc (Fields
fs:[Fields]
fss) =
        case Fields
fs of
          Fields
FieldsNil ->
            [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go [KnownField Type]
acc [Fields]
fss
          FieldsCons (Field (FieldKnown FieldName
nm) Type
typ) Fields
fs' ->
            [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go (FieldName -> Type -> KnownField Type
knownField FieldName
nm Type
typ KnownField Type -> [KnownField Type] -> [KnownField Type]
forall a. a -> [a] -> [a]
: [KnownField Type]
acc) (Fields
fs'Fields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:[Fields]
fss)
          FieldsCons (Field (FieldVar TyVar
_) Type
_) Fields
_ ->
            Maybe (KnownRow Type)
forall a. Maybe a
Nothing
          FieldsVar TyVar
_ ->
            Maybe (KnownRow Type)
forall a. Maybe a
Nothing
          FieldsMerge Fields
l Fields
r ->
            [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go [KnownField Type]
acc (Fields
lFields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:Fields
rFields -> [Fields] -> [Fields]
forall a. a -> [a] -> [a]
:[Fields]
fss)

    knownField :: FieldName -> Type -> KnownField Type
    knownField :: FieldName -> Type -> KnownField Type
knownField FieldName
nm Type
typ = KnownField :: forall a. FieldName -> a -> KnownField a
KnownField {
          knownFieldName :: FieldName
knownFieldName = FieldName
nm
        , knownFieldInfo :: Type
knownFieldInfo = Type
typ
        }

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

parseFields :: TyConSubst -> ResolvedNames -> Type -> Maybe Fields
parseFields :: TyConSubst -> ResolvedNames -> Type -> Maybe Fields
parseFields TyConSubst
tcs rn :: ResolvedNames
rn@ResolvedNames{Class
DataCon
TyVar
TyCon
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConDictAny :: ResolvedNames -> TyCon
idUnsafeCoerce :: ResolvedNames -> TyVar
idEvidenceSubRow :: ResolvedNames -> TyVar
idEvidenceRowHasField :: ResolvedNames -> TyVar
idEvidenceKnownHash :: ResolvedNames -> TyVar
idEvidenceKnownFields :: ResolvedNames -> TyVar
idEvidenceAllFields :: ResolvedNames -> TyVar
dataConDictAny :: ResolvedNames -> DataCon
clsSubRow :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsAllFields :: ResolvedNames -> Class
tyConSimpleFieldTypes :: TyCon
tyConPair :: TyCon
tyConFieldTypes :: TyCon
tyConMerge :: TyCon
tyConDictAny :: TyCon
idUnsafeCoerce :: TyVar
idEvidenceSubRow :: TyVar
idEvidenceRowHasField :: TyVar
idEvidenceKnownHash :: TyVar
idEvidenceKnownFields :: TyVar
idEvidenceAllFields :: TyVar
dataConDictAny :: DataCon
clsSubRow :: Class
clsRowHasField :: Class
clsKnownHash :: Class
clsKnownFields :: Class
clsAllFields :: Class
..} = Type -> Maybe Fields
go
  where
    go :: Type -> Maybe Fields
    go :: Type -> Maybe Fields
go Type
fields = [Maybe Fields] -> Maybe Fields
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
          do (Type
f, Type
fs) <- TyConSubst -> Type -> Maybe (Type, Type)
parseCons TyConSubst
tcs Type
fields
             Field
f' <- TyConSubst -> ResolvedNames -> Type -> Maybe Field
parseField TyConSubst
tcs ResolvedNames
rn Type
f
             (Field -> Fields -> Fields
FieldsCons Field
f') (Fields -> Fields) -> Maybe Fields -> Maybe Fields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Fields
go Type
fs
        , do TyConSubst -> Type -> Maybe ()
parseNil TyConSubst
tcs Type
fields
             Fields -> Maybe Fields
forall (m :: * -> *) a. Monad m => a -> m a
return Fields
FieldsNil
        , do TyVar -> Fields
FieldsVar (TyVar -> Fields) -> Maybe TyVar -> Maybe Fields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe TyVar
getTyVar_maybe Type
fields
        , do [Type]
args <- TyConSubst -> TyCon -> Type -> Maybe [Type]
parseInjTyConApp TyConSubst
tcs TyCon
tyConMerge Type
fields
             (Type
left, Type
right) <- case [Type]
args of
                                [Type
l, Type
r]     -> (Type, Type) -> Maybe (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
l, Type
r)
                                [Type]
_otherwise -> Maybe (Type, Type)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
             Fields -> Fields -> Fields
FieldsMerge (Fields -> Fields -> Fields)
-> Maybe Fields -> Maybe (Fields -> Fields)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Fields
go Type
left Maybe (Fields -> Fields) -> Maybe Fields -> Maybe Fields
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Fields
go Type
right
        ]

parseField :: TyConSubst -> ResolvedNames -> Type -> Maybe Field
parseField :: TyConSubst -> ResolvedNames -> Type -> Maybe Field
parseField TyConSubst
tcs ResolvedNames
rn Type
field = do
    (Type
label, Type
typ) <- TyConSubst -> ResolvedNames -> Type -> Maybe (Type, Type)
parsePair TyConSubst
tcs ResolvedNames
rn Type
field
    FieldLabel
label' <- Type -> Maybe FieldLabel
parseFieldLabel Type
label
    Field -> Maybe Field
forall (m :: * -> *) a. Monad m => a -> m a
return (Field -> Maybe Field) -> Field -> Maybe Field
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Type -> Field
Field FieldLabel
label' Type
typ

parseFieldLabel :: Type -> Maybe FieldLabel
parseFieldLabel :: Type -> Maybe FieldLabel
parseFieldLabel Type
label = [Maybe FieldLabel] -> Maybe FieldLabel
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
      FastString -> FieldLabel
fieldKnown (FastString -> FieldLabel) -> Maybe FastString -> Maybe FieldLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe FastString
isStrLitTy     Type
label
    , TyVar -> FieldLabel
FieldVar   (TyVar -> FieldLabel) -> Maybe TyVar -> Maybe FieldLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe TyVar
getTyVar_maybe Type
label
    ]
  where
    fieldKnown :: FastString -> FieldLabel
    fieldKnown :: FastString -> FieldLabel
fieldKnown = FieldName -> FieldLabel
FieldKnown (FieldName -> FieldLabel)
-> (FastString -> FieldName) -> FastString -> FieldLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> FieldName
FieldName.fromFastString

-- | Parse @(x := y)@
parsePair :: TyConSubst -> ResolvedNames -> Type -> Maybe (Type, Type)
parsePair :: TyConSubst -> ResolvedNames -> Type -> Maybe (Type, Type)
parsePair TyConSubst
tcs ResolvedNames{Class
DataCon
TyVar
TyCon
tyConSimpleFieldTypes :: TyCon
tyConPair :: TyCon
tyConFieldTypes :: TyCon
tyConMerge :: TyCon
tyConDictAny :: TyCon
idUnsafeCoerce :: TyVar
idEvidenceSubRow :: TyVar
idEvidenceRowHasField :: TyVar
idEvidenceKnownHash :: TyVar
idEvidenceKnownFields :: TyVar
idEvidenceAllFields :: TyVar
dataConDictAny :: DataCon
clsSubRow :: Class
clsRowHasField :: Class
clsKnownHash :: Class
clsKnownFields :: Class
clsAllFields :: Class
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConDictAny :: ResolvedNames -> TyCon
idUnsafeCoerce :: ResolvedNames -> TyVar
idEvidenceSubRow :: ResolvedNames -> TyVar
idEvidenceRowHasField :: ResolvedNames -> TyVar
idEvidenceKnownHash :: ResolvedNames -> TyVar
idEvidenceKnownFields :: ResolvedNames -> TyVar
idEvidenceAllFields :: ResolvedNames -> TyVar
dataConDictAny :: ResolvedNames -> DataCon
clsSubRow :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsAllFields :: ResolvedNames -> Class
..} Type
t = do
    [Type]
args <- TyConSubst -> TyCon -> Type -> Maybe [Type]
parseInjTyConApp TyConSubst
tcs TyCon
tyConPair Type
t
    case [Type]
args of
      [Type
_kx, Type
_ky, Type
x, Type
y] -> (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
x, Type
y)
      [Type]
_otherwise       -> Maybe (Type, Type)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Outputable
-------------------------------------------------------------------------------}

instance Outputable Fields where
  ppr :: Fields -> SDoc
ppr (FieldsCons Field
f Fields
fs) = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"FieldsCons"
      SDoc -> SDoc -> SDoc
<+> Field -> SDoc
forall a. Outputable a => a -> SDoc
ppr Field
f
      SDoc -> SDoc -> SDoc
<+> Fields -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fields
fs
  ppr Fields
FieldsNil         = String -> SDoc
text String
"FieldsNil"
  ppr (FieldsVar TyVar
var)   = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"FieldsVar" SDoc -> SDoc -> SDoc
<+> TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
var
  ppr (FieldsMerge Fields
l Fields
r) = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Merge" SDoc -> SDoc -> SDoc
<+> Fields -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fields
l SDoc -> SDoc -> SDoc
<+> Fields -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fields
r

instance Outputable Field where
  ppr :: Field -> SDoc
ppr (Field FieldLabel
label Type
typ) = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Field"
      SDoc -> SDoc -> SDoc
<+> FieldLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabel
label
      SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
typ

instance Outputable FieldLabel where
  ppr :: FieldLabel -> SDoc
ppr (FieldKnown FieldName
nm)  = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"FieldKnown" SDoc -> SDoc -> SDoc
<+> FieldName -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldName
nm
  ppr (FieldVar   TyVar
var) = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"FieldVar"   SDoc -> SDoc -> SDoc
<+> TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
var