-- For GHC version 7.10 or higher

{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

module AbsProlog ( Tree(..)
, Database
, Clause
, Predicate
, Term
, Atom
, Var
, List
, Ident
, UIdent
, LIdent
, Wild
, johnMajorEq
, module ComposOpProlog ) where

import Prelude ((.), (>), (&&), (==))
import Prelude ((.), (>), (&&), (==))
import qualified Prelude as P

import ComposOpProlog

data Tag = Database_ | Clause_ | Predicate_ | Term_ | Atom_ | Var_ | List_ | Ident_ | UIdent_ | LIdent_ | Wild_
type Database = Tree 'Database_
type Clause = Tree 'Clause_
type Predicate = Tree 'Predicate_
type Term = Tree 'Term_
type Atom = Tree 'Atom_
type Var = Tree 'Var_
type List = Tree 'List_
type Ident = Tree 'Ident_
type UIdent = Tree 'UIdent_
type LIdent = Tree 'LIdent_
type Wild = Tree 'Wild_

data Tree (a :: Tag) where
  Db :: [Clause] -> Tree 'Database_
  Directive :: [Predicate] -> Tree 'Clause_
  Fact :: Predicate -> Tree 'Clause_
  Rule :: Predicate -> [Predicate] -> Tree 'Clause_
  APred :: Atom -> Tree 'Predicate_
  CPred :: Atom -> [Term] -> Tree 'Predicate_
  Complex :: Atom -> [Term] -> Tree 'Term_
  TAtom :: Atom -> Tree 'Term_
  TList :: List -> Tree 'Term_
  VarT :: Var -> Tree 'Term_
  Atm :: LIdent -> Tree 'Atom_
  EAtm :: Ident -> Tree 'Atom_
  A :: Wild -> Tree 'Var_
  V :: UIdent -> Tree 'Var_
  Cons :: [Term] -> List -> Tree 'List_
  ConsV :: [Term] -> Var -> Tree 'List_
  Empty :: Tree 'List_
  Enum :: [Term] -> Tree 'List_
  Ident ::P.String -> Tree 'Ident_
  UIdent ::P.String -> Tree 'UIdent_
  LIdent ::P.String -> Tree 'LIdent_
  Wild ::P.String -> Tree 'Wild_

instance Compos Tree where
  compos r a f = \case
    Db clauses -> r Db `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) clauses
    Directive predicates -> r Directive `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) predicates
    Fact predicate -> r Fact `a` f predicate
    Rule predicate predicates -> r Rule `a` f predicate `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) predicates
    APred atom -> r APred `a` f atom
    CPred atom terms -> r CPred `a` f atom `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) terms
    Complex atom terms -> r Complex `a` f atom `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) terms
    TAtom atom -> r TAtom `a` f atom
    TList list -> r TList `a` f list
    VarT var -> r VarT `a` f var
    Atm lIdent -> r Atm `a` f lIdent
    EAtm x -> r EAtm `a` f x
    A wild -> r A `a` f wild
    V uIdent -> r V `a` f uIdent
    Cons terms list -> r Cons `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) terms `a` f list
    ConsV terms var -> r ConsV `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) terms `a` f var
    Enum terms -> r Enum `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) terms
    t -> r t

instance P.Show (Tree c) where
  showsPrec n = \case
    Ident str -> opar . P.showString "Ident" . P.showChar ' ' . P.showsPrec 1 str . cpar
    UIdent str -> opar . P.showString "UIdent" . P.showChar ' ' . P.showsPrec 1 str . cpar
    LIdent str -> opar . P.showString "LIdent" . P.showChar ' ' . P.showsPrec 1 str . cpar
    Wild str -> opar . P.showString "Wild" . P.showChar ' ' . P.showsPrec 1 str . cpar
    Db clauses -> opar . P.showString "Db" . P.showChar ' ' . P.showsPrec 1 clauses . cpar
    Directive predicates -> opar . P.showString "Directive" . P.showChar ' ' . P.showsPrec 1 predicates . cpar
    Fact predicate -> opar . P.showString "Fact" . P.showChar ' ' . P.showsPrec 1 predicate . cpar
    Rule predicate predicates -> opar . P.showString "Rule" . P.showChar ' ' . P.showsPrec 1 predicate . P.showChar ' ' . P.showsPrec 1 predicates . cpar
    APred atom -> opar . P.showString "APred" . P.showChar ' ' . P.showsPrec 1 atom . cpar
    CPred atom terms -> opar . P.showString "CPred" . P.showChar ' ' . P.showsPrec 1 atom . P.showChar ' ' . P.showsPrec 1 terms . cpar
    Complex atom terms -> opar . P.showString "Complex" . P.showChar ' ' . P.showsPrec 1 atom . P.showChar ' ' . P.showsPrec 1 terms . cpar
    TAtom atom -> opar . P.showString "TAtom" . P.showChar ' ' . P.showsPrec 1 atom . cpar
    TList list -> opar . P.showString "TList" . P.showChar ' ' . P.showsPrec 1 list . cpar
    VarT var -> opar . P.showString "VarT" . P.showChar ' ' . P.showsPrec 1 var . cpar
    Atm lIdent -> opar . P.showString "Atm" . P.showChar ' ' . P.showsPrec 1 lIdent . cpar
    EAtm x -> opar . P.showString "EAtm" . P.showChar ' ' . P.showsPrec 1 x . cpar
    A wild -> opar . P.showString "A" . P.showChar ' ' . P.showsPrec 1 wild . cpar
    V uIdent -> opar . P.showString "V" . P.showChar ' ' . P.showsPrec 1 uIdent . cpar
    Cons terms list -> opar . P.showString "Cons" . P.showChar ' ' . P.showsPrec 1 terms . P.showChar ' ' . P.showsPrec 1 list . cpar
    ConsV terms var -> opar . P.showString "ConsV" . P.showChar ' ' . P.showsPrec 1 terms . P.showChar ' ' . P.showsPrec 1 var . cpar
    Empty -> P.showString "Empty"
    Enum terms -> opar . P.showString "Enum" . P.showChar ' ' . P.showsPrec 1 terms . cpar
    where
    opar = if n > 0 then P.showChar '(' else P.id
    cpar = if n > 0 then P.showChar ')' else P.id

