{-# 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
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
  where
    go :: Int -> [Fields] -> Maybe (Int, Type)
    go :: Int -> [Fields] -> Maybe (Int, Type)
go Int
_ []       = 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)
            forall a. Maybe a
Nothing
          FieldsCons (Field (FieldKnown FieldName
nm') Type
typ) Fields
fs' ->
            if FieldName
nm forall a. Eq a => a -> a -> Bool
== FieldName
nm' then
              forall a. a -> Maybe a
Just (Int
i, Type
typ)
            else
              Int -> [Fields] -> Maybe (Int, Type)
go (forall a. Enum a => a -> a
succ Int
i) (Fields
fs'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
            forall a. Maybe a
Nothing
          FieldsMerge Fields
l Fields
r ->
            Int -> [Fields] -> Maybe (Int, Type)
go Int
i (Fields
lforall a. a -> [a] -> [a]
:Fields
rforall 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 [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
  where
    go :: [KnownField Type]
       -> [Fields]
       -> Maybe (KnownRow Type)
    go :: [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go [KnownField Type]
acc []       = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [KnownField a] -> KnownRow a
KnownRow.fromList (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 forall a. a -> [a] -> [a]
: [KnownField Type]
acc) (Fields
fs'forall a. a -> [a] -> [a]
:[Fields]
fss)
          FieldsCons (Field (FieldVar TyVar
_) Type
_) Fields
_ ->
            forall a. Maybe a
Nothing
          FieldsVar TyVar
_ ->
            forall a. Maybe a
Nothing
          FieldsMerge Fields
l Fields
r ->
            [KnownField Type] -> [Fields] -> Maybe (KnownRow Type)
go [KnownField Type]
acc (Fields
lforall a. a -> [a] -> [a]
:Fields
rforall a. a -> [a] -> [a]
:[Fields]
fss)

    knownField :: FieldName -> Type -> KnownField Type
    knownField :: FieldName -> Type -> KnownField Type
knownField FieldName
nm Type
typ = 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
TyCon
TyVar
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 = 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') 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
             forall (m :: * -> *) a. Monad m => a -> m a
return Fields
FieldsNil
        , do TyVar -> Fields
FieldsVar 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]     -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type
l, Type
r)
                                [Type]
_otherwise -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
             Fields -> Fields -> Fields
FieldsMerge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Fields
go Type
left 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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
      FastString -> FieldLabel
fieldKnown forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe FastString
isStrLitTy     Type
label
    , TyVar -> FieldLabel
FieldVar   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 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
TyCon
TyVar
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] -> forall a. a -> Maybe a
Just (Type
x, Type
y)
      [Type]
_otherwise       -> forall a. Maybe a
Nothing

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

instance Outputable Fields where
  ppr :: Fields -> SDoc
ppr (FieldsCons Field
f Fields
fs) = SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"FieldsCons"
      SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Field
f
      SDoc -> SDoc -> 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 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"FieldsVar" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyVar
var
  ppr (FieldsMerge Fields
l Fields
r) = SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Merge" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Fields
l SDoc -> SDoc -> 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 forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Field"
      SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr FieldLabel
label
      SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
typ

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