-----------------------------------------------------------------------------
-- |
-- Module      :  P
-- Copyright   :  (c) Masahiro Sakai 2007-2009
-- License     :  BSD3-style (see LICENSE)
-- 
-- Maintainer:    masahiro.sakai@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable

{-# LANGUAGE TypeOperators, GADTs, EmptyDataDecls, MultiParamTypeClasses
  , TypeSynonymInstances #-}

module P
  ( Sen
  , IV
  , CN
  , Adj
  , (:/)
  , (://)
  , Cat (..)
  , cat_Sen
  , cat_IV
  , cat_CN
  , cat_Adj
  , T
  , TV
  , IAV
  , cat_T
  , cat_TV
  , cat_IAV
  , Det
  , DTV
  , TTV
  , PP
  , cat_Det
  , cat_DTV
  , cat_PP
  , PronounNo
  , P (..)
  , PAny (..)
  , F5
  , F6
  , F8 (..)
  , F9 (..)
  , F10 (..)
  ) where
import Expr

-----------------------------------------------------------------------------

infixl 1 :/
infixl 1 ://

-- 型レベルでの範疇の表現
data Sen -- 文。本来はtと書かれるけど小文字が使えないので
data IV  -- 動詞句, 自動詞: walk
data CN  -- 普通名詞(句): man
data Adj -- 形容詞? (定義が載っていなかった)
data (:/) a b
data (://) a b

-- 範疇を型レベルだけでなく値レベルでも表現
data Cat a where
    Sen   :: Cat Sen
    IV    :: Cat IV
    CN    :: Cat CN
    Adj   :: Cat Adj
    (:/)  :: Cat a -> Cat b -> Cat (a :/ b)
    (://) :: Cat a -> Cat b -> Cat (a :// b)
cat_Sen = Sen
cat_IV  = IV
cat_CN  = CN
cat_Adj = Adj

type T   = Sen :/ IV -- 名詞句, 固有名詞: John, he
type TV  = IV :/ T   -- 他動詞(句): find
type IAV = IV :/ IV  -- 動詞句修飾の副詞(句): slowly
cat_T   = cat_Sen :/ cat_IV
cat_TV  = cat_IV :/ cat_T
cat_IAV = cat_IV :/ cat_IV

-- FIXME: 定義が載っていなかった範疇
type Det = T  :/ CN -- 冠詞
type DTV = TV :/ T  -- ditransitive verb : 名詞句を２つ取る他動詞
type TTV = TV :/ T  -- to transitive verb : DTVと名詞句の順序が逆?
type PP  = IV :/ TV -- prepositional phrase?: by John
cat_Det = cat_T  :/ cat_CN
cat_DTV = cat_TV :/ cat_T
cat_PP  = cat_IV :/ cat_TV

-----------------------------------------------------------------------------

type PronounNo = Int

-- 範疇がcである表現
data P c where
    -- 基本表現
    B  :: Cat c -> String -> P c
    He :: PronounNo -> P T

    -- 統語規則
    -- F1はないのね
    F2  :: P Det -> P CN -> P T
    F3  :: PronounNo -> P CN -> P Sen -> P CN
    F4  :: P T -> P IV -> P Sen
    F5  :: F5 c => P (c :/ T) -> P T -> P c
    F6  :: F6 c a => P (c :/ a) -> P a -> P c
    F7  :: P IAV -> P IV -> P IV
    F8  :: F8 c => P c -> P c -> P c -- and
    F9  :: F9 c => P c -> P c -> P c -- or
    F10 :: F10 c => PronounNo -> P T -> P c -> P c -- 文の中への量化
    F11 :: P T -> P IV -> P Sen
    F12 :: P T -> P IV -> P Sen
    F13 :: P T -> P IV -> P Sen
    F14 :: P T -> P IV -> P Sen
    F15 :: P T -> P IV -> P Sen
    F16 :: P (IV :/ Sen) -> P Sen -> P IV
    F17 :: P (IV :// IV) -> P IV -> P IV
    -- F18はないのね
    F19 :: P TV -> P IV
    F20 :: P DTV -> P T -> P TV
    F21 :: P DTV -> P T -> P TV
    F22 :: P DTV -> P TTV
    F23 :: P PP -> P TV -> P IV
    F24 :: P (PP :/ T) -> P T -> P PP
    F25 :: P TV -> P Adj

data PAny where
    PAny :: P a -> PAny

class F5 c 
instance F5 IV  -- T5
instance F5 IAV -- T6

class F6 c a
instance F6 Sen Sen -- T9
instance F6 IV Adj  -- T18

class F8 c where f8 :: Cat c
instance F8 Sen where f8 = cat_Sen
instance F8 IV where f8 = cat_IV

class F9 c where f9 :: Cat c
instance F9 Sen where f9 = cat_Sen
instance F9 IV where f9 = cat_IV
instance F9 T where f9 = cat_T

class F10 c where f10 :: Cat c
instance F10 Sen where f10 = cat_Sen
instance F10 CN where f10 = cat_CN
instance F10 IV where f10 = cat_IV

-----------------------------------------------------------------------------

-- Ughhh!!
instance Show (P c) where
    showsPrec _ (B _ s)     = showString s
    showsPrec d (He n)      = c1 d "He" n
    showsPrec d (F2 x y)    = c2 d "F2" x y
    showsPrec d (F3 n x y)  = c3 d "F3" n x y
    showsPrec d (F4 x y)    = c2 d "F4" x y
    showsPrec d (F5 x y)    = c2 d "F5" x y
    showsPrec d (F6 x y)    = c2 d "F6" x y
    showsPrec d (F7 x y)    = c2 d "F7" x y
    showsPrec d (F8 x y)    = c2 d "F8" x y
    showsPrec d (F9 x y)    = c2 d "F9" x y
    showsPrec d (F10 n x y) = c3 d "F10" n x y
    showsPrec d (F11 x y)   = c2 d "F11" x y
    showsPrec d (F12 x y)   = c2 d "F12" x y
    showsPrec d (F13 x y)   = c2 d "F13" x y
    showsPrec d (F14 x y)   = c2 d "F14" x y
    showsPrec d (F15 x y)   = c2 d "F15" x y
    showsPrec d (F16 x y)   = c2 d "F16" x y
    showsPrec d (F17 x y)   = c2 d "F17" x y
    showsPrec d (F19 x)     = c1 d "F19" x
    showsPrec d (F20 x y)   = c2 d "F20" x y
    showsPrec d (F21 x y)   = c2 d "F21" x y
    showsPrec d (F22 x)     = c1 d "F22" x
    showsPrec d (F23 x y)   = c2 d "F23" x y
    showsPrec d (F24 x y)   = c2 d "F24" x y
    showsPrec d (F25 x)     = c1 d "F25" x

instance Show PAny where
  showsPrec d (PAny p) = c1 d "PAny" p

c1 :: (Show x) => Int -> String -> x -> ShowS
c1 d con x =
    showParen (d > app_prec) $
    showString con
    . showChar ' ' . showsPrec (app_prec+1) x
c2 :: (Show x, Show y) => Int -> String -> x -> y -> ShowS
c2 d con x y =
    showParen (d > app_prec) $
    showString con
    . showChar ' ' . showsPrec (app_prec+1) x
    . showChar ' ' . showsPrec (app_prec+1) y
c3 :: (Show x, Show y, Show z) => Int -> String -> x -> y -> z -> ShowS
c3 d con x y z =
    showParen (d > app_prec) $
    showString con
    . showChar ' ' . showsPrec (app_prec+1) x
    . showChar ' ' . showsPrec (app_prec+1) y
    . showChar ' ' . showsPrec (app_prec+1) z
app_prec :: Int
app_prec = 10