Data.hs

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

-- | Defines "free" versions of datatypes, which are very general, and
-- can be refined to more constrained, specific datatypes.
module Descript.Free.Data
  ( module Descript.Free.Data.Import
  , module Descript.Free.Data.Atom
  , Property (..)
  , Record (..)
  , Part (..)
  , Value (..)
  , ValueRefinement (..)
  , RecordDecl (..)
  , Reducer (..)
  , Query (..)
  , TopLevel (..)
  , mkTopLevel
  , topLevelToModuleDecl
  , topLevelToImportDecl
  , topLevelToRecordDecl
  , topLevelToReducer
  , topLevelIsPhaseSep
  , topLevelToQuery
  , valueToPropKey
  ) where

import Prelude hiding (head)
import Descript.Free.Data.Import
import Descript.Free.Data.Atom
import Descript.Misc
import Data.Monoid
import Data.List.NonEmpty (NonEmpty (..))

-- | A free property. Can be refined into a property declaration for a
-- record type (as just a key), or an actual property (as a define).
data Property an
  = PropertySingle (Value an)
  | PropertyDef an (Symbol an) (Value an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A free record. Can be refined into a regular record, or a record type.
data Record an
  = Record
  { recordAnn :: an
  , head :: Symbol an
  , properties :: [Property an]
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A free part. Can be refined into a regular part, input part, or
-- output part.
data Part an
  = PartPrim (Prim an)
  | PartRecord (Record an)
  | PartPropPath (PropPath an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A free value. Can be refined into a regular value, input value, or
-- output value.
data Value an
  = Value an [Part an]
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | Converts a value into a top-level declaration.
-- Useful for parsing - parse a value, then a refinement.
data ValueRefinement an
  = ToRecordDecl -- ^ Refine into a record type declaration.
  -- | Refine into a reducer with the given output,
  -- where the value being converted is the input.
  | ToReducer (Value an)
  | ToQuery -- ^ Refine into a query.
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | Declares a record type to be used in values.
data RecordDecl an
  = RecordDecl an (Value an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A reducer. It takes a value and converts it into a new value.
-- Programs are interpreted/compiled by taking values and reducing them -
-- the program starts with a value representing a question or source
-- code, and reducers convert this value into the answer or compiled code.
-- This is like a function, or even better, an implicit conversion.
data Reducer an
  = Reducer
  { reducerAnn :: an
  , input :: Value an
  , output :: Value an
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | Declares a program's query.
data Query an
  = Query an (Value an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A top-level declaration in source.
data TopLevel an
  = TopLevelModuleDecl (ModuleDecl an)
  | TopLevelImportDecl (ImportDecl an)
  | TopLevelRecordDecl (RecordDecl an)
  | TopLevelReducer (Reducer an)
  | TopLevelPhaseSep an
  | TopLevelQuery (Query an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance Ann TopLevel where
  getAnn (TopLevelModuleDecl x) = getAnn x
  getAnn (TopLevelImportDecl x) = getAnn x
  getAnn (TopLevelRecordDecl x) = getAnn x
  getAnn (TopLevelReducer x) = getAnn x
  getAnn (TopLevelPhaseSep ann) = ann
  getAnn (TopLevelQuery x) = getAnn x

instance Ann RecordDecl where
  getAnn (RecordDecl ann _) = ann

instance Ann Reducer where
  getAnn = reducerAnn

instance Ann Query where
  getAnn (Query ann _) = ann

instance Ann Value where
  getAnn (Value ann _) = ann

instance Ann Part where
  getAnn (PartPrim x) = getAnn x
  getAnn (PartRecord x) = getAnn x
  getAnn (PartPropPath x) = getAnn x

instance Ann Record where
  getAnn = recordAnn

instance Ann Property where
  getAnn (PropertySingle x) = getAnn x
  getAnn (PropertyDef ann _ _) = ann

instance Printable TopLevel where
  aprintRec sub (TopLevelModuleDecl decl) = sub decl
  aprintRec sub (TopLevelImportDecl decl) = sub decl
  aprintRec sub (TopLevelRecordDecl decl) = sub decl
  aprintRec sub (TopLevelReducer reducer) = sub reducer
  aprintRec _ (TopLevelPhaseSep _) = "---"
  aprintRec sub (TopLevelQuery query) = sub query

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

instance Printable Reducer where
  aprintRec sub reducer = sub (input reducer) <> ": " <> sub (output reducer)

instance Printable Query where
  aprintRec sub (Query _ value) = sub value <> "?"

instance Printable Value where
  aprintRec sub (Value _ parts) = pintercal " | " $ map sub parts

instance Printable Part where
  aprintRec sub (PartPrim prim) = sub prim
  aprintRec sub (PartRecord record) = sub record
  aprintRec sub (PartPropPath path) = sub path

instance Printable Record where
  aprintRec sub record = sub (head record) <> propsPrinted
    where propsPrinted = "[" <> pintercal ", " propPrinteds <> "]"
          propPrinteds = map sub $ properties record

instance Printable Property where
  aprintRec sub (PropertySingle x) = sub x
  aprintRec sub (PropertyDef _ key val) = sub key <> ": " <> sub val

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

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

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

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

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

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

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

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

-- | Creates a top-level declaration, which starts with the given value
-- and then has the given refinement.
mkTopLevel :: an -> Value an -> ValueRefinement an -> TopLevel an
mkTopLevel ann val ToRecordDecl = TopLevelRecordDecl $ RecordDecl ann val
mkTopLevel ann val (ToReducer out) = TopLevelReducer $ Reducer ann val out
mkTopLevel ann val ToQuery = TopLevelQuery $ Query ann val

topLevelToModuleDecl :: TopLevel an -> Maybe (ModuleDecl an)
topLevelToModuleDecl (TopLevelModuleDecl decl) = Just decl
topLevelToModuleDecl _ = Nothing

topLevelToImportDecl :: TopLevel an -> Maybe (ImportDecl an)
topLevelToImportDecl (TopLevelImportDecl decl) = Just decl
topLevelToImportDecl _ = Nothing

topLevelToRecordDecl :: TopLevel an -> Maybe (RecordDecl an)
topLevelToRecordDecl (TopLevelRecordDecl decl) = Just decl
topLevelToRecordDecl _ = Nothing

topLevelToReducer :: TopLevel an -> Maybe (Reducer an)
topLevelToReducer (TopLevelReducer reducer) = Just reducer
topLevelToReducer _ = Nothing

topLevelIsPhaseSep :: TopLevel an -> Bool
topLevelIsPhaseSep (TopLevelPhaseSep _) = True
topLevelIsPhaseSep _ = False

topLevelToQuery :: TopLevel an -> Maybe (Query an)
topLevelToQuery (TopLevelQuery query') = Just query'
topLevelToQuery _ = Nothing

valueToPropKey :: Value an -> Maybe (Symbol an)
valueToPropKey (Value _ [PartPropPath (PropPath _ (PathElemImp sym :| []))])
  = Just sym
valueToPropKey _ = Nothing