Type.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}

module Descript.BasicInj.Data.Type
  ( Symbol (..)
  , RecordType (..)
  , RecordDecl (..)
  , RecordCtx (..)
  , recordCtxTypes
  , lookupRecordType
  , recTypeHasHead
  ) where

import Descript.BasicInj.Data.Atom
import Descript.Misc
import Data.Semigroup as S
import Data.Monoid as M
import Data.List hiding (head)
import Prelude hiding (head)

-- | A record type.
data RecordType an
  = RecordType
  { recordTypeAnn :: an
  , head :: FSymbol an -- ^ Identifies and distinguishes the type.
  , properties :: [Symbol an] -- ^ All instances should have properties with these keys.
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A record declaration.
data RecordDecl an
  = RecordDecl
  { recordDeclAnn :: an
  , recordDeclType :: RecordType an
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | Contains a source file's data definitions.
-- These record types encode the types of records which can be used
-- throughout the rest of the source.
-- Each of them should have a different head.
data RecordCtx an
  = RecordCtx
  { recordCtxAnn :: an
  , recordCtxDecls :: [RecordDecl an]
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance (Semigroup an) => Semigroup (RecordCtx an) where
  RecordCtx xAnn xds <> RecordCtx yAnn yds
    = RecordCtx (xAnn S.<> yAnn) (xds ++ yds)

instance (Monoid an) => Monoid (RecordCtx an) where
  mempty = RecordCtx mempty []
  RecordCtx xAnn xds `mappend` RecordCtx yAnn yds
    = RecordCtx (xAnn M.<> yAnn) (xds ++ yds)

instance Ann RecordCtx where
  getAnn = recordCtxAnn

instance Ann RecordDecl where
  getAnn = recordDeclAnn

instance Ann RecordType where
  getAnn = recordTypeAnn

instance Printable RecordCtx where
  aprintRec sub (RecordCtx _ recordDecls) = pintercal "\n" $ map sub recordDecls

instance Printable RecordDecl where
  aprintRec sub (RecordDecl _ recordType) = sub recordType M.<> "."

instance Printable RecordType where
  aprintRec sub recordType = sub (head recordType) M.<> propsPrinted
    where propsPrinted = "[" M.<> pintercal ", " propPrinteds M.<> "]"
          propPrinteds = map sub $ properties recordType

instance (Show an) => Summary (RecordCtx an) where
  summaryRec = pprintSummaryRec

instance (Show an) => Summary (RecordDecl an) where
  summaryRec = pprintSummaryRec

instance (Show an) => Summary (RecordType an) where
  summaryRec = pprintSummaryRec

-- | The record types declared in the context.
recordCtxTypes :: RecordCtx an -> [RecordType an]
recordCtxTypes = map recordDeclType . recordCtxDecls

-- | Finds the record type with the given head in the context.
lookupRecordType :: FSymbol an -> RecordCtx an -> Maybe (RecordType an)
lookupRecordType head' = find (recTypeHasHead head') . recordCtxTypes

-- | Does the record type have the given head?
recTypeHasHead :: FSymbol an1 -> RecordType an2 -> Bool
recTypeHasHead head' record = head' =@= head record