content: {- |
  Module      :  ./Common/ConvertLiteral.hs
  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)
  