{-# 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(..)
    -- * Check if all fields are known
  , allKnown
    -- * Parsing
  , parseFields
  , parseFieldLabel
  ) where

import Prelude hiding (lookup)

import Control.Monad (mzero)
import Control.Monad.State (State, evalState, state)
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(..), KnownRowField(..))
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
$c== :: FieldLabel -> FieldLabel -> Bool
== :: FieldLabel -> FieldLabel -> Bool
$c/= :: FieldLabel -> FieldLabel -> Bool
/= :: FieldLabel -> FieldLabel -> Bool
Eq)

{-------------------------------------------------------------------------------
  Check if all fields are known
-------------------------------------------------------------------------------}

-- | 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
postprocess ([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 {
          knownFieldName :: FieldName
knownFieldName = FieldName
nm
        , knownFieldInfo :: Type
knownFieldInfo = Type
typ
        }

    -- Assign field indices
    postprocess :: [KnownField Type] -> KnownRow Type
    postprocess :: [KnownField Type] -> KnownRow Type
postprocess [KnownField Type]
fields =
          [KnownRowField Type] -> KnownRow Type
forall a. [KnownRowField a] -> KnownRow a
KnownRow.fromList
        ([KnownRowField Type] -> KnownRow Type)
-> ([KnownField Type] -> [KnownRowField Type])
-> [KnownField Type]
-> KnownRow Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State FieldIndex [KnownRowField Type]
 -> FieldIndex -> [KnownRowField Type])
-> FieldIndex
-> State FieldIndex [KnownRowField Type]
-> [KnownRowField Type]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State FieldIndex [KnownRowField Type]
-> FieldIndex -> [KnownRowField Type]
forall s a. State s a -> s -> a
evalState ([KnownField Type] -> FieldIndex
forall a. [a] -> FieldIndex
forall (t :: * -> *) a. Foldable t => t a -> FieldIndex
length [KnownField Type]
fields)
        (State FieldIndex [KnownRowField Type] -> [KnownRowField Type])
-> ([KnownField Type] -> State FieldIndex [KnownRowField Type])
-> [KnownField Type]
-> [KnownRowField Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KnownField Type
 -> StateT FieldIndex Identity (KnownRowField Type))
-> [KnownField Type] -> State FieldIndex [KnownRowField Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM KnownField Type -> StateT FieldIndex Identity (KnownRowField Type)
assignIndex
        ([KnownField Type] -> KnownRow Type)
-> [KnownField Type] -> KnownRow Type
forall a b. (a -> b) -> a -> b
$ [KnownField Type]
fields
      where
        assignIndex :: KnownField Type -> State Int (KnownRowField Type)
        assignIndex :: KnownField Type -> StateT FieldIndex Identity (KnownRowField Type)
assignIndex KnownField Type
field = (FieldIndex -> (KnownRowField Type, FieldIndex))
-> StateT FieldIndex Identity (KnownRowField Type)
forall a.
(FieldIndex -> (a, FieldIndex)) -> StateT FieldIndex Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((FieldIndex -> (KnownRowField Type, FieldIndex))
 -> StateT FieldIndex Identity (KnownRowField Type))
-> (FieldIndex -> (KnownRowField Type, FieldIndex))
-> StateT FieldIndex Identity (KnownRowField Type)
forall a b. (a -> b) -> a -> b
$ \FieldIndex
ix -> (
              KnownField Type -> FieldIndex -> KnownRowField Type
forall a. KnownField a -> FieldIndex -> KnownRowField a
KnownRow.toKnownRowField KnownField Type
field (FieldIndex
ix FieldIndex -> FieldIndex -> FieldIndex
forall a. Num a => a -> a -> a
- FieldIndex
1)
            , FieldIndex -> FieldIndex
forall a. Enum a => a -> a
pred FieldIndex
ix
            )

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

parseFields :: TyConSubst -> ResolvedNames -> Type -> Maybe Fields
parseFields :: TyConSubst -> ResolvedNames -> Type -> Maybe Fields
parseFields TyConSubst
tcs rn :: ResolvedNames
rn@ResolvedNames{TyVar
TyCon
DataCon
Class
clsAllFields :: Class
clsKnownFields :: Class
clsKnownHash :: Class
clsRowHasField :: Class
clsSubRow :: Class
dataConDictAny :: DataCon
idEvidenceAllFields :: TyVar
idEvidenceKnownFields :: TyVar
idEvidenceKnownHash :: TyVar
idEvidenceRowHasField :: TyVar
idEvidenceSubRow :: TyVar
idMkDictAny :: TyVar
tyConDictAny :: TyCon
tyConMerge :: TyCon
tyConFieldTypes :: TyCon
tyConPair :: TyCon
tyConSimpleFieldTypes :: TyCon
clsAllFields :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsSubRow :: ResolvedNames -> Class
dataConDictAny :: ResolvedNames -> DataCon
idEvidenceAllFields :: ResolvedNames -> TyVar
idEvidenceKnownFields :: ResolvedNames -> TyVar
idEvidenceKnownHash :: ResolvedNames -> TyVar
idEvidenceRowHasField :: ResolvedNames -> TyVar
idEvidenceSubRow :: ResolvedNames -> TyVar
idMkDictAny :: ResolvedNames -> TyVar
tyConDictAny :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
..} = 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 a. a -> Maybe a
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 a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
l, Type
r)
                                [Type]
_otherwise -> Maybe (Type, Type)
forall a. Maybe a
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 a b. Maybe (a -> b) -> Maybe a -> Maybe b
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 a. a -> Maybe a
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{TyVar
TyCon
DataCon
Class
clsAllFields :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsSubRow :: ResolvedNames -> Class
dataConDictAny :: ResolvedNames -> DataCon
idEvidenceAllFields :: ResolvedNames -> TyVar
idEvidenceKnownFields :: ResolvedNames -> TyVar
idEvidenceKnownHash :: ResolvedNames -> TyVar
idEvidenceRowHasField :: ResolvedNames -> TyVar
idEvidenceSubRow :: ResolvedNames -> TyVar
idMkDictAny :: ResolvedNames -> TyVar
tyConDictAny :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
clsAllFields :: Class
clsKnownFields :: Class
clsKnownHash :: Class
clsRowHasField :: Class
clsSubRow :: Class
dataConDictAny :: DataCon
idEvidenceAllFields :: TyVar
idEvidenceKnownFields :: TyVar
idEvidenceKnownHash :: TyVar
idEvidenceRowHasField :: TyVar
idEvidenceSubRow :: TyVar
idMkDictAny :: TyVar
tyConDictAny :: TyCon
tyConMerge :: TyCon
tyConFieldTypes :: TyCon
tyConPair :: TyCon
tyConSimpleFieldTypes :: TyCon
..} 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
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FieldsCons"
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Field -> SDoc
forall a. Outputable a => a -> SDoc
ppr Field
f
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Fields -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fields
fs
  ppr Fields
FieldsNil         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FieldsNil"
  ppr (FieldsVar TyVar
var)   = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FieldsVar" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
var
  ppr (FieldsMerge Fields
l Fields
r) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Merge" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Fields -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fields
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Field"
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FieldLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabel
label
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
typ

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