{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}

--
-- Ivory expression QuasiQuoter.
--
-- Copyright (C) 2014, Galois, Inc.
-- All rights reserved.
--

module Ivory.Language.Syntax.Concrete.QQ.ExprQQ
  ( toExp
  , fromConstDef
  , toArray
  , toStruct
  , toAddrOf
  ) where

import           Prelude ()
import           Prelude.Compat hiding (exp, init)
import qualified Prelude.Compat as P

import           Language.Haskell.TH       hiding (Stmt, Exp, Type)
import qualified Language.Haskell.TH as T
import           Language.Haskell.TH.Quote()
import           Language.Haskell.TH.Lift()

import qualified Ivory.Language.IIntegral as I
import qualified Ivory.Language.Bits      as I
import qualified  Ivory.Language.Float    as I
import qualified  Ivory.Language.Ref      as I
import qualified  Ivory.Language.MemArea  as I
import qualified  Ivory.Language.IBool    as I
import qualified  Ivory.Language.Array    as I
import qualified  Ivory.Language.Struct   as I
import qualified  Ivory.Language.CArray   as I
import qualified  Ivory.Language.Cast     as I
import qualified  Ivory.Language.Ptr      as I
import qualified  Ivory.Language.SizeOf   as I

import Ivory.Language.Syntax.Concrete.ParseAST

import Ivory.Language.Syntax.Concrete.QQ.Common
import Ivory.Language.Syntax.Concrete.QQ.TypeQQ
import Ivory.Language.Syntax.Concrete.Location

--------------------------------------------------------------------------------
-- Expressions

