-- 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 AbsJavaletteLight ( Tree(..)
, Prog
, Stm
, Exp
, Typ
, Ident
, johnMajorEq
, module ComposOpJavaletteLight ) where

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

import ComposOpJavaletteLight

data Tag = Prog_ | Stm_ | Exp_ | Typ_ | Ident_
type Prog = Tree 'Prog_
type Stm = Tree 'Stm_
type Exp = Tree 'Exp_
type Typ = Tree 'Typ_
type Ident = Tree 'Ident_

data Tree (a :: Tag) where
  Fun :: Typ -> Ident -> [Stm] -> Tree 'Prog_
  SAss :: Ident -> Exp -> Tree 'Stm_
  SDecl :: Typ -> Ident -> Tree 'Stm_
  SIncr :: Ident -> Tree 'Stm_
  SWhile :: Exp -> [Stm] -> Tree 'Stm_
  EDouble :: P.Double -> Tree 'Exp_
  EInt :: P.Integer -> Tree 'Exp_
  ELt :: Exp -> Exp -> Tree 'Exp_
  EPlus :: Exp -> Exp -> Tree 'Exp_
  ETimes :: Exp -> Exp -> Tree 'Exp_
  EVar :: Ident -> Tree 'Exp_
  ExpT :: Typ -> Exp -> Tree 'Exp_
  TDouble :: Tree 'Typ_
  TInt :: Tree 'Typ_
  Ident ::P.String -> Tree 'Ident_

