-- 
-- (c) Susumu Katayama 2009
--
CoreLang.lhs
extracted haskell-src-free stuff that can be used with Hat.
(This looks like Bindging.hs....)

\begin{code}
{-# OPTIONS -cpp -fglasgow-exts -XExistentialQuantification #-}
-- workaround Haddock invoked from Cabal unnecessarily chasing imports. (If cpp fails, haddock ignores the remaining part of the module.)
#ifndef __GLASGOW_HASKELL__
-- x #hoge
#endif


module MagicHaskeller.CoreLang where
import Language.Haskell.TH
import Data.Array

import Debug.Trace

import MagicHaskeller.MyDynamic

import Data.Char(chr,ord)

#ifdef FORCE
import Control.Parallel.Strategies
#endif
-- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out.

import Data.Bits
import Data.HashTable(hashInt, prime)

infixl :$


data CoreExpr = S | K | I | B | C | S' | B' | C'
                | Lambda CoreExpr | X Int -- de Bruijn notation
                | Tuple Int
                | Primitive Int
		| CoreExpr :$ CoreExpr
		  deriving (Read, Eq, Show, Ord)
-- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out.
#ifdef FORCE
instance NFData CoreExpr where
    rnf (Lambda e) = rnf e
    rnf (X i)      = rnf i
    rnf (Tuple i)  = rnf i
    rnf (Primitive _) = () -- 最後のパターンにマッチするのでこれは要らなかったか．
    rnf (c :$ d)         = rnf c `seq` rnf d
    rnf e                = ()
#endif

{- unused due to inefficiency
ceToInteger (Lambda e)    = ceToInteger e -- 型が変わっちゃうのでLambdaは無視できるはず．...  といいつつ自信無．July 24, 2008のnotesを参照. ま，hashには使えるという程度のつもり．
ceToInteger (f :$ e)      = 3 * (ceToInteger f `interleave` ceToInteger e)
ceToInteger (X n)         = 3 * toInteger n + 1
ceToInteger (Primitive n) = 3 * toInteger n + 2

0 `interleave` 0 = 0
i `interleave` j = (j `interleave` (i `shiftR` 1)) * 2 + (i `mod` 2)
-- IntegerでなくIntを使う場合，算術右シフトshiftRでなく論理右シフトを使う必要がある...のはいいけど，なぜライブラリに論理右シフトがない?
logShiftR1 n = (n `clearBit` 0) `rotateR` 1 
-}

instance Enum CoreExpr where
    fromEnum (Lambda e)    = fromIntegral prime * fromEnum e -- 型が変わっちゃうのでLambdaは無視できるはず．...  といいつつ自信無．July 24, 2008のnotesを参照. ま，hashには使えるという程度のつもり．
    fromEnum (f :$ e)      = fromEnum f #* fromEnum e
    fromEnum (X n)         = n * 0xdeadbeef
    fromEnum (Primitive n) = (-1-n) * 0xdeadbeef
m #* c = fromIntegral (hashInt m) + (c `mod` fromIntegral prime)

newtype HValue = HV (forall a. a)
instance Eq Dynamic where
    a == b = True
instance Ord Dynamic where
    compare a b = EQ
instance Read Dynamic where
    readsPrec _ str = [(error "Dynamics cannot be read.", str)]
instance Ord Exp where
    compare (VarE n0) (VarE n1) = n0 `compare` n1
    compare (VarE n0) _         = LT
    compare (ConE n0) (VarE n1) = GT
    compare (ConE n0) (ConE n1) = n0 `compare` n1
    compare (ConE n0) _         = LT
    compare (AppE _ _) (VarE _) = GT
    compare (AppE _ _) (ConE _) = GT
    compare (AppE e0 f0) (AppE e1 f1) = case compare e0 e1 of EQ -> compare f0 f1
                                                              c  -> c
    compare (AppE _ _) _        = LT

    compare a b = show a `compare` show b -- 超遅そう....
instance Read Exp where
    readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)]


type VarLib = Array Int (Exp,Dynamic)

-- x 第1引数のplはArray Con Stringなんだけど，もう全部Primitiveを使うことになったので不要．
-- exprToTHExp converts CoreLang.CoreExpr into Language.Haskell.TH.Exp
exprToTHExp :: VarLib -> CoreExpr -> Exp
exprToTHExp vl e = x2hsx (ord 'a'-1) e
    where x2hsx dep (Lambda e) = -- trace "Lambda" $
                       case x2hsx (dep+1) e of LamE pvars expr -> LamE (pvar:pvars) expr
                                               expr            -> LamE [pvar] expr
              where pvar = VarP $ mkName [chr (dep+1)]
          x2hsx dep (X n)            = VarE (mkName [chr (dep - n)])         -- X nはX 0, X 1, ....
--          x2hsx _   (Qualified con)  = VarE (mkName (pl ! con))
          x2hsx _   (Primitive n)    = fst (vl ! n)
          x2hsx dep (Primitive n :$ e0 :$ e1)
              = case fst (vl!n) of e@(VarE name) | head (nameBase name) `elem` "!@#$%&*+./<=>?\\^|-~"
                                                     -> InfixE (Just $ x2hsx dep e0) e (Just $ x2hsx dep e1)
                                   e@(ConE name) | namestr == ":"      -> case hsx1 of ListE hsxs                  -> ListE (hsx0 : hsxs)
                                                                                       ConE n | nameBase n == "[]" -> ListE [hsx0]
                                                                                       _                           -> InfixE (Just hsx0) e (Just hsx1)
                                                 | head namestr == ':' -> InfixE (Just hsx0) e (Just hsx1)
                                                 where hsx0 = x2hsx dep e0
                                                       hsx1 = x2hsx dep e1
                                                       namestr = nameBase name
                                   e             -> (e `AppE` x2hsx dep e0) `AppE` x2hsx dep e1
          x2hsx dep (e0 :$ e1)       = x2hsx dep e0 `AppE` x2hsx dep e1
          x2hsx _   e                = error ("exprToTHExp: converting" ++ show e)

\end{code}