hets/Common/ConvertMixfixToken.hs

{- |
Module      :  ./Common/ConvertMixfixToken.hs
Description :  generic conversion of mixfix tokens
Copyright   :  Christian Maeder and Uni Bremen 2004
License     :  GPLv2 or higher, see LICENSE.txt

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

generic conversion of mixfix tokens

-}

module Common.ConvertMixfixToken
    ( convertMixfixToken
    , AsAppl
    ) where

import Common.Id
import Common.Lexer
import Common.GlobalAnnotations
import Common.Result

-- * convert a literal to a term

type AsAppl a = Id -> [a] -> Range -> a

inc :: Int -> Range -> Range
inc n (Range p) =
  Range (map (`incSourceColumn` n) p)

stripIdRange :: Id -> Id
stripIdRange (Id ts cs _) =
  Id (map (\ t -> t { tokPos = nullRange }) ts) (map stripIdRange cs) nullRange

makeStringTerm :: Id -> Id -> AsAppl a -> Token -> a
makeStringTerm c f asAppl tok =
  makeStrTerm (inc 1 sp) str
  where
  sp = tokPos tok
  str = init (tail (tokStr tok))
  makeStrTerm p l =
    if null l then asAppl c [] p
    else let (hd, tl) = splitString caslChar l
         in asAppl f [asAppl (Id [Token ("'" ++ hd ++ "'") p]
                              [] nullRange) [] p,
                      makeStrTerm (inc (length hd) p) tl] p

makeNumberTerm :: Id -> AsAppl a -> Token -> a
makeNumberTerm f asAppl t@(Token n p) =
    case n of
           [] -> error "makeNumberTerm"
           [_] -> asAppl (Id [t] [] nullRange) [] p
           hd : tl -> asAppl f [asAppl (Id [Token [hd] p] [] nullRange) [] p,
                              makeNumberTerm f asAppl (Token tl
                                                $ inc 1 p)] p

makeFraction :: Id -> Id -> AsAppl a -> Token -> a
makeFraction f d asAppl t@(Token s p) =
    let (n, r) = span (/= '.') s
        dotOffset = length n
    in if null r then makeNumberTerm f asAppl t
       else asAppl d [makeNumberTerm f asAppl (Token n p),
                      makeNumberTerm f asAppl $ Token (tail r)
                                      $ inc (dotOffset + 1) p]
            $ inc dotOffset p

makeSignedNumber :: Id -> AsAppl a -> Token -> a
makeSignedNumber f asAppl t@(Token n p) =
  case n of
  [] -> error "makeSignedNumber"
  hd : tl ->
    if hd == '-' || hd == '+' then
       asAppl (Id [Token [hd] p, placeTok ] [] nullRange)
                  [makeNumberTerm f asAppl $ Token tl
                                         $ inc 1 p] p
    else makeNumberTerm f asAppl t

makeFloatTerm :: Id -> Id -> Id -> AsAppl a -> Token -> a
makeFloatTerm f d e asAppl t@(Token s p) =
    let (m, r) = span (/= 'E') s
        offset = length m
    in if null r then makeFraction f d asAppl t
       else asAppl e [makeFraction f d asAppl (Token m p),
                      makeSignedNumber f asAppl $ Token (tail r)
                                          $ inc (offset + 1) p]
                $ inc offset p

-- | convert a literal token to an application term
convertMixfixToken :: LiteralAnnos -> AsAppl a
                   -> (Token -> a) -> Token -> ([Diagnosis], a)
convertMixfixToken ga asAppl toTerm t = let
  te = toTerm t
  err s = ([Diag Error ("missing %" ++ s ++ " annotation") (tokPos t)], te)
  in if isString t then case string_lit ga of
        Nothing -> err "string"
        Just (c, f) ->
            ([], makeStringTerm (stripIdRange c) (stripIdRange f) asAppl t)
     else if isNumber t then case number_lit ga of
        Nothing -> err "number"
        Just f0 -> let f = stripIdRange f0 in
          if isFloating t then case float_lit ga of
            Nothing -> err "floating"
            Just (d, e) ->
              ([], makeFloatTerm f (stripIdRange d) (stripIdRange e) asAppl t)
          else ([], makeNumberTerm f asAppl t)
     else ([], te)