{-  CAO Compiler
    Copyright (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>. -}

{- |
Module      :  $Header$
Description :  Queries about the target platform.
Copyright   :  (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable

Query and utility functions about the target platform.
-}

module Language.CAO.Platform.Query where

import Control.Monad 

import Data.Array
import Data.Maybe

import Language.CAO.Common.Error
import Language.CAO.Common.Literal
import Language.CAO.Common.Monad
import Language.CAO.Common.Polynomial
import Language.CAO.Common.SrcLoc
import Language.CAO.Common.Var

import Language.CAO.Index

import Language.CAO.Platform.Literals
import Language.CAO.Platform.Naming
import Language.CAO.Platform.Specification

import Language.CAO.Type

--------------------------------------------------------------------------------
-- These are the main query function which are used to encapsulate all searches.

queryTTS :: TypeTransSpec -> [TypeSpec]
queryTTS tts = 
    map snd (ubitsT tts) ++
    map snd (sbitsT tts) ++
    map snd (modT tts) ++
    map snd (vectorT tts) ++
    map snd (matrixT tts) ++
    (catMaybes $ 
        boolT tts : 
        intT tts :
        rintT tts :
        structT tts :
        modpolT tts :
        [])
{- 
 - Translations for matrices with just one dimension specified?
 - Structs of differnt sizes
 -}
query :: TranslationSpec -> Type Var -> Maybe TypeSpec 
query tspec typ = 
    either id (uncurry sizedTypeQuery) (worker typ) $ typeTransSpec tspec

    where
    worker tp = case tp of
        Int          -> Left intT
        RInt         -> Left rintT
        Bool         -> Left boolT
        Bits sg n -> let
                f = case sg of
                    U -> ubitsT
                    S -> sbitsT
            in Right (f, auxIndex n)
        Mod Nothing Nothing (Pol [Mon (CoefI m) EZero]) ->
            Right (modT, auxIndex m)
        Mod _ _ _    -> Left modpolT
        -- TODO: specific polynomial

        Vector n _   -> Right (vectorT, auxIndex n)
        Matrix n m _ -> Right (matrixT, combineM (auxIndex n) (auxIndex m))
        Struct {}    -> Left structT
        SField _ t   -> worker t
        Index _ _ t  -> worker t
        _            -> error "query: Not expectd type"

    auxIndex n =
        case n of
            IInt n' -> Simple n'
            IInd v  -> case indConst v of
                Just (IInt n') -> Simple n'
                _              -> Generic
            _       -> Generic
    
    combineM (Simple n) (Simple m) = MSize n m
    combineM _          _          = Generic

sizedTypeQuery :: (TypeTransSpec -> [(Size, TypeSpec)]) -> Size -> TypeTransSpec -> Maybe TypeSpec
sizedTypeQuery typ size ttspec = let
        t = typ ttspec
    in maybe (lookup Generic t) Just $ lookup size t

-------------------------------------------------------------------------------- 
-- Checks the query result, and raises an exception if the type is not supported.
queryType 
    :: CaoMonad m 
    => TranslationSpec -> Type Var
    -> m TypeSpec 
queryType tspec typ = maybe 
    (caoError defSrcLoc $ NotSupportedTypeErr typ) 
    return 
    $ query tspec typ

queryOperation 
    :: CaoMonad m 
    => TranslationSpec -> Type Var -> OpCode
    -> m (OpReturn, Consts, SafetyConv)
queryOperation tspec typ op = do
    m <- queryType tspec typ
    maybe (caoError defSrcLoc $ NotSupportedOp (operationNames ! op) typ)
          return
          $ operations m ! op

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

varOrMacroDecl :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
varOrMacroDecl tspec typ f1 f2 = queryType tspec typ >>= aux . declConv 
    where
    aux VarDecl   = f1
    aux MacroDecl = f2

autoOrAlloc :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
autoOrAlloc tspec typ f1 f2 = queryType tspec typ >>= aux . memoryConv 
    where
    aux Auto    = f1 
    aux AutoRef = f1
    aux Alloc   = f2

valOrRef :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
valOrRef tspec typ f1 f2 = queryType tspec typ >>= aux . memoryConv 
    where
    aux Auto    = f1 
    aux AutoRef = f2
    aux Alloc   = f2

valOrRefFuncReturn :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
valOrRefFuncReturn tspec typ f1 f2 = queryType tspec typ >>= aux . funcCall 
    where
    aux FFuncReturn = f1
    aux FFuncRef    = f2

valOrRefOpReturn :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a
valOrRefOpReturn tspec typ op f1 f2 = queryOperation tspec typ op >>= aux
    where
    aux (rc, _, _) = case rc of
        OMacroReturn -> f1
        OFuncReturn  -> f1
        OMacroRef    -> f2
        OFuncRef     -> f2

opReturnKind' :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a -> m a -> m a
opReturnKind' tspec typ op f1 f2 f3 f4 = queryOperation tspec typ op >>= aux
    where
    aux (rc, _, _) = case rc of
        OFuncReturn  -> f1
        OFuncRef     -> f2
        OMacroReturn -> f3
        OMacroRef    -> f4

valOrRefOpMacroReturn :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a
valOrRefOpMacroReturn tspec typ op f1 f2 = queryOperation tspec typ op >>= aux
    where
    aux (rc, _, _) = case rc of
        OMacroReturn    -> f1
        OMacroRef       -> f2
        _ -> caoError defSrcLoc $ NotSupportedOp (operationNames ! op) typ

globalOrInlinedField :: CaoMonad m => TranslationSpec -> m a -> m a -> m a
globalOrInlinedField tspec f1 f2 = case structFields $ globalTransSpec tspec of
    GlobalF  -> f1
    InlinedF -> f2

safeOfUnsafe :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a -> m a
safeOfUnsafe tspec typ op f1 f2 f3 = queryOperation tspec typ op >>= aux
    where
    aux (_,_, saf) = case saf of
        Safe -> f1
        Unsafe -> f2
        ArgSafe -> f3

safeOrUnsafeDefault :: CaoMonad m => TranslationSpec -> m a -> m a -> m a -> m a
safeOrUnsafeDefault tspec f1 f2 f3 = 
    case defaultSafety $ globalTransSpec tspec of
        Safe -> f1
        Unsafe -> f2
        ArgSafe -> f3

checkLiteral :: CaoMonad m => TranslationSpec -> Type Var -> m a -> (LitCheck -> m a) -> m a
checkLiteral tspec typ f1 f2 = queryType tspec typ >>= maybe f1 f2 . literal 

--------------------------------------------------------------------------------
-- Encapsulated queries

-- How to deal with literals
operandKind :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m Consts
operandKind tspec typ op = queryOperation tspec typ op >>= aux
    where
    aux (_, rc, _) = return rc
        
operandKindGeneral :: CaoMonad m => TranslationSpec -> Type Var -> m Consts
operandKindGeneral tspec typ = liftM operands $ queryType tspec typ 

codes :: CaoMonad m => TranslationSpec -> Type Var -> m String
codes tspec typ = liftM code $ queryType tspec typ

typeName :: CaoMonad m => TranslationSpec -> Type Var -> m String
typeName tspec typ = liftM nameInPlat $ queryType tspec typ

existsModWithBase :: TranslationSpec -> Integer -> Bool
existsModWithBase tspec n = maybe False (const True) $ lookup (Simple n) $ modT $ typeTransSpec tspec