{- |
Module      :  $Header$
Description :  generic conversion of literals
Copyright   :  Christian Maeder and Uni Bremen 2004
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  experimental
Portability :  portable

Generically converting literals
-}

module Common.ConvertLiteral
    ( SplitM
    , isGenLiteral
    , isGenNumber
    , isGenNum
    , isGenString
    , isGenList
    , isGenFloat
    , isGenFrac
    , toNumber
    , toFrac
    , toFloat
    , toString
    , toMixfixList
    , toChar
    ) where

import Common.Id
import Common.GlobalAnnotations
import Data.Char (isDigit)
import Data.List (isPrefixOf)

-- * test if term is a literal

type SplitM a = a -> Maybe (Id, [a])

isGenLiteral :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenLiteral splt ga i trm =
       or [ isGenNumber splt ga i trm
          , isGenString splt ga i trm
          , isGenList splt ga i trm
          , isGenFloat splt ga i trm
          , isGenFrac splt ga i trm
          ]

-- | is a number or a single digit
isGenNum :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenNum splt ga i trs = case trs of
    [] -> digitTest i
    _ -> isGenNumber splt ga i trs

-- | is a number of more than one digit
isGenNumber :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenNumber splt ga i trs = case trs of
    [_, _] -> getLiteralType ga i == Number
              && all (sameId splt digitTest i) trs
    _ -> False

digitTest :: Id -> Bool
digitTest ii = case ii of
                         Id [t] [] _ -> case tokStr t of
                             [d] -> isDigit d
                             _ -> False
                         _ -> False

isGenSignedNumber :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenSignedNumber splt ga i trs =
    case trs of
    [hd] -> case splt hd of
            Just (ni, nt) -> isSign i && isGenNum splt ga ni nt
            Nothing -> False
    _ -> False

isSign :: Id -> Bool
isSign i = case i of
           Id [tok, p] [] _ | isPlace p ->
              let ts = tokStr tok in ts == "-" || ts == "+"
           _ -> False

isGenString :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenString splt ga i trs = case getLiteralType ga i of
                    StringNull -> null trs
                    StringCons _ -> all (sameId splt stringTest i) trs
                    _ -> False
    where
          stringTest ii = case getLiteralType ga ii of
                          StringNull -> True
                          _ -> case ii of
                               Id [t] [] _ -> isPrefixOf "'" $ tokStr t
                               _ -> False

isGenList :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenList splt ga i trms = case getLiteralType ga i of
                     ListNull _ -> null trms
                     ListCons _ n -> listTest n i trms
                     _ -> False
    where listTest n1 i1 terms = case getLiteralType ga i1 of
              ListNull _ -> n1 == i1 && null terms
              ListCons _ n2 -> n1 == n2 && case terms of
                               [_, hd] -> case splt hd of
                                    Just (i2, ts) -> listTest n1 i2 ts
                                    Nothing -> False
                               _ -> False
              _ -> False

isGenFloat :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenFloat splt ga i [l, r] =
    case getLiteralType ga i of
    Floating -> case (splt l, splt r) of
        (Just (li, ltrm), Just (ri, rtrm)) ->
            (isGenNum splt ga li ltrm || isGenFrac splt ga li ltrm) &&
            (isGenSignedNumber splt ga ri rtrm || isGenNum splt ga ri rtrm)
        _ -> False
    _ -> False
isGenFloat _ _ _ _ = False

isGenFrac :: SplitM a -> GlobalAnnos -> Id -> [a] -> Bool
isGenFrac splt ga i [l, r] =
    case getLiteralType ga i of
    Fraction -> case (splt l, splt r) of
       (Just (li, ltrm), Just (ri, rtrm)) ->
                   isGenNum splt ga li ltrm && isGenNum splt ga ri rtrm
       _ -> False
    _ -> False
isGenFrac _ _ _ _ = False

sameId :: SplitM a -> (Id -> Bool) -> Id -> a -> Bool
sameId splt test i t = case splt t of
    Just (j, ts) -> if null ts then test j
                    else j == i && all (sameId splt test i) ts
    _ -> False

-- * convert an application back to a literal

joinToken :: Token -> Token -> Token
joinToken (Token s1 _) (Token s2 _) =
    Token (s1 ++ s2) nullRange -- forget the range

toSignedNumber :: (a -> (Id, [a])) -> Id -> [a] -> Token
toSignedNumber splt (Id [sign, p] [] _) [hd] | isPlace p = case splt hd of
  (i, ts) -> joinToken sign $ toNumber splt i ts
toSignedNumber _ _ _ = error "toSignedNumber"

toNumber :: (a -> (Id, [a])) -> Id -> [a] -> Token
toNumber splt i ts = if null ts then case i of
    Id [d] [] _ -> d
    _ -> error "toNumber"
    else foldr1 joinToken $ map (toNumber2 splt) ts

toNumber2 :: (a -> (Id, [a])) -> a -> Token
toNumber2 splt t = case splt t of (j, args) -> toNumber splt j args

toFrac :: (a -> (Id, [a])) -> [a] -> Token
toFrac splt [lt, rt] =
    joinToken (toNumber2 splt lt) $
              joinToken (Token "." nullRange) $
                      toNumber2 splt rt
toFrac _ _ = error "toFrac"

toFloat :: (a -> (Id, [a])) -> GlobalAnnos -> [a] -> Token
toFloat splt ga [lt, rt] =
    case (splt lt, splt rt) of
    ((bas_i, bas_t), (ex_i, ex_t)) ->
        let t1 = if isGenFrac (Just . splt) ga bas_i bas_t then
                 toFrac splt bas_t else
                 toNumber splt bas_i bas_t
            t2 = if isGenSignedNumber (Just . splt) ga ex_i ex_t then
                 toSignedNumber splt ex_i ex_t else
                 toNumber splt ex_i ex_t
        in joinToken t1 $ joinToken (Token "E" nullRange) t2
toFloat _ _ _ = error "toFloat2"

toChar :: Token -> String
toChar t = case tokStr t of
           '\'' : rt -> init rt
           _ -> error "toChar"

toString :: (a -> (Id, [a])) -> GlobalAnnos -> Id -> [a] -> Token
toString splt ga i ts =
  Token ( "\"" ++ toString1 splt ga i ts ++ "\"") nullRange

-- | the string without double quotes
toString1 :: (a -> (Id, [a])) -> GlobalAnnos -> Id -> [a] -> String
toString1 splt ga i ts = if null ts then
    case getLiteralType ga i of
    StringNull -> ""
    _ -> case i of
         Id [c] [] _ -> toChar c
         _ -> error "toString"
    else concatMap (toString2 splt ga) ts

toString2 :: (a -> (Id, [a])) -> GlobalAnnos -> a -> String
toString2 splt ga t = case splt t of (i, ts) -> toString1 splt ga i ts

-- | get list elements
getListElems :: (a -> (Id, [a])) -> [a] -> [a]
getListElems splt ts = case ts of
                     [] -> []
                     [ft, rt] -> ft : getListElems splt (snd $ splt rt)
                     _ -> error "getListElems"

-- | construct list result from application
toMixfixList :: (Id -> [a] -> Id -> b) -> (a -> (Id, [a]))
             -> GlobalAnnos -> Id -> [a] -> b
toMixfixList mkList splt ga i ts =
   let args = getListElems splt ts
       (openL, closeL, comps) = getListBrackets $
                case getLiteralType ga i of
                ListNull b -> b
                ListCons b _ -> b
                _ -> error "print_Literal_text"
   in mkList (Id openL [] nullRange) args (Id closeL comps nullRange)
