AST.hs

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

module Huff.Compile.AST where

import           Data.Foldable (foldMap)
import qualified Data.Map.Strict as Map
import           Data.Monoid (Monoid(..))
import qualified Data.Text as T


data Domain a = Domain { domName      :: T.Text
                       , domObjects   :: [Object]
                       , domPreds     :: [Pred]
                       , domOperators :: [Operator a]
                       } deriving (Show)

data Problem = Problem { probInit :: [Literal]
                       , probGoal :: Term
                       } deriving (Show)

data Operator a = Operator { opName    :: !T.Text
                           , opDerived :: !Bool
                           , opParams  :: [Param]
                           , opVal     :: Maybe a
                           , opPrecond :: Term
                           , opEffects :: Effect
                           } deriving (Show,Functor,Foldable,Traversable)

type Name = T.Text

type Type = T.Text

data Typed a = Typed { tValue :: a
                     , tType  :: !Type
                     } deriving (Show,Eq,Ord)

-- | Types and all their inhabitants.
newtype TypeMap a = TypeMap { getTypeMap :: Map.Map Type [a]
                            } deriving (Show)

instance Monoid (TypeMap a) where
  mempty =
    TypeMap mempty

  mappend (TypeMap a) (TypeMap b) =
    TypeMap (Map.unionWith (++) a b)

typeMap :: [Typed a] -> TypeMap a
typeMap  = foldMap (\ Typed { .. } -> TypeMap (Map.singleton tType [tValue]) )

lookupType :: Type -> TypeMap a -> [a]
lookupType k (TypeMap m) = Map.findWithDefault [] k m


type Param  = Typed Name
type Object = Typed Name

data Term = TAnd    [Term]
          | TOr     [Term]
          | TNot    !Term
          | TImply  !Term   !Term
          | TExists [Param] !Term
          | TForall [Param] !Term
          | TLit    !Literal
            deriving (Show)

mkTAnd :: [Term] -> Term
mkTAnd [t] = t
mkTAnd ts  = TAnd ts

mkTOr :: [Term] -> Term
mkTOr [t] = t
mkTOr ts  = TOr ts

data Effect = EForall [Param] Effect
            | EWhen Term [Literal]
            | EAnd [Effect]
            | ELit Literal
              deriving (Show)

mkEWhen :: [Term] -> [Literal] -> Effect
mkEWhen [] = mkELitConj
mkEWhen ps = EWhen (mkTAnd ps)

mkELitConj :: [Literal] -> Effect
mkELitConj xs = EAnd (map ELit xs)

mkEAnd :: [Effect] -> Effect
mkEAnd [e] = e
mkEAnd es  = EAnd es

elimEAnd :: Effect -> [Effect]
elimEAnd (EAnd es) = concatMap elimEAnd es
elimEAnd e         = [e]

isELit :: Effect -> Bool
isELit ELit{} = True
isELit _      = False

data Literal = LAtom Atom
             | LNot  Atom
               deriving (Show)

data App a = App !Name [a]
            deriving (Show,Eq,Ord)

type Atom = App Arg

pattern Atom n as = App n as

negAtom :: Atom -> Atom
negAtom (Atom a as) = Atom (T.append "$not-" a) as

type Pred = App Type

pattern Pred n ts = App n ts

data Arg = AName !Name
         | AVar  !Name
           deriving (Show,Eq,Ord)