instance Compos Tree where
  compos r a f = \case
    Fun typ x stms -> r Fun `a` f typ `a` f x `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) stms
    SAss x exp -> r SAss `a` f x `a` f exp
    SDecl typ x -> r SDecl `a` f typ `a` f x
    SIncr x -> r SIncr `a` f x
    SWhile exp stms -> r SWhile `a` f exp `a` P.foldr (\ x z -> r (:) `a` f x `a` z) (r []) stms
    ELt exp1 exp2 -> r ELt `a` f exp1 `a` f exp2
    EPlus exp1 exp2 -> r EPlus `a` f exp1 `a` f exp2
    ETimes exp1 exp2 -> r ETimes `a` f exp1 `a` f exp2
    EVar x -> r EVar `a` f x
    ExpT typ exp -> r ExpT `a` f typ `a` f exp
    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
    Fun typ x stms -> opar . P.showString "Fun" . P.showChar ' ' . P.showsPrec 1 typ . P.showChar ' ' . P.showsPrec 1 x . P.showChar ' ' . P.showsPrec 1 stms . cpar
    SAss x exp -> opar . P.showString "SAss" . P.showChar ' ' . P.showsPrec 1 x . P.showChar ' ' . P.showsPrec 1 exp . cpar
    SDecl typ x -> opar . P.showString "SDecl" . P.showChar ' ' . P.showsPrec 1 typ . P.showChar ' ' . P.showsPrec 1 x . cpar
    SIncr x -> opar . P.showString "SIncr" . P.showChar ' ' . P.showsPrec 1 x . cpar
    SWhile exp stms -> opar . P.showString "SWhile" . P.showChar ' ' . P.showsPrec 1 exp . P.showChar ' ' . P.showsPrec 1 stms . cpar
    EDouble d -> opar . P.showString "EDouble" . P.showChar ' ' . P.showsPrec 1 d . cpar
    EInt n -> opar . P.showString "EInt" . P.showChar ' ' . P.showsPrec 1 n . cpar
    ELt exp1 exp2 -> opar . P.showString "ELt" . P.showChar ' ' . P.showsPrec 1 exp1 . P.showChar ' ' . P.showsPrec 1 exp2 . cpar
    EPlus exp1 exp2 -> opar . P.showString "EPlus" . P.showChar ' ' . P.showsPrec 1 exp1 . P.showChar ' ' . P.showsPrec 1 exp2 . cpar
    ETimes exp1 exp2 -> opar . P.showString "ETimes" . P.showChar ' ' . P.showsPrec 1 exp1 . P.showChar ' ' . P.showsPrec 1 exp2 . cpar
    EVar x -> opar . P.showString "EVar" . P.showChar ' ' . P.showsPrec 1 x . cpar
    ExpT typ exp -> opar . P.showString "ExpT" . P.showChar ' ' . P.showsPrec 1 typ . P.showChar ' ' . P.showsPrec 1 exp . cpar
    TDouble -> P.showString "TDouble"
    TInt -> P.showString "TInt"
    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 (Fun _ _ _) = 1
index (SAss _ _) = 2
index (SDecl _ _) = 3
index (SIncr _) = 4
index (SWhile _ _) = 5
index (EDouble _) = 6
index (EInt _) = 7
index (ELt _ _) = 8
index (EPlus _ _) = 9
index (ETimes _ _) = 10
index (EVar _) = 11
index (ExpT _ _) = 12
index (TDouble ) = 13
index (TInt ) = 14
index (Ident _) = 15

johnMajorEq :: Tree a -> Tree b -> P.Bool
johnMajorEq (Fun typ x stms) (Fun typ_ x_ stms_) = typ == typ_ && x == x_ && stms == stms_
johnMajorEq (SAss x exp) (SAss x_ exp_) = x == x_ && exp == exp_
johnMajorEq (SDecl typ x) (SDecl typ_ x_) = typ == typ_ && x == x_
johnMajorEq (SIncr x) (SIncr x_) = x == x_
johnMajorEq (SWhile exp stms) (SWhile exp_ stms_) = exp == exp_ && stms == stms_
johnMajorEq (EDouble d) (EDouble d_) = d == d_
johnMajorEq (EInt n) (EInt n_) = n == n_
johnMajorEq (ELt exp1 exp2) (ELt exp1_ exp2_) = exp1 == exp1_ && exp2 == exp2_
johnMajorEq (EPlus exp1 exp2) (EPlus exp1_ exp2_) = exp1 == exp1_ && exp2 == exp2_
johnMajorEq (ETimes exp1 exp2) (ETimes exp1_ exp2_) = exp1 == exp1_ && exp2 == exp2_
johnMajorEq (EVar x) (EVar x_) = x == x_
johnMajorEq (ExpT typ exp) (ExpT typ_ exp_) = typ == typ_ && exp == exp_
johnMajorEq TDouble TDouble = P.True
johnMajorEq TInt TInt = P.True
johnMajorEq (Ident str) (Ident str_) = str == str_
johnMajorEq _ _ = P.False

compareSame :: Tree c -> Tree c -> P.Ordering
compareSame (Fun typ x stms) (Fun typ_ x_ stms_) = P.mappend (P.compare typ typ_) (P.mappend (P.compare x x_) (P.compare stms stms_))
compareSame (SAss x exp) (SAss x_ exp_) = P.mappend (P.compare x x_) (P.compare exp exp_)
compareSame (SDecl typ x) (SDecl typ_ x_) = P.mappend (P.compare typ typ_) (P.compare x x_)
compareSame (SIncr x) (SIncr x_) = P.compare x x_
compareSame (SWhile exp stms) (SWhile exp_ stms_) = P.mappend (P.compare exp exp_) (P.compare stms stms_)
compareSame (EDouble d) (EDouble d_) = P.compare d d_
compareSame (EInt n) (EInt n_) = P.compare n n_
compareSame (ELt exp1 exp2) (ELt exp1_ exp2_) = P.mappend (P.compare exp1 exp1_) (P.compare exp2 exp2_)
compareSame (EPlus exp1 exp2) (EPlus exp1_ exp2_) = P.mappend (P.compare exp1 exp1_) (P.compare exp2 exp2_)
compareSame (ETimes exp1 exp2) (ETimes exp1_ exp2_) = P.mappend (P.compare exp1 exp1_) (P.compare exp2 exp2_)
compareSame (EVar x) (EVar x_) = P.compare x x_
compareSame (ExpT typ exp) (ExpT typ_ exp_) = P.mappend (P.compare typ typ_) (P.compare exp exp_)
compareSame TDouble TDouble = P.EQ
compareSame TInt TInt = P.EQ
compareSame (Ident str) (Ident str_) = P.compare str str_
compareSame _ _ = P.error "BNFC error: compareSame"