instance P.Eq (Tree c) where (==) = johnMajorEq

instance P.Ord (Tree c) where compare x y = P.compare (index x) (index y) `P.mappend` compareSame x y

index :: Tree c -> P.Int
index (Db _) = 1
index (Directive _) = 2
index (Fact _) = 3
index (Rule _ _) = 4
index (APred _) = 5
index (CPred _ _) = 6
index (Complex _ _) = 7
index (TAtom _) = 8
index (TList _) = 9
index (VarT _) = 10
index (Atm _) = 11
index (EAtm _) = 12
index (A _) = 13
index (V _) = 14
index (Cons _ _) = 15
index (ConsV _ _) = 16
index (Empty ) = 17
index (Enum _) = 18
index (Ident _) = 19
index (UIdent _) = 20
index (LIdent _) = 21
index (Wild _) = 22

johnMajorEq :: Tree a -> Tree b -> P.Bool
johnMajorEq (Db clauses) (Db clauses_) = clauses == clauses_
johnMajorEq (Directive predicates) (Directive predicates_) = predicates == predicates_
johnMajorEq (Fact predicate) (Fact predicate_) = predicate == predicate_
johnMajorEq (Rule predicate predicates) (Rule predicate_ predicates_) = predicate == predicate_ && predicates == predicates_
johnMajorEq (APred atom) (APred atom_) = atom == atom_
johnMajorEq (CPred atom terms) (CPred atom_ terms_) = atom == atom_ && terms == terms_
johnMajorEq (Complex atom terms) (Complex atom_ terms_) = atom == atom_ && terms == terms_
johnMajorEq (TAtom atom) (TAtom atom_) = atom == atom_
johnMajorEq (TList list) (TList list_) = list == list_
johnMajorEq (VarT var) (VarT var_) = var == var_
johnMajorEq (Atm lIdent) (Atm lIdent_) = lIdent == lIdent_
johnMajorEq (EAtm x) (EAtm x_) = x == x_
johnMajorEq (A wild) (A wild_) = wild == wild_
johnMajorEq (V uIdent) (V uIdent_) = uIdent == uIdent_
johnMajorEq (Cons terms list) (Cons terms_ list_) = terms == terms_ && list == list_
johnMajorEq (ConsV terms var) (ConsV terms_ var_) = terms == terms_ && var == var_
johnMajorEq Empty Empty = P.True
johnMajorEq (Enum terms) (Enum terms_) = terms == terms_
johnMajorEq (Ident str) (Ident str_) = str == str_
johnMajorEq (UIdent str) (UIdent str_) = str == str_
johnMajorEq (LIdent str) (LIdent str_) = str == str_
johnMajorEq (Wild str) (Wild str_) = str == str_
johnMajorEq _ _ = P.False

compareSame :: Tree c -> Tree c -> P.Ordering
compareSame (Db clauses) (Db clauses_) = P.compare clauses clauses_
compareSame (Directive predicates) (Directive predicates_) = P.compare predicates predicates_
compareSame (Fact predicate) (Fact predicate_) = P.compare predicate predicate_
compareSame (Rule predicate predicates) (Rule predicate_ predicates_) = P.mappend (P.compare predicate predicate_) (P.compare predicates predicates_)
compareSame (APred atom) (APred atom_) = P.compare atom atom_
compareSame (CPred atom terms) (CPred atom_ terms_) = P.mappend (P.compare atom atom_) (P.compare terms terms_)
compareSame (Complex atom terms) (Complex atom_ terms_) = P.mappend (P.compare atom atom_) (P.compare terms terms_)
compareSame (TAtom atom) (TAtom atom_) = P.compare atom atom_
compareSame (TList list) (TList list_) = P.compare list list_
compareSame (VarT var) (VarT var_) = P.compare var var_
compareSame (Atm lIdent) (Atm lIdent_) = P.compare lIdent lIdent_
compareSame (EAtm x) (EAtm x_) = P.compare x x_
compareSame (A wild) (A wild_) = P.compare wild wild_
compareSame (V uIdent) (V uIdent_) = P.compare uIdent uIdent_
compareSame (Cons terms list) (Cons terms_ list_) = P.mappend (P.compare terms terms_) (P.compare list list_)
compareSame (ConsV terms var) (ConsV terms_ var_) = P.mappend (P.compare terms terms_) (P.compare var var_)
compareSame Empty Empty = P.EQ
compareSame (Enum terms) (Enum terms_) = P.compare terms terms_
compareSame (Ident str) (Ident str_) = P.compare str str_
compareSame (UIdent str) (UIdent str_) = P.compare str str_
compareSame (LIdent str) (LIdent str_) = P.compare str str_
compareSame (Wild str) (Wild str_) = P.compare str str_
compareSame _ _ = P.error "BNFC error: compareSame"