{-# 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
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)

{-------------------------------------------------------------------------------
  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 [] 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
$ [KnownField Type] -> KnownRow Type
postprocess (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
        }

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