{- |
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 :: Int -> Range -> Range
inc n :: Int
n (Range p :: [Pos]
p) =
  [Pos] -> Range
Range ((Pos -> Pos) -> [Pos] -> [Pos]
forall a b. (a -> b) -> [a] -> [b]
map (Pos -> Int -> Pos
`incSourceColumn` Int
n) [Pos]
p)

stripIdRange :: Id -> Id
stripIdRange :: Id -> Id
stripIdRange (Id ts :: [Token]
ts cs :: [Id]
cs _) =
  [Token] -> [Id] -> Range -> Id
Id ((Token -> Token) -> [Token] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map (\ t :: Token
t -> Token
t { tokPos :: Range
tokPos = Range
nullRange }) [Token]
ts) ((Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
stripIdRange [Id]
cs) Range
nullRange

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

makeNumberTerm :: Id -> AsAppl a -> Token -> a
makeNumberTerm :: Id -> AsAppl a -> Token -> a
makeNumberTerm f :: Id
f asAppl :: AsAppl a
asAppl t :: Token
t@(Token n :: String
n p :: Range
p) =
    case String
n of
           [] -> String -> a
forall a. HasCallStack => String -> a
error "makeNumberTerm"
           [_] -> AsAppl a
asAppl ([Token] -> [Id] -> Range -> Id
Id [Token
t] [] Range
nullRange) [] Range
p
           hd :: Char
hd : tl :: String
tl -> AsAppl a
asAppl Id
f [AsAppl a
asAppl ([Token] -> [Id] -> Range -> Id
Id [String -> Range -> Token
Token [Char
hd] Range
p] [] Range
nullRange) [] Range
p,
                              Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeNumberTerm Id
f AsAppl a
asAppl (String -> Range -> Token
Token String
tl
                                                (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ Int -> Range -> Range
inc 1 Range
p)] Range
p

makeFraction :: Id -> Id -> AsAppl a -> Token -> a
makeFraction :: Id -> Id -> AsAppl a -> Token -> a
makeFraction f :: Id
f d :: Id
d asAppl :: AsAppl a
asAppl t :: Token
t@(Token s :: String
s p :: Range
p) =
    let (n :: String
n, r :: String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.') String
s
        dotOffset :: Int
dotOffset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n
    in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r then Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeNumberTerm Id
f AsAppl a
asAppl Token
t
       else AsAppl a
asAppl Id
d [Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeNumberTerm Id
f AsAppl a
asAppl (String -> Range -> Token
Token String
n Range
p),
                      Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeNumberTerm Id
f AsAppl a
asAppl (Token -> a) -> Token -> a
forall a b. (a -> b) -> a -> b
$ String -> Range -> Token
Token (String -> String
forall a. [a] -> [a]
tail String
r)
                                      (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ Int -> Range -> Range
inc (Int
dotOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Range
p]
            (Range -> a) -> Range -> a
forall a b. (a -> b) -> a -> b
$ Int -> Range -> Range
inc Int
dotOffset Range
p

makeSignedNumber :: Id -> AsAppl a -> Token -> a
makeSignedNumber :: Id -> AsAppl a -> Token -> a
makeSignedNumber f :: Id
f asAppl :: AsAppl a
asAppl t :: Token
t@(Token n :: String
n p :: Range
p) =
  case String
n of
  [] -> String -> a
forall a. HasCallStack => String -> a
error "makeSignedNumber"
  hd :: Char
hd : tl :: String
tl ->
    if Char
hd Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' Bool -> Bool -> Bool
|| Char
hd Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+' then
       AsAppl a
asAppl ([Token] -> [Id] -> Range -> Id
Id [String -> Range -> Token
Token [Char
hd] Range
p, Token
placeTok ] [] Range
nullRange)
                  [Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeNumberTerm Id
f AsAppl a
asAppl (Token -> a) -> Token -> a
forall a b. (a -> b) -> a -> b
$ String -> Range -> Token
Token String
tl
                                         (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ Int -> Range -> Range
inc 1 Range
p] Range
p
    else Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeNumberTerm Id
f AsAppl a
asAppl Token
t

makeFloatTerm :: Id -> Id -> Id -> AsAppl a -> Token -> a
makeFloatTerm :: Id -> Id -> Id -> AsAppl a -> Token -> a
makeFloatTerm f :: Id
f d :: Id
d e :: Id
e asAppl :: AsAppl a
asAppl t :: Token
t@(Token s :: String
s p :: Range
p) =
    let (m :: String
m, r :: String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= 'E') String
s
        offset :: Int
offset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m
    in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r then Id -> Id -> AsAppl a -> Token -> a
forall a. Id -> Id -> AsAppl a -> Token -> a
makeFraction Id
f Id
d AsAppl a
asAppl Token
t
       else AsAppl a
asAppl Id
e [Id -> Id -> AsAppl a -> Token -> a
forall a. Id -> Id -> AsAppl a -> Token -> a
makeFraction Id
f Id
d AsAppl a
asAppl (String -> Range -> Token
Token String
m Range
p),
                      Id -> AsAppl a -> Token -> a
forall a. Id -> AsAppl a -> Token -> a
makeSignedNumber Id
f AsAppl a
asAppl (Token -> a) -> Token -> a
forall a b. (a -> b) -> a -> b
$ String -> Range -> Token
Token (String -> String
forall a. [a] -> [a]
tail String
r)
                                          (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ Int -> Range -> Range
inc (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Range
p]
                (Range -> a) -> Range -> a
forall a b. (a -> b) -> a -> b
$ Int -> Range -> Range
inc Int
offset Range
p

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