{-# OPTIONS_GHC -XMultiParamTypeClasses  
                -XTypeSynonymInstances 
                -XFlexibleInstances 
                -XNoMonomorphismRestriction
#-}

{- 

Author: Wishnu Prasetya

Copyright 2011 Wishnu Prasetya

The use of this sofware is free under the GNU General Public License
(GPL) version 3.

-}

module CTy.DSL where

import Data.Maybe
import Control.Monad.Reader
import CTy.CRule
import CTy.TestVal
import CTy.TCgen
import CTy.Utils
import CTy.Example0

-- | A class of type that has a node-like constructor.
class NODE nodeinfo branch node where
   -- | An operator, acting as a pseudo constructor to construct a node.
   (<==) :: nodeinfo -> [branch] -> node

instance NODE PartitionName (Partition tv) (Partition tv) where
   (<==) = Node

instance NODE CategoryName (Partition tv) (Category tv) where
   (<==) = Cat

(%=)  a b = Leaf a (checkTV b)

frag :: Show a => a -> TestVal
frag = Frag . show

(%%=) a b = Leaf a (checkTV . fst $ b, snd b)

tree = ClsTree

--
-- Rewriting ex0 using the above operators:
--

ex00 :: CTree TestVal
ex00 = tree [insuranceType,age,place]
   where

   insuranceType = "insType" <== [ 
     "standard" %= frag Standard,
     "comfort"  %= frag Comfort,
     "super"    %= frag Super ]

   age = "age" <== [ 
     "kid1" %= Int32 4,
     "kid2" %= Int32 16,
     adult ]
     where
     adult = "adult" <== [ "young" %= Int32 20, "old" %= Int32 66 ] 

   place = "place" <== [ 
     "city"    %= StringN 100 "Amsterdam", 
     "noncity" %= StringN 100 "Achterhoek" ]

ex01 :: CTree (TestVal,Float)
ex01 = tree [insuranceType,age,place]
   where

   insuranceType = "insType" <== [ 
     "standard" %%= (frag Standard, (0.5::Float)),
     "comfort"  %%= (frag Comfort, 0.35) ,
     "super"    %%= (frag Super,  0.15) ]

   age = "age" <== [ 
     "kid1" %%= (Int32 4, (0.2::Float)),
     "kid2" %%= (Int32 16, 0.2),
     adult ]
     where
     adult = "adult" <== [ 
        "young" %%= (Int32 20, (0.4::Float)), 
        "old"   %%= (Int32 66, 0.2) ] 

   place = "place" <== [ 
     "city"    %%= (StringN 100 "Amsterdam", (0.6::Float)) , 
     "noncity" %%=  (StringN 100 "Achterhoek", 0.4)  ]


-- =============================

-- | The class of types that has union and intersection.
class SET set where
  -- | Union
  (|+|) :: set -> set -> set
  -- | Intersection
  (|&|) :: set -> set -> set

class INCL t where
  incl :: t -> Rule

neg = Neg
(&&*) = Andp
(&&-) = Andm

instance SET Rule where
  (|+|) = Union
  (|&|) = Intersect

instance INCL CategoryName where
  incl = All

instance INCL [PartitionName] where
  incl = Include

{-
instance SET (Suite tv) where
  (|+|) =  union_
  (|&|) =  intersect_
-}

instance SET ( Reader (CTree tv) (Suite tv)) where
  u |+| v =  do {
               u_ <- u ;
               v_ <- v ;
               return (u_ `union_` v_)
             }
  u |&| v =  do {
               u_ <- u ;
               v_ <- v ;
               return (u_ `intersect_` v_)
             }


excl = neg . incl
   
orf  p q  =  (p &&* q) |+| ((p &&* neg q) |+| (neg p &&* q))
xorf p q  =  (p &&* neg q) |+| (neg p &&* q)
norf p q  =  neg p &&* neg q
impf p q  =  neg p `orf` q
equf p q  =  (p &&* q) |+| (neg p &&* neg q)

orm  p q  =  (p &&- q) |+| ((p &&- neg q) |+| (neg p &&- q))
xorm p q  =  (p &&- neg q) |+| (neg p &&- q)
norm p q  =  neg p &&- neg q
impm p q  =  neg p `orm` q
equm p q  =  (p &&- q) |+| (neg p &&- neg q)

allf = fullComb
allm = minComb

rule :: Rule -> Reader (CTree tv) (Suite tv)
rule r  = do {
    ct <- ask ;
    case chkR ct r of
      []    -> return (semRule ct r)
      (r:_) -> error ("this rule is not well-formed: " ++ show r)
  }

paddingf :: Suite tv -> Reader (CTree tv) (Suite tv)
paddingf suite = do { ct <- ask ; return (fullPadding ct suite) }

paddingm :: Suite tv -> Reader (CTree tv) (Suite tv)
paddingm suite = do { ct <- ask ; return (minPadding ct suite) }

u |*| v  = do {
   u_ <- u ;
   v_ <- v ;
   return (u_ `sJoin` v_)
   }


u `suchthat` v = do {
   u_ <- u ;
   v_ <- v ;
   return (u_ `suchthat_` v_) 
  }

u `except` v = do {
   u_ <- u ;
   v_ <- v ;
   return (u_ `except_` v_) 
  }


lift_ = return

wsort = return . wsort_
psort = return . psort_

fixorder suite = do { ct <- ask ; return (fixorder_ ct suite) }

infix  0 $$
infixl 4 `suchthat`, `except`
infixr 6 |*|, |+|, |&|, `impf`, `equf`, `impm`, `equm`
infixr 7 &&* , `orf`, `xorf`, `norf`, &&- , `orm`, `xorm`, `norm`

ct $$ rm = (runReader rm) ct




suiteEx0a = ex00 $$ rule (incl ["kid1"] &&* incl "insType")

suiteEx0b = ex00 $$ rule (incl ["kid1"] &&* incl "insType")
                    >>=
                    paddingf

suiteEx0c = ex00 $$ rule (incl ["kid1"] &&* incl "insType")
                    >>=
                    paddingm

suiteEx1a = ex00 $$  rule (incl ["kid1"] &&* incl "insType"
                          |+|
                          incl "age" &&- incl "insType" )

suiteEx1b = ex00 $$  rule (incl ["kid1"] &&* incl "insType")
                     |+|
                     rule (incl "age" &&- incl "insType")


suiteEx2 = ex00 $$ rule  (incl ["kid1"] &&* incl "insType"
                         |&|
                         incl "age" &&- incl "insType" )

suiteEx3 = ex00 $$ rule (incl ["adult"] &&* incl "insType" &&* excl ["city"])
                   `suchthat`
                   rule (incl ["standard"])

suiteEx4 = ex00 $$ rule (incl ["adult"] &&* incl "insType" &&* excl ["city"])
                   `except`
                   rule (incl ["standard"])


suiteEx5 = ex00 $$ rule (incl ["kid1"] &&* incl "insType") >>= paddingf

suiteEx6 = ex00 $$ rule (incl ["kid1"] &&* incl "insType") >>= paddingm

suiteEx7 = ex00 $$ rule (incl ["kid1"] &&* incl "insType")
                   |*|
                   rule (incl "place" &&* incl ["standard"])

suiteEx8 = ex01 $$ rule (incl ["kid1"] &&* incl "insType")
                   >>= paddingf
                   >>= psort

suiteEx8b = ex01 $$ rule (incl ["kid1"] &&* incl "insType")
                   >>= paddingf
                   >>= psort
                   >>= lift_ . take 3

suiteEx8c = ex01 $$ rule (incl ["kid1"] &&* incl "insType")
                   >>= paddingf
                   >>= psort
                   >>= lift_ . ptakeWhile_ (<= 0.03)


suiteEx8d = ex01 $$ rule (incl ["kid1"] &&* incl "insType")
                   >>= paddingf
                   >>= psort
                   >>= lift_ . take 3
                   >>= fixorder
                   >>= lift_ . strip2