{-  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 :  Parsing of the platform configuration.
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

-}

module Language.CAO.Parser.Config ( loadConfig ) where

import Control.Monad

import Data.Array
import Data.Char (isSpace, isAlphaNum, isNumber)
import Data.ConfigFile
import Data.Function (on)
import Data.List(foldl', sortBy)
import Data.Maybe (fromMaybe)

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

loadConfig :: String -> IO TranslationSpec
loadConfig confFile = do
    readStr <- readfile emptyCP confFile
    case readStr of
        Left  e  -> configError $ show e
        Right cf -> let 
                gpec = readGlobalSpec cf
                spec = emptyTranslationSpec { globalTransSpec = gpec }
                fpec = readType cf (defaultSafety gpec)
            in return $  foldl' fpec spec (sections cf)

readGlobalSpec :: ConfigParser -> GlobalTransSpec
readGlobalSpec cff = GlobalTransSpec {
      initProcName    = readOptionDefault word'       "initproc"
    , disposeProcName = readOptionDefault word'       "disposeproc"
    , tpPrefix        = readOptionDefault word'       "typeprefix"
    , callPrefix      = readOptionDefault word'       "callprefix"
    , defaultHeader   = readOptionDefault word'       "header"
    , defaultSafety   = readOptionDefault parseSafety "safety"
    , structFields    = readOptionDefault parseFields "fields"
    , wordSize        = readOptionDefault parseWord   "word"}
    where
    readOptionDefault p = run p . readOption cff "DEFAULT"

readType :: ConfigParser -> SafetyConv -> TranslationSpec -> SectionSpec -> TranslationSpec
readType cff safe tinfo sspec = updateTypes typinfo tinfo nrWords caotypes
    where
    typinfo = TypeSpec { 
          nameInPlat  = sspec
        , headerFile  = readOptionS word'       "header"
        , code        = readOptionS word'       "code"
        , declConv    = readOptionS parseCall   "declaration"
        , memoryConv  = readOptionS parseMemory "memory"
        , funcCall    = readOptionS parseFReturn  "return"
        , operands    = readOptionS parseConsts "operands"
        , literal     = Nothing
        , operations  = array (0, 36) (auxOpers opers) } 

    nrWords  = readOptionS parseSize            "size"
    caotypes = readOptionS parseType            "type"
    opcall   = readOptionS parseOpCall          "opcall"
    opers    = readOptionS (parseOperations opcall (operands typinfo) safe) "operations"

    readOptionS p = run p . readOption cff sspec

-- Not very elegant solution
    auxOpers = worker 0 . sortBy (compare `on` fst)
    worker :: Int -> [(OpCode, (OpReturn, Consts, SafetyConv))] -> [(OpCode, Maybe (OpReturn, Consts, SafetyConv))]
    worker 37 [] = []
    worker 37 _ = error "Not expected configuration"
    worker n  [] = (n, Nothing) : worker (n+1) []
    worker n l@((i, v):lst) = if n < i then (n, Nothing) : worker (n+1) l else (i, Just v) : worker (n+1) lst


updateTypes :: TypeSpec -> TranslationSpec -> Maybe (NumberOfWords, Maybe WordsPerChunk) -> [(String, Size)] -> TranslationSpec
updateTypes typinfo tspec nrWords = foldl' worker tspec
    where
    wordSz :: Maybe WordSize
    wordSz = wordSize $ globalTransSpec tspec

    worker :: TranslationSpec -> (String, Size) -> TranslationSpec
    worker ti (typ, siz) = case typ of
        "bool"   -> tworker ti typ (\ ti' -> ti' { boolT = Just typinfo } ) boolT
        "struct" -> tworker ti typ (\ ti' -> ti' { structT = Just typinfo } ) structT
        "modpol" -> tworker ti typ (\ ti' -> ti' { modpolT = Just typinfo } ) modpolT
        "int"    -> tworker ti typ (\ ti' -> ti' { intT = Just $ typinfo { literal = checkInt wordSz nrWords } } ) intT
        "rint"   -> tworker ti typ (\ ti' -> ti' { rintT = Just $ typinfo { literal = checkInt wordSz nrWords } } ) rintT
        "ubits"  -> ti { typeTransSpec = (typeTransSpec ti) { 
                            ubitsT = (siz, typinfo { literal = checkBits wordSz siz nrWords }) : ubitsT (typeTransSpec ti) } }
        "sbits"  -> ti { typeTransSpec = (typeTransSpec ti) { 
                            sbitsT = (siz, typinfo { literal = checkBits wordSz siz nrWords }) : sbitsT (typeTransSpec ti) } }
        "vector" -> ti { typeTransSpec = (typeTransSpec ti) { 
                            vectorT = (siz, typinfo) : vectorT (typeTransSpec ti) } }
        "matrix" -> ti { typeTransSpec = (typeTransSpec ti) { 
                            matrixT = (siz, typinfo) : matrixT (typeTransSpec ti) } }
        "mod"    -> ti { typeTransSpec = (typeTransSpec ti) { 
                            modT = (siz, typinfo { literal = checkMod wordSz siz nrWords }) : modT (typeTransSpec ti) } }
        _        -> configError $ "Not known type identifier: " ++ typ

    tworker :: TranslationSpec -> String -> (TypeTransSpec -> TypeTransSpec) -> (TypeTransSpec -> Maybe TypeSpec) -> TranslationSpec
    tworker ti typ f1 sel = maybe 
        (ti {typeTransSpec = f1 (typeTransSpec ti) }) 
        (configError $ "Configuration already found for type: " ++ typ) 
        (sel (typeTransSpec ti))

configError :: String -> a
configError err = error $ 
    "[ERROR] There was an error in the configuration file:\n" ++ err

readOption :: ConfigParser -> SectionSpec -> OptionSpec -> String
readOption cff sspec opt = 
    either (configError . ("Option not found: " ++) . show) id
           ((get cff sspec opt)::Either CPError String)

--------------------------------------------------------------------------------
parseType :: ReadC [(String, Size)]
parseType     = sepBy (comp (,) (word id) (option Generic (brackets tsize))) comma

parseCall :: ReadC VarDeclaration
parseCall
      = keyword VarDecl   "var" 
    <|> keyword MacroDecl "macro"

parseMemory :: ReadC VarMemory
parseMemory   
      = seqOpt (keyword Auto    "auto") 
               (keyword AutoRef "ref") 
                        Auto 
    <|>         keyword Alloc   "alloc"

parseFReturn :: ReadC FuncReturn
parseFReturn    
      = keyword FFuncReturn "val"
    <|> keyword FFuncRef    "ref"
    
parseOpCall :: ReadC OpReturn
parseOpCall   
      = seqOpt (keyword OMacroRef    "macro") 
               (keyword OMacroReturn "val") 
                    OMacroRef 
    <|> seqOpt (keyword OFuncRef     "func") 
               (keyword OFuncReturn  "val")
                    OFuncRef

parseSafety :: ReadC SafetyConv
parseSafety 
      = keyword Safe    "safe" 
    <|> keyword Unsafe  "unsafe" 
    <|> keyword ArgSafe "arg_safe"

parseConsts :: ReadC Consts
parseConsts 
      = keyword GlobalV "vars_global" 
    <|> keyword LocalV  "vars_local" 
    <|> keyword Inlined "inlined" 
    <|> keyword Mixed   "mixed"

parseFields :: ReadC FieldsConv
parseFields 
      = keyword GlobalF  "global" 
    <|> keyword InlinedF "inlined"

parseWord :: ReadC (Maybe WordSize)
parseWord 
      = keyword Nothing "undefined" 
    <|> apply (Just . fromInteger) number

parseSize :: ReadC (Maybe (NumberOfWords, Maybe WordsPerChunk))
parseSize 
      = keyword Nothing "undefined" 
    <|> apply (Just . (\x -> (x, Nothing)) . fromInteger) number 
    <|> comp (\ _ (n1, n2) -> Just (fromInteger n1, Just $ fromInteger n2)) 
              (keyword () "split") 
              (pair number number)

parseOperations :: OpReturn -> Consts -> SafetyConv -> ReadC [(OpCode, (OpReturn, Consts, SafetyConv))]
parseOperations defaultRet operand safe = 
    sepBy (comp (,) parseOperation 
                    (option (defaultRet, operand, safe) (parens $ 
                        perm3 comma 
                            parseOpCall 
                            parseConsts 
                            parseSafety 
                            defaultRet operand safe))) comma 

parseOperation :: ReadC OpCode
parseOperation = word aux
    where
    aux w = fromMaybe 
        (parseError $ "Not expected operation name: `" ++ w ++ "'") $ getCode w
    
--------------------------------------------------------------------------------
type ReadC a = String -> Either String (String, a)

parseError :: String -> a
parseError err = error $ 
    "[ERROR] There was a parsing error while reading the configuration file:\n" ++
    err

run :: ReadC a -> String -> a
run p str = case p str of
    Left err -> parseError err
    Right (str', v) -> 
        if null str' 
        then v 
        else parseError $ "Trailing string not expected: `" ++ str' ++ 
                "' while reading `" ++ str ++ "'"

sepBy :: ReadC a -> ReadC sep -> ReadC [a]
sepBy p psep str = do
    (str', v) <- p str
    if null str' then return (str', [v]) 
        else do
            (str'', _) <- psep str'
            (str''', lv) <- sepBy p psep str''
            return (str''', v : lv)

comp :: (a -> b -> c) -> ReadC a -> ReadC b -> ReadC c
comp f p1 p2 str = do
    (str1, v1) <- p1 str
    (str2, v2) <- p2 str1
    return (str2, f v1 v2)

inject :: a -> ReadC a
inject d = \ s -> return (s, d)

(<|>) :: ReadC a -> ReadC a -> ReadC a
(p1 <|> p2) str = p1 str `mplus` p2 str

option :: a -> ReadC a -> ReadC a
option a p str = p str `mplus` return (str, a)

comma :: ReadC ()
comma (',' : str) = white str
comma str         = Left $ "Expected comma before `" ++ str ++ "'"

white :: ReadC ()
white str = return (dropWhile isSpace str, ()) 

delim :: Char -> Char -> ReadC a -> ReadC a
delim co cc p (co' : str) | co == co' = do
    (str', _) <- white str
    (str'', v) <- p str'
    when (null str'' || head str'' /= cc) $ Left $ 
        "Expected delimiters `" ++ [co] ++ "' `" ++ [cc] ++ "' around `" ++ 
            str' ++ "'"
    (str''', _) <- white (tail str'')
    return (str''', v)
delim co cc _ _ = Left $ "Expected delimiters `" ++ [co] ++ "' `" ++ [cc] ++ "'"

parens :: ReadC a -> ReadC a
parens = delim '(' ')' 

brackets :: ReadC a -> ReadC a
brackets = delim '[' ']'

number :: ReadC Integer
number str = do
    let (n, str') = span isNumber str
    when (null n) $ Left $ "Expected number in `" ++ str ++ "'"
    (str'', _) <- white str'
    return (str'', (read n::Integer))

keyword :: a -> String -> ReadC a
keyword val key str = do
    (str', w) <- word id str
    if key == w 
        then return (str', val) 
        else Left $ 
            "Expected keyword `" ++ key ++ "'. Got `" ++ w ++ "' instead."

word :: (String -> b) -> ReadC b
word f str = do
    let (w, str') = span (\ c -> isAlphaNum c || c == '.' || c == '_') str
    (ww, _) <- white str'
    return (ww, f w)

word' :: ReadC String
word' = word id

tsize :: ReadC Size
tsize str = do
    (str', n1) <- option 0 number str
    if n1 == 0 
        then return (str', Generic)
        else if not (null str') && head str' == 'x'
            then do
                (str'', _) <- white (tail str')
                (str''', n2) <- option 0 number str''
                if n2 == 0 
                    then Left "Invalid size (0)"
                    else return (str''', MSize n1 n2)
            else return (str', Simple n1)

perm2 :: ReadC () -> ReadC a -> ReadC b -> a -> b -> ReadC (a, b)
perm2 sep p1 p2 d1 d2 = 
    comp (,) p1 (comp (curry snd) sep p2) <|> 
    comp (flip (,)) p2 (comp (curry snd) sep p1) <|>
    comp (,) p1 (inject d2) <|>
    comp (,) (inject d1) p2

perm3 :: ReadC () -> ReadC a -> ReadC b -> ReadC c -> a -> b -> c -> ReadC (a, b, c)
perm3 sep p1 p2 p3 d1 d2 d3 = 
    comp (\ x (y, z) -> (x, y, z)) p1 (comp (curry snd) sep (perm2 sep p2 p3 d2 d3)) <|>
    comp (\ (y, z) x -> (x, y, z)) (perm2 sep p2 p3 d2 d3) (comp (curry snd) sep p1) <|>
    comp (\ x (y, z) -> (x, y, z)) p1 (inject (d2, d3)) <|>
    comp (\ x (y, z) -> (x, y, z)) (inject d1) (perm2 sep p2 p3 d2 d3)

seqOpt :: ReadC a -> ReadC b -> b -> ReadC b
seqOpt p1 p2 d1 = comp (\_ y -> y) p1 (option d1 (parens p2))

apply :: (a -> b) -> ReadC a -> ReadC b
apply f p str = do
    (str', v) <- p str
    return (str', f v)

pair :: ReadC a -> ReadC b -> ReadC (a, b)
pair p1 p2 = parens (\ str -> do
    (str', v1) <- p1 str
    (str'', _) <- comma str'
    (str''', v2) <- p2 str''
    return (str''', (v1, v2)))