module Common.ConvertMixfixToken
( convertMixfixToken
, AsAppl
) where
import Common.Id
import Common.Lexer
import Common.GlobalAnnotations
import Common.Result
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
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)