{-# LANGUAGE QuasiQuotes, UndecidableInstances, GADTs, RankNTypes, TypeSynonymInstances, FlexibleInstances, KindSignatures, 
             TypeFamilies, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, NoMonomorphismRestriction,
             TemplateHaskell,DeriveDataTypeable, ViewPatterns #-}

-- 要 language-c-quote
-- インストール：
-- cabal install language-c-quote

import Data.List
import Data.Maybe
import Control.Monad
import Control.Monad.Writer
import Control.Monad.State

import Data.Loc (noSrcLoc)
import qualified Data.Loc
import qualified Data.Symbol
import qualified Language.C.Syntax
import qualified Language.C.Syntax as C
import Language.C.Quote.GCC

newtype Exp l a = Exp {unExp::l a}

data FunName = Op String | Name String
newtype Func1 a b = Func1 (FunName, a -> b)
newtype Func2 a b c = Func2 (FunName, a -> b -> c)

-- 'tagless' representation of the language
class Lang (l :: * -> *) where
  -- | true constant
  true :: Exp l Bool
  -- | false constant
  false :: Exp l Bool
  -- | constant of type Int
  int :: Int -> Exp l Int
  -- | func e1
  func1 :: Func1 a b -> Exp l a -> Exp l b
  -- | func e1 e2
  func2 :: Func2 a b c -> Exp l a -> Exp l b -> Exp l c
  -- | if-then-else
  ifThenElse :: Exp l Bool -> Exp l Int -> Exp l Int -> Exp l Int
  -- | loop
  loop :: Exp l Int -> Exp l Int -> Exp l Int
          -> (Exp l Int -> Exp l Int -> Exp l Int) -> Exp l Int
  -- | let-binding in the target language
  let_ :: Exp l Int -> (Exp l Int -> Exp l Int) -> Exp l Int
  
  
-- mapping operators in our DSL into ones in C
toCBinOp :: String -> C.BinOp
toCBinOp "+" = C.Add
toCBinOp "-" = C.Sub
toCBinOp "*" = C.Mul
toCBinOp "/" = C.Div
toCBinOp "==" = C.Eq
toCBinOp "<" = C.Lt
toCBinOp "<=" = C.Le
toCBinOp ">" = C.Gt
toCBinOp ">=" = C.Ge
toCBinOp "&&" = C.Land
toCBinOp "||" = C.Lor
toCBinOp s = error $ "no such binary operator:"++s

toCUnOp :: String -> C.UnOp
toCUnOp "-" = C.Negate
toCUnOp "!" = C.Lnot
toCUnOp s = error $ "no such unary operator:"++s

class Monad q => MonadQ q where
  newName :: String -> q String

instance MonadQ (State [(String,Int)]) where
  newName str = do
    varmap <- get
    let cnt = fromMaybe 0 $ lookup str varmap
    put $ (str,cnt+1):deleteBy (\(a,_)(b,_)->a==b) (str,0) varmap
    return $ str ++ show cnt

instance (Monoid w, MonadQ m) => MonadQ (WriterT w m) where
  newName = lift . newName

type W a = WriterT [C.BlockItem] (State [(String,Int)]) a

newtype CGen a = CGen {unCGen :: W C.Exp}

cgen :: C.Exp -> Exp CGen a
cgen = Exp. CGen . return

cgenW :: W C.Exp -> Exp CGen a
cgenW = Exp . CGen

unExp_ :: Exp CGen a -> W C.Exp
unExp_ (Exp (CGen m)) = m

-- generate C code!!
instance Lang CGen where
  true  = cgen $ [cexp| TRUE |]
  false = cgen $ [cexp| FALSE |]
  int i   = cgen $ [cexp| $int:i |]
  func1 fun e1 = cgenW $ do 
    x <- unExp_ e1
    return $ case fun of
      Func1(Name funname,_) -> [cexp| $id:funname( $x ) |]
      Func1(Op opname,_) -> (C.UnOp (toCUnOp opname) x noSrcLoc)
  func2 fun e1 e2 = cgenW $ do
    x <- unExp_ e1; 
    y <- unExp_ e2;
    return $ case fun of
      Func2(Name funname,_) -> [cexp| $id:funname( $x, $y ) |]
      Func2(Op opname,_) -> (C.BinOp (toCBinOp opname) x y noSrcLoc)
  ifThenElse cond then_ else_ = cgenW $ do
    tmp <- newName "tmp"
    cond' <- unExp_ cond
    (thenExp, thenStmts) <- lift $ runWriterT $ unExp_ then_
    (elseExp, elseStmts) <- lift $ runWriterT $ unExp_ else_
    -- 変数宣言を生成し、if文の内部で代入する
    tell [C.BlockDecl [cdecl|
            int $id:tmp;
          |], C.BlockStm [cstm| 
            if($cond') {
              $items:thenStmts
              $id:tmp = $thenExp;
            } else { 
              $items:thenStmts
              $id:tmp = $elseExp;
            } 
          |] ]
    return [cexp| $id:tmp |]
  -- let_ = ...
  -- loop = ...

toString :: Exp CGen Int -> String
toString exp = 
  case flip evalState [] $ runWriterT $ unExp_ exp of
    (exp, blocks) -> unlines (map show blocks) ++ "return " ++ show exp ++ ";"


-- おまけ


instance Eq (Exp l a) where
  _ == _ = error "(==) is not defined"

instance (Lang l, Show a) => Show (Exp l a) where
  show _ = error "show is not defined"

instance (Lang l) => Num (Exp l Int) where
  (+) = func2 (Func2 (Op "+", (+)))
  (-) = func2 (Func2 (Op "-", (-)))
  (*) = func2 (Func2 (Op "*", (*)))
  negate = func1 (Func1 (Op "-", (\x-> -x)))
  abs = func1 (Func1 (Name "ABS", abs))
  signum x = error "signum is not defined"
  fromInteger i = int (fromInteger i)

max_ = func2 (Func2 (Name "MAX", max))
min_ = func2 (Func2 (Name "MIN", min))
not_ = func1 (Func1 (Op "!", not))

(<.), (<=.), (>.), (>=.), (==.) :: Lang l => Exp l Int -> Exp l Int -> Exp l Bool
(<.) = func2 $ Func2 (Op "<", (<))
(<=.) = func2 $ Func2 (Op "<=", (<=))
(>.) = func2 $ Func2 (Op ">", (>))
(>=.) = func2 $ Func2 (Op ">=", (>=))
(==.) = func2 $ Func2 (Op "==", (==))

infixl 6 <., <=., >., >=., ==.

(&&.), (||.) :: (Lang l) => Exp l Bool -> Exp l Bool -> Exp l Bool
(&&.) = func2 $ Func2 (Op "&&", (&&))
(||.) = func2 $ Func2 (Op "||", (||))

infixr 3 &&.
infixr 2 ||.

sum_iter :: Lang l => Exp l Int -> Exp l Int -> (Exp l Int -> Exp l Int) -> Exp l Int
sum_iter from to f = loop from to 0 (\i acc -> acc + f i)