-- | Top-level constant definition.
fromConstDef :: ConstDef -> Q [Dec]
fromConstDef def = case def of
#if __GLASGOW_HASKELL__ >= 709
  ConstDef sym e mtype srcloc -> do
    n <- newName sym
    let def' = ValD (VarP n) (NormalB $ toExp [] e) []
    case mtype of
      Nothing -> return [def']
      Just ty -> do tyQ <- runToQ (fromType ty)
                    -- Ignore possible type variables---should be any for a
                    -- top-level constant.
                    ln <- lnPragma srcloc
                    return (ln ++ [SigD n (fst tyQ), def'])
#else
  ConstDef sym e mtype _srcloc -> do
    n <- newName sym
    let d = ValD (VarP n) (NormalB $ toExp [] e) []
    case mtype of
      Nothing -> return [d]
      Just ty -> do tyQ <- runToQ (fromType ty)
                    -- Ignore possible type variables---should be any for a
                    -- top-level constant.
                    return [SigD n (fst tyQ), d]
#endif

fromLit :: Literal -> T.Exp
fromLit lit = case lit of
  LitInteger int -> LitE (IntegerL int)
  LitFloat   f   -> LitE (RationalL (toRational f))
  LitString  str -> LitE (StringL str)

fromOpExp :: VarEnv -> ExpOp -> [Exp] -> T.Exp
fromOpExp env op args = case op of
  EqOp             -> mkInfix '(I.==?)
  NeqOp            -> mkInfix '(I./=?)
  CondOp           -> mkTert  '(I.?)

  GtOp g           -> mkInfix $ if g then '(I.>=?) else '(I.>?)
  LtOp g           -> mkInfix $ if g then '(I.<=?) else '(I.<?)

  NotOp            -> mkUn 'I.iNot
  AndOp            -> mkInfix '(I..&&)
  OrOp             -> mkInfix '(I..||)

  MulOp            -> mkInfix '(*)
  AddOp            -> mkInfix '(+)
  SubOp            -> mkInfix '(-)
  DivOp            -> mkInfix '(/)
  NegateOp         -> mkUn 'negate
  AbsOp            -> mkUn 'abs
  SignumOp         -> mkUn 'signum

  EucDivOp         -> mkInfix '(I../)   -- Euclidean division
  ModOp            -> mkInfix '(I..%)  -- Euclidean modulo

  FExpOp           -> mkUn 'P.exp
  FSqrtOp          -> mkUn 'sqrt
  FLogOp           -> mkUn 'log
  FPowOp           -> mkInfix '(**)
  FSinOp           -> mkUn 'sin
  FTanOp           -> mkUn 'tan
  FCosOp           -> mkUn 'cos
  FAsinOp          -> mkUn 'asin
  FAtanOp          -> mkUn 'atan
  FAtan2Op         -> mkBin 'I.atan2F
  FAcosOp          -> mkUn 'acos
  FSinhOp          -> mkUn 'sinh
  FTanhOp          -> mkUn 'tanh
  FCoshOp          -> mkUn 'cosh
  FAsinhOp         -> mkUn 'asinh
  FAtanhOp         -> mkUn 'atanh
  FAcoshOp         -> mkUn 'acosh

  IsNanOp          -> mkUn 'I.isnan
  IsInfOp          -> mkUn 'I.isinf
  RoundFOp         -> mkUn 'I.roundF
  CeilFOp          -> mkUn 'I.ceilF
  FloorFOp         -> mkUn 'I.floorF

  BitAndOp         -> mkInfix '(I..&)
  BitOrOp          -> mkInfix '(I..|)
  BitXorOp         -> mkInfix '(I..^)
  BitComplementOp  -> mkUn  'I.iComplement
  BitShiftLOp      -> mkBin 'I.iShiftL
  BitShiftROp      -> mkBin 'I.iShiftR

  ConstRefOp       -> mkUn 'I.constRef

  SafeCast         -> mkUn  'I.safeCast
  BitCast          -> mkUn  'I.bitCast
  CastWith         -> mkBin 'I.castWith
  TwosCompCast     -> mkUn  'I.twosComplementCast
  TwosCompRep      -> mkUn  'I.twosComplementRep

  ToIx             -> mkUn  'I.toIx
  FromIx           -> mkUn  'I.fromIx
  ToCArray         -> mkUn  'I.toCArray
  ArrayLen         -> mkUn  'I.arrayLen
  SizeOf           -> mkUn  'I.sizeOf
  NullPtr          -> mkUn  'I.nullPtr
  RefToPtr         -> mkUn  'I.refToPtr
  IxSize           -> mkUn  'I.ixSize

  where
  getArg i    = toExp env (args !! i)
  mkArg       = Just . getArg
  mkInfix op' = InfixE (mkArg 0) (VarE op') (mkArg 1)
  mkTert  op' = InfixE (mkArg 0) (VarE op') (Just $ TupE [getArg 1, getArg 2])
  mkUn    op' = AppE (VarE op') (getArg 0)
  mkBin   op' = AppE (AppE (VarE op') (getArg 0)) (getArg 1)

toExp :: VarEnv -> Exp -> T.Exp
toExp env exp = case exp of
  ExpLit lit
    -> fromLit lit
  ExpVar v
    -> VarE (mkName v)
  ExpRet
    -> VarE (mkName "return")
  ExpOp op args
    -> fromOpExp env op args
  IvoryMacroExp (v,args)
    -> callit (mkVar v) (map (toExp env) args)
  ExpDeref e
    -> VarE $ lookupDerefVar (expToArea e) env
  ExpArray e0 e1
    -> toArray (toExp env e0) (toExp env e1)
  ExpStruct e0 e1
    -> toStruct (toExp env e0) (toExp env e1)
  -- Must be a call that returns a value
  ExpCall sym args
    -> VarE $ lookupVar (expToCall sym args) env
  ExpAddrOf v
    -> toAddrOf $ VarE $ mkName v
  LocExp e
    -> toExp env (unLoc e)

--------------------------------------------------------------------------------
-- These are shared by toExp above and fromArea in BindExp.

toArray :: T.Exp -> T.Exp -> T.Exp
toArray e0 e1 = InfixE (Just e0) (VarE '(I.!)) (Just e1)

toStruct :: T.Exp -> T.Exp -> T.Exp
toStruct e0 e1 = InfixE (Just e0) (VarE '(I.~>)) (Just e1)

toAddrOf :: T.Exp -> T.Exp
toAddrOf = AppE (VarE 'I.addrOf)

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