{- |
Module      :  ./Common/AnalyseAnnos.hs
Description :  analyse annotations and add them to global ones
Copyright   :  (c) Christian Maeder, Klaus Luettich and Uni Bremen 2002-2003
License     :  GPLv2 or higher, see LICENSE.txt

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

Some functions for building and accessing the datastructures of
 GlobalAnnotations
-}

module Common.AnalyseAnnos
  ( addGlobalAnnos
  , getGlobalAnnos
  , store_literal_map
  ) where

import Common.AnnoParser
import Common.AS_Annotation
import Common.DocUtils
import Common.GlobalAnnotations
import Common.Id
import Common.Lexer
import Common.Parsec
import Common.Result
import Common.Utils
import qualified Common.Lib.Rel as Rel

import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.List (partition)
import Control.Monad (foldM)
import qualified Control.Monad.Fail as Fail
import Text.ParserCombinators.Parsec

getGlobalAnnos :: String -> Result GlobalAnnos
getGlobalAnnos :: String -> Result GlobalAnnos
getGlobalAnnos istr :: String
istr = let str :: String
str = String -> String
trimLeft String
istr in
  case GenParser Char () [Annotation]
-> () -> String -> String -> Either ParseError [Annotation]
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser (GenParser Char () [Annotation]
forall st. GenParser Char st [Annotation]
annotations GenParser Char () [Annotation]
-> ParsecT String () Identity () -> GenParser Char () [Annotation]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) () "" String
str of
    Left err :: ParseError
err -> String -> Result GlobalAnnos
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Result GlobalAnnos) -> String -> Result GlobalAnnos
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right ans :: [Annotation]
ans -> GlobalAnnos -> [Annotation] -> Result GlobalAnnos
addGlobalAnnos GlobalAnnos
emptyGlobalAnnos [Annotation]
ans

-- | add global annotations
addGlobalAnnos :: GlobalAnnos -> [Annotation] -> Result GlobalAnnos
addGlobalAnnos :: GlobalAnnos -> [Annotation] -> Result GlobalAnnos
addGlobalAnnos ga :: GlobalAnnos
ga all_annos :: [Annotation]
all_annos = do
  let (annos :: [Annotation]
annos, rest_annos :: [Annotation]
rest_annos) = (Annotation -> Bool)
-> [Annotation] -> ([Annotation], [Annotation])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ( \ a :: Annotation
a -> case Annotation
a of
        Label _ _ -> Bool
False
        Semantic_anno _ _ -> Bool
False
        Unparsed_anno {} -> Bool
False
            -- line and group and comments will be ignored
        _ -> Bool
True) [Annotation]
all_annos
  [Diagnosis] -> Result ()
appendDiags ([Diagnosis] -> Result ()) -> [Diagnosis] -> Result ()
forall a b. (a -> b) -> a -> b
$ (Annotation -> Diagnosis) -> [Annotation] -> [Diagnosis]
forall a b. (a -> b) -> [a] -> [b]
map (DiagKind -> String -> Annotation -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Hint "no analysis of") [Annotation]
rest_annos
  PrecedenceGraph
n_prec_annos <- PrecedenceGraph -> [Annotation] -> Result PrecedenceGraph
store_prec_annos (GlobalAnnos -> PrecedenceGraph
prec_annos GlobalAnnos
ga) [Annotation]
annos
  AssocMap
n_assoc_annos <- AssocMap -> [Annotation] -> Result AssocMap
store_assoc_annos (GlobalAnnos -> AssocMap
assoc_annos GlobalAnnos
ga) [Annotation]
annos
  DisplayMap
n_display_annos <- DisplayMap -> [Annotation] -> Result DisplayMap
store_display_annos (GlobalAnnos -> DisplayMap
display_annos GlobalAnnos
ga) [Annotation]
annos
  LiteralAnnos
n_literal_annos <- LiteralAnnos -> [Annotation] -> Result LiteralAnnos
store_literal_annos (GlobalAnnos -> LiteralAnnos
literal_annos GlobalAnnos
ga) [Annotation]
annos
  LiteralMap
n_literal_map <- LiteralMap -> [Annotation] -> Result LiteralMap
store_literal_map (GlobalAnnos -> LiteralMap
literal_map GlobalAnnos
ga) [Annotation]
annos
  PrefixMap
n_prefix_map <- PrefixMap -> [Annotation] -> Result PrefixMap
store_prefix_map (GlobalAnnos -> PrefixMap
prefix_map GlobalAnnos
ga) [Annotation]
annos
  GlobalAnnos -> Result GlobalAnnos
forall (m :: * -> *) a. Monad m => a -> m a
return GlobalAnnos
ga
    { prec_annos :: PrecedenceGraph
prec_annos = PrecedenceGraph
n_prec_annos
    , assoc_annos :: AssocMap
assoc_annos = AssocMap
n_assoc_annos
    , display_annos :: DisplayMap
display_annos = DisplayMap
n_display_annos
    , literal_annos :: LiteralAnnos
literal_annos = LiteralAnnos
n_literal_annos
    , literal_map :: LiteralMap
literal_map = LiteralMap
n_literal_map
    , prefix_map :: PrefixMap
prefix_map = PrefixMap
n_prefix_map }

-- | add precedences
store_prec_annos :: PrecedenceGraph -> [Annotation] -> Result PrecedenceGraph
store_prec_annos :: PrecedenceGraph -> [Annotation] -> Result PrecedenceGraph
store_prec_annos pgr :: PrecedenceGraph
pgr =
  let showRel :: PrecedenceGraph -> String -> String
showRel = (String -> String)
-> ((Id, Id) -> String -> String) -> [(Id, Id)] -> String -> String
forall a.
(String -> String)
-> (a -> String -> String) -> [a] -> String -> String
showSepList (String -> String -> String
showString "\n") (Id, Id) -> String -> String
showIdPair ([(Id, Id)] -> String -> String)
-> (PrecedenceGraph -> [(Id, Id)])
-> PrecedenceGraph
-> String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecedenceGraph -> [(Id, Id)]
forall a. Rel a -> [(a, a)]
Rel.toList in
    (PrecedenceGraph -> PrecedenceGraph)
-> Result PrecedenceGraph -> Result PrecedenceGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrecedenceGraph -> PrecedenceGraph
forall a. Ord a => Rel a -> Rel a
Rel.transClosure (Result PrecedenceGraph -> Result PrecedenceGraph)
-> ([Annotation] -> Result PrecedenceGraph)
-> [Annotation]
-> Result PrecedenceGraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrecedenceGraph -> Annotation -> Result PrecedenceGraph)
-> PrecedenceGraph -> [Annotation] -> Result PrecedenceGraph
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ( \ p0 :: PrecedenceGraph
p0 an :: Annotation
an -> case Annotation
an of
      Prec_anno prc :: PrecRel
prc lIds :: [Id]
lIds hIds :: [Id]
hIds _ -> (PrecedenceGraph -> Id -> Result PrecedenceGraph)
-> PrecedenceGraph -> [Id] -> Result PrecedenceGraph
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ p1 :: PrecedenceGraph
p1 li :: Id
li ->
        (PrecedenceGraph -> Id -> Result PrecedenceGraph)
-> PrecedenceGraph -> [Id] -> Result PrecedenceGraph
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ( \ p2 :: PrecedenceGraph
p2 hi :: Id
hi -> if Id
li Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
hi
          then [Diagnosis] -> Maybe PrecedenceGraph -> Result PrecedenceGraph
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error "prec_anno with equal id" Id
hi] (Maybe PrecedenceGraph -> Result PrecedenceGraph)
-> Maybe PrecedenceGraph -> Result PrecedenceGraph
forall a b. (a -> b) -> a -> b
$ PrecedenceGraph -> Maybe PrecedenceGraph
forall a. a -> Maybe a
Just PrecedenceGraph
p2
          else let
            err :: String -> Result PrecedenceGraph
err rel :: String
rel = [Diagnosis] -> Maybe PrecedenceGraph -> Result PrecedenceGraph
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error
              ("prec_anno conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
li String
rel String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
hi "\n"
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrecedenceGraph -> String -> String
showRel PrecedenceGraph
p2 "") Id
hi] (Maybe PrecedenceGraph -> Result PrecedenceGraph)
-> Maybe PrecedenceGraph -> Result PrecedenceGraph
forall a b. (a -> b) -> a -> b
$ PrecedenceGraph -> Maybe PrecedenceGraph
forall a. a -> Maybe a
Just PrecedenceGraph
p2
            in case PrecRel
prc of
          Lower -> if Id -> Id -> PrecedenceGraph -> Bool
forall a. Ord a => a -> a -> Rel a -> Bool
Rel.path Id
hi Id
li PrecedenceGraph
p2
            then String -> Result PrecedenceGraph
err " < "
            else PrecedenceGraph -> Result PrecedenceGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id -> PrecedenceGraph -> PrecedenceGraph
forall a. Ord a => a -> a -> Rel a -> Rel a
Rel.insertPair Id
li Id
hi PrecedenceGraph
p2)
          BothDirections -> if Id -> Id -> PrecedenceGraph -> Bool
forall a. Ord a => a -> a -> Rel a -> Bool
Rel.path Id
hi Id
li PrecedenceGraph
p2 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Id -> PrecedenceGraph -> Bool
forall a. Ord a => a -> a -> Rel a -> Bool
Rel.path Id
li Id
hi PrecedenceGraph
p2
            then PrecedenceGraph -> Result PrecedenceGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id -> PrecedenceGraph -> PrecedenceGraph
forall a. Ord a => a -> a -> Rel a -> Rel a
Rel.insertPair Id
hi Id
li (Id -> Id -> PrecedenceGraph -> PrecedenceGraph
forall a. Ord a => a -> a -> Rel a -> Rel a
Rel.insertPair Id
li Id
hi PrecedenceGraph
p2))
            else String -> Result PrecedenceGraph
err " <> "
          _ -> String -> Result PrecedenceGraph
err " > ") PrecedenceGraph
p1 [Id]
hIds) PrecedenceGraph
p0 [Id]
lIds
      _ -> PrecedenceGraph -> Result PrecedenceGraph
forall (m :: * -> *) a. Monad m => a -> m a
return PrecedenceGraph
p0) PrecedenceGraph
pgr

-- | add associative ids
store_assoc_annos :: AssocMap -> [Annotation] -> Result AssocMap
store_assoc_annos :: AssocMap -> [Annotation] -> Result AssocMap
store_assoc_annos = (AssocMap -> Annotation -> Result AssocMap)
-> AssocMap -> [Annotation] -> Result AssocMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((AssocMap -> Annotation -> Result AssocMap)
 -> AssocMap -> [Annotation] -> Result AssocMap)
-> (AssocMap -> Annotation -> Result AssocMap)
-> AssocMap
-> [Annotation]
-> Result AssocMap
forall a b. (a -> b) -> a -> b
$ \ am0 :: AssocMap
am0 an :: Annotation
an -> case Annotation
an of
  Assoc_anno as :: AssocEither
as is :: [Id]
is _ -> (AssocMap -> Id -> Result AssocMap)
-> AssocMap -> [Id] -> Result AssocMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ( \ am1 :: AssocMap
am1 i :: Id
i ->
    let v :: Maybe AssocEither
v = Id -> AssocMap -> Maybe AssocEither
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Id
i AssocMap
am1 in case Maybe AssocEither
v of
      Nothing -> AssocMap -> Result AssocMap
forall (m :: * -> *) a. Monad m => a -> m a
return (AssocMap -> Result AssocMap) -> AssocMap -> Result AssocMap
forall a b. (a -> b) -> a -> b
$ Id -> AssocEither -> AssocMap -> AssocMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
i AssocEither
as AssocMap
am1
      Just os :: AssocEither
os -> [Diagnosis] -> Maybe AssocMap -> Result AssocMap
forall a. [Diagnosis] -> Maybe a -> Result a
Result
        [ if AssocEither
as AssocEither -> AssocEither -> Bool
forall a. Eq a => a -> a -> Bool
== AssocEither
os
          then DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Hint "repeated associative identifier" Id
i
          else DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error "identifier has already other associativity" Id
i ]
        (Maybe AssocMap -> Result AssocMap)
-> Maybe AssocMap -> Result AssocMap
forall a b. (a -> b) -> a -> b
$ AssocMap -> Maybe AssocMap
forall a. a -> Maybe a
Just AssocMap
am1 ) AssocMap
am0 [Id]
is
  _ -> AssocMap -> Result AssocMap
forall (m :: * -> *) a. Monad m => a -> m a
return AssocMap
am0

-- | add display annotations
store_display_annos :: DisplayMap -> [Annotation] -> Result DisplayMap
store_display_annos :: DisplayMap -> [Annotation] -> Result DisplayMap
store_display_annos = (DisplayMap -> Annotation -> Result DisplayMap)
-> DisplayMap -> [Annotation] -> Result DisplayMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((DisplayMap -> Annotation -> Result DisplayMap)
 -> DisplayMap -> [Annotation] -> Result DisplayMap)
-> (DisplayMap -> Annotation -> Result DisplayMap)
-> DisplayMap
-> [Annotation]
-> Result DisplayMap
forall a b. (a -> b) -> a -> b
$ \ m :: DisplayMap
m an :: Annotation
an -> case Annotation
an of
  Display_anno i :: Id
i sxs :: [(Display_format, String)]
sxs _ -> do
    let t :: Map Display_format [Token]
t = Map Display_format [Token]
-> Id -> DisplayMap -> Map Display_format [Token]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Display_format [Token]
forall k a. Map k a
Map.empty Id
i DisplayMap
m
    Map Display_format [Token]
dm <- (Map Display_format [Token]
 -> (Display_format, String) -> Result (Map Display_format [Token]))
-> Map Display_format [Token]
-> [(Display_format, String)]
-> Result (Map Display_format [Token])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ( \ table :: Map Display_format [Token]
table (df :: Display_format
df, str :: String
str) -> do
      let Result ds :: [Diagnosis]
ds mres :: Maybe [Token]
mres = Annotation -> String -> Result [Token]
parse_display_str Annotation
an String
str
          toks :: [Token]
toks = [Token] -> Maybe [Token] -> [Token]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Token]
mres
          oldToks :: [Token]
oldToks = [Token] -> Display_format -> Map Display_format [Token] -> [Token]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [Token]
toks Display_format
df Map Display_format [Token]
table
          checkToks :: [Diagnosis]
checkToks =
            [ DiagKind -> String -> Annotation -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error
              ("Number of places in identifier \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
i
              " \" does not meet number of places in display string \""
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"") Annotation
an
            | Id -> Int
placeCount Id
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Id -> Int
placeCount ([Token] -> Id
mkId [Token]
toks) ]
      [Diagnosis] -> Result ()
appendDiags [Diagnosis]
ds
      if [Token]
oldToks [Token] -> [Token] -> Bool
forall a. Eq a => a -> a -> Bool
== [Token]
toks then do
          [Diagnosis] -> Result ()
appendDiags [Diagnosis]
checkToks
          Map Display_format [Token] -> Result (Map Display_format [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Display_format [Token] -> Result (Map Display_format [Token]))
-> Map Display_format [Token]
-> Result (Map Display_format [Token])
forall a b. (a -> b) -> a -> b
$ Display_format
-> [Token]
-> Map Display_format [Token]
-> Map Display_format [Token]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Display_format
df [Token]
toks Map Display_format [Token]
table
        else do
          [Diagnosis] -> Result ()
appendDiags [DiagKind -> String -> Annotation -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error ("conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annotation -> String -> String
forall a. Pretty a => a -> String -> String
showDoc Annotation
an "") Annotation
an]
          Map Display_format [Token] -> Result (Map Display_format [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return Map Display_format [Token]
table) Map Display_format [Token]
t [(Display_format, String)]
sxs
    DisplayMap -> Result DisplayMap
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayMap -> Result DisplayMap)
-> DisplayMap -> Result DisplayMap
forall a b. (a -> b) -> a -> b
$ Id -> Map Display_format [Token] -> DisplayMap -> DisplayMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
i Map Display_format [Token]
dm DisplayMap
m
  _ -> DisplayMap -> Result DisplayMap
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayMap
m

{- | add literal annotation to 'LiteralMap'
and check for overlapping ids -}
store_literal_map :: LiteralMap -> [Annotation] -> Result LiteralMap
store_literal_map :: LiteralMap -> [Annotation] -> Result LiteralMap
store_literal_map = (LiteralMap -> Annotation -> Result LiteralMap)
-> LiteralMap -> [Annotation] -> Result LiteralMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((LiteralMap -> Annotation -> Result LiteralMap)
 -> LiteralMap -> [Annotation] -> Result LiteralMap)
-> (LiteralMap -> Annotation -> Result LiteralMap)
-> LiteralMap
-> [Annotation]
-> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ \ m :: LiteralMap
m a :: Annotation
a -> case Annotation
a of
  Number_anno id1 :: Id
id1 _ ->
      let oc :: LiteralType
oc = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
Number Id
id1 LiteralMap
m in
      if LiteralType
oc LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
Number -- repeated or new
      then LiteralMap -> Result LiteralMap
forall (m :: * -> *) a. Monad m => a -> m a
return (LiteralMap -> Result LiteralMap)
-> LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id1 LiteralType
Number LiteralMap
m
      else [Diagnosis] -> Maybe LiteralMap -> Result LiteralMap
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error ("conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annotation -> String -> String
forall a. Pretty a => a -> String -> String
showDoc Annotation
a "") Id
id1] (Maybe LiteralMap -> Result LiteralMap)
-> Maybe LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ LiteralMap -> Maybe LiteralMap
forall a. a -> Maybe a
Just LiteralMap
m
  String_anno id1 :: Id
id1 id2 :: Id
id2 _ ->
      let c :: LiteralType
c = Id -> LiteralType
StringCons Id
id1
          oc :: LiteralType
oc = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
c Id
id2 LiteralMap
m
          on :: LiteralType
on = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
StringNull Id
id1 LiteralMap
m
      in if LiteralType
oc LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
c Bool -> Bool -> Bool
&& LiteralType
on LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
StringNull
      then LiteralMap -> Result LiteralMap
forall (m :: * -> *) a. Monad m => a -> m a
return (LiteralMap -> Result LiteralMap)
-> LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id1 LiteralType
StringNull (LiteralMap -> LiteralMap) -> LiteralMap -> LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id2 LiteralType
c LiteralMap
m
      else [Diagnosis] -> Maybe LiteralMap -> Result LiteralMap
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error ("conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annotation -> String -> String
forall a. Pretty a => a -> String -> String
showDoc Annotation
a "") Id
id1] (Maybe LiteralMap -> Result LiteralMap)
-> Maybe LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ LiteralMap -> Maybe LiteralMap
forall a. a -> Maybe a
Just LiteralMap
m
  Float_anno id1 :: Id
id1 id2 :: Id
id2 _ ->
      let oc :: LiteralType
oc = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
Fraction Id
id1 LiteralMap
m
          on :: LiteralType
on = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
Floating Id
id2 LiteralMap
m
      in if LiteralType
oc LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
Fraction Bool -> Bool -> Bool
&& LiteralType
on LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
Floating
      then LiteralMap -> Result LiteralMap
forall (m :: * -> *) a. Monad m => a -> m a
return (LiteralMap -> Result LiteralMap)
-> LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id2 LiteralType
Floating (LiteralMap -> LiteralMap) -> LiteralMap -> LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id1 LiteralType
Fraction LiteralMap
m
      else [Diagnosis] -> Maybe LiteralMap -> Result LiteralMap
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error ("conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annotation -> String -> String
forall a. Pretty a => a -> String -> String
showDoc Annotation
a "") Id
id1] (Maybe LiteralMap -> Result LiteralMap)
-> Maybe LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ LiteralMap -> Maybe LiteralMap
forall a. a -> Maybe a
Just LiteralMap
m
  List_anno id1 :: Id
id1 id2 :: Id
id2 id3 :: Id
id3 _ ->
      let c :: LiteralType
c = Id -> Id -> LiteralType
ListCons Id
id1 Id
id2
          n :: LiteralType
n = Id -> LiteralType
ListNull Id
id1
          oc :: LiteralType
oc = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
c Id
id3 LiteralMap
m
          on :: LiteralType
on = LiteralType -> Id -> LiteralMap -> LiteralType
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault LiteralType
n Id
id2 LiteralMap
m
      in if LiteralType
c LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
oc Bool -> Bool -> Bool
&& LiteralType
n LiteralType -> LiteralType -> Bool
forall a. Eq a => a -> a -> Bool
== LiteralType
on
         then LiteralMap -> Result LiteralMap
forall (m :: * -> *) a. Monad m => a -> m a
return (LiteralMap -> Result LiteralMap)
-> LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id2 LiteralType
n (LiteralMap -> LiteralMap) -> LiteralMap -> LiteralMap
forall a b. (a -> b) -> a -> b
$ Id -> LiteralType -> LiteralMap -> LiteralMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id3 LiteralType
c LiteralMap
m
         else [Diagnosis] -> Maybe LiteralMap -> Result LiteralMap
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error ("conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annotation -> String -> String
forall a. Pretty a => a -> String -> String
showDoc Annotation
a "") Id
id1] (Maybe LiteralMap -> Result LiteralMap)
-> Maybe LiteralMap -> Result LiteralMap
forall a b. (a -> b) -> a -> b
$ LiteralMap -> Maybe LiteralMap
forall a. a -> Maybe a
Just LiteralMap
m
  _ -> LiteralMap -> Result LiteralMap
forall (m :: * -> *) a. Monad m => a -> m a
return LiteralMap
m

-- | add prefix annotation to 'PrefixMap'
store_prefix_map :: PrefixMap -> [Annotation] -> Result PrefixMap
store_prefix_map :: PrefixMap -> [Annotation] -> Result PrefixMap
store_prefix_map = (PrefixMap -> Annotation -> Result PrefixMap)
-> PrefixMap -> [Annotation] -> Result PrefixMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((PrefixMap -> Annotation -> Result PrefixMap)
 -> PrefixMap -> [Annotation] -> Result PrefixMap)
-> (PrefixMap -> Annotation -> Result PrefixMap)
-> PrefixMap
-> [Annotation]
-> Result PrefixMap
forall a b. (a -> b) -> a -> b
$ \ m :: PrefixMap
m a :: Annotation
a -> case Annotation
a of
  Prefix_anno assoc :: [(String, IRI)]
assoc _ ->
      let newPrefixesMap :: PrefixMap
newPrefixesMap = [(String, IRI)] -> PrefixMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, IRI)]
assoc in
      PrefixMap -> Result PrefixMap
forall (m :: * -> *) a. Monad m => a -> m a
return (PrefixMap -> Result PrefixMap) -> PrefixMap -> Result PrefixMap
forall a b. (a -> b) -> a -> b
$ (IRI -> IRI -> IRI) -> PrefixMap -> PrefixMap -> PrefixMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\ _ p2 :: IRI
p2 -> IRI
p2) PrefixMap
m PrefixMap
newPrefixesMap
  _ -> PrefixMap -> Result PrefixMap
forall (m :: * -> *) a. Monad m => a -> m a
return PrefixMap
m

{- | add literal annotation to 'LiteralAnnos'
and check for contradictions -}
store_literal_annos :: LiteralAnnos -> [Annotation] -> Result LiteralAnnos
store_literal_annos :: LiteralAnnos -> [Annotation] -> Result LiteralAnnos
store_literal_annos la :: LiteralAnnos
la ans :: [Annotation]
ans = do
  Maybe (Id, Id)
n_string_lit <- Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
setStringLit (LiteralAnnos -> Maybe (Id, Id)
string_lit LiteralAnnos
la) [Annotation]
ans
  Map Id (Id, Id)
n_list_lit <- Map Id (Id, Id) -> [Annotation] -> Result (Map Id (Id, Id))
setListLit (LiteralAnnos -> Map Id (Id, Id)
list_lit LiteralAnnos
la) [Annotation]
ans
  Maybe Id
n_number_lit <- Maybe Id -> [Annotation] -> Result (Maybe Id)
setNumberLit (LiteralAnnos -> Maybe Id
number_lit LiteralAnnos
la) [Annotation]
ans
  Maybe (Id, Id)
n_float_lit <- Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
setFloatLit (LiteralAnnos -> Maybe (Id, Id)
float_lit LiteralAnnos
la) [Annotation]
ans
  LiteralAnnos -> Result LiteralAnnos
forall (m :: * -> *) a. Monad m => a -> m a
return LiteralAnnos
la
    { string_lit :: Maybe (Id, Id)
string_lit = Maybe (Id, Id)
n_string_lit
    , list_lit :: Map Id (Id, Id)
list_lit = Map Id (Id, Id)
n_list_lit
    , number_lit :: Maybe Id
number_lit = Maybe Id
n_number_lit
    , float_lit :: Maybe (Id, Id)
float_lit = Maybe (Id, Id)
n_float_lit }

-- | shortcut to show errors in 'setStringLit' and  'setFloatLit'
showIdPair :: (Id, Id) -> ShowS
showIdPair :: (Id, Id) -> String -> String
showIdPair (i1 :: Id
i1, i2 :: Id
i2) = Id -> String -> String
showId Id
i1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString "," (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> String -> String
showId Id
i2

-- | add (and check for uniqueness) string annotations
setStringLit :: Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
setStringLit :: Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
setStringLit = (Maybe (Id, Id) -> Annotation -> Result (Maybe (Id, Id)))
-> Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Maybe (Id, Id) -> Annotation -> Result (Maybe (Id, Id)))
 -> Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id)))
-> (Maybe (Id, Id) -> Annotation -> Result (Maybe (Id, Id)))
-> Maybe (Id, Id)
-> [Annotation]
-> Result (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$ \ m :: Maybe (Id, Id)
m a :: Annotation
a -> case Annotation
a of
  String_anno id1 :: Id
id1 id2 :: Id
id2 _ -> let q :: (Id, Id)
q = (Id
id1, Id
id2) in case Maybe (Id, Id)
m of
    Nothing -> Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Id, Id) -> Result (Maybe (Id, Id)))
-> Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$ (Id, Id) -> Maybe (Id, Id)
forall a. a -> Maybe a
Just (Id, Id)
q
    Just p :: (Id, Id)
p -> if (Id, Id)
q (Id, Id) -> (Id, Id) -> Bool
forall a. Eq a => a -> a -> Bool
== (Id, Id)
p then Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Id)
m
      else [Diagnosis] -> Maybe (Maybe (Id, Id)) -> Result (Maybe (Id, Id))
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error
        ("conflict %string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Id, Id) -> String -> String
showIdPair (Id, Id)
q " and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Id, Id) -> String -> String
showIdPair (Id, Id)
p "") Id
id1]
      (Maybe (Maybe (Id, Id)) -> Result (Maybe (Id, Id)))
-> Maybe (Maybe (Id, Id)) -> Result (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$ Maybe (Id, Id) -> Maybe (Maybe (Id, Id))
forall a. a -> Maybe a
Just Maybe (Id, Id)
m
  _ -> Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Id)
m

-- | add (and check for uniqueness) floating annotations
setFloatLit :: Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
setFloatLit :: Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
setFloatLit = (Maybe (Id, Id) -> Annotation -> Result (Maybe (Id, Id)))
-> Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Maybe (Id, Id) -> Annotation -> Result (Maybe (Id, Id)))
 -> Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id)))
-> (Maybe (Id, Id) -> Annotation -> Result (Maybe (Id, Id)))
-> Maybe (Id, Id)
-> [Annotation]
-> Result (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$ \ m :: Maybe (Id, Id)
m a :: Annotation
a -> case Annotation
a of
  Float_anno id1 :: Id
id1 id2 :: Id
id2 _ -> let q :: (Id, Id)
q = (Id
id1, Id
id2) in case Maybe (Id, Id)
m of
    Nothing -> Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Id, Id) -> Result (Maybe (Id, Id)))
-> Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$ (Id, Id) -> Maybe (Id, Id)
forall a. a -> Maybe a
Just (Id, Id)
q
    Just p :: (Id, Id)
p -> if (Id, Id)
q (Id, Id) -> (Id, Id) -> Bool
forall a. Eq a => a -> a -> Bool
== (Id, Id)
p then Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Id)
m
      else [Diagnosis] -> Maybe (Maybe (Id, Id)) -> Result (Maybe (Id, Id))
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error
       ("conflict %floating  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Id, Id) -> String -> String
showIdPair (Id, Id)
q " and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Id, Id) -> String -> String
showIdPair (Id, Id)
p "") Id
id1]
      (Maybe (Maybe (Id, Id)) -> Result (Maybe (Id, Id)))
-> Maybe (Maybe (Id, Id)) -> Result (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$ Maybe (Id, Id) -> Maybe (Maybe (Id, Id))
forall a. a -> Maybe a
Just Maybe (Id, Id)
m
  _ -> Maybe (Id, Id) -> Result (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Id)
m

-- | add (and check for uniqueness) number annotations
setNumberLit :: Maybe Id -> [Annotation] -> Result (Maybe Id)
setNumberLit :: Maybe Id -> [Annotation] -> Result (Maybe Id)
setNumberLit = (Maybe Id -> Annotation -> Result (Maybe Id))
-> Maybe Id -> [Annotation] -> Result (Maybe Id)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Maybe Id -> Annotation -> Result (Maybe Id))
 -> Maybe Id -> [Annotation] -> Result (Maybe Id))
-> (Maybe Id -> Annotation -> Result (Maybe Id))
-> Maybe Id
-> [Annotation]
-> Result (Maybe Id)
forall a b. (a -> b) -> a -> b
$ \ m :: Maybe Id
m a :: Annotation
a -> case Annotation
a of
  Number_anno id1 :: Id
id1 _ -> case Maybe Id
m of
    Nothing -> Maybe Id -> Result (Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> Result (Maybe Id)) -> Maybe Id -> Result (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
forall a. a -> Maybe a
Just Id
id1
    Just id2 :: Id
id2 -> if Id
id1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
id2 then Maybe Id -> Result (Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Id
m
      else [Diagnosis] -> Maybe (Maybe Id) -> Result (Maybe Id)
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error
        ("conflict %number " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
id1 " and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
id2 "") Id
id1]
      (Maybe (Maybe Id) -> Result (Maybe Id))
-> Maybe (Maybe Id) -> Result (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Maybe Id -> Maybe (Maybe Id)
forall a. a -> Maybe a
Just Maybe Id
m
  _ -> Maybe Id -> Result (Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Id
m

-- | add (and check for consistency) (possibly several) list annotations
setListLit :: Map.Map Id (Id, Id) -> [Annotation]
  -> Result (Map.Map Id (Id, Id))
setListLit :: Map Id (Id, Id) -> [Annotation] -> Result (Map Id (Id, Id))
setListLit =
  let showListAnno :: Id -> (Id, Id) -> String
showListAnno i1 :: Id
i1 (i2 :: Id
i2, i3 :: Id
i3) =
          " %list " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
i1 "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
i2 "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String -> String
showId Id
i3 ""
  in (Map Id (Id, Id) -> Annotation -> Result (Map Id (Id, Id)))
-> Map Id (Id, Id) -> [Annotation] -> Result (Map Id (Id, Id))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Map Id (Id, Id) -> Annotation -> Result (Map Id (Id, Id)))
 -> Map Id (Id, Id) -> [Annotation] -> Result (Map Id (Id, Id)))
-> (Map Id (Id, Id) -> Annotation -> Result (Map Id (Id, Id)))
-> Map Id (Id, Id)
-> [Annotation]
-> Result (Map Id (Id, Id))
forall a b. (a -> b) -> a -> b
$ \ m :: Map Id (Id, Id)
m a :: Annotation
a -> case Annotation
a of
  List_anno id1 :: Id
id1 id2 :: Id
id2 id3 :: Id
id3 _ ->
           -- equal keys with different values conflict
    let nv :: (Id, Id)
nv = (Id
id2, Id
id3)
    in case Id -> Map Id (Id, Id) -> Maybe (Id, Id)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Id
id1 Map Id (Id, Id)
m of
         Nothing -> Map Id (Id, Id) -> Result (Map Id (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Id (Id, Id) -> Result (Map Id (Id, Id)))
-> Map Id (Id, Id) -> Result (Map Id (Id, Id))
forall a b. (a -> b) -> a -> b
$ Id -> (Id, Id) -> Map Id (Id, Id) -> Map Id (Id, Id)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
id1 (Id, Id)
nv Map Id (Id, Id)
m
         Just v :: (Id, Id)
v -> if (Id, Id)
nv (Id, Id) -> (Id, Id) -> Bool
forall a. Eq a => a -> a -> Bool
== (Id, Id)
v then Map Id (Id, Id) -> Result (Map Id (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Map Id (Id, Id)
m
           else [Diagnosis] -> Maybe (Map Id (Id, Id)) -> Result (Map Id (Id, Id))
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Id -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Error
             ("conflict" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> (Id, Id) -> String
showListAnno Id
id1 (Id, Id)
nv String -> String -> String
forall a. [a] -> [a] -> [a]
++ " and"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> (Id, Id) -> String
showListAnno Id
id1 (Id, Id)
v) Id
id1] (Maybe (Map Id (Id, Id)) -> Result (Map Id (Id, Id)))
-> Maybe (Map Id (Id, Id)) -> Result (Map Id (Id, Id))
forall a b. (a -> b) -> a -> b
$ Map Id (Id, Id) -> Maybe (Map Id (Id, Id))
forall a. a -> Maybe a
Just Map Id (Id, Id)
m
  _ -> Map Id (Id, Id) -> Result (Map Id (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Map Id (Id, Id)
m

parse_display_str :: Annotation -> String -> Result [Token]
parse_display_str :: Annotation -> String -> Result [Token]
parse_display_str an :: Annotation
an str :: String
str =
  case Parsec String () [Token]
-> String -> String -> Either ParseError [Token]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [Token]
forall st. CharParser st [Token]
tokenL "-- internal parse --" String
str of
    Left err :: ParseError
err -> let
          err' :: String
err' = "could not parse display string: using \""
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\" as display token!\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\nin:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annotation -> String -> String
forall a. Pretty a => a -> String -> String
showDoc Annotation
an ""
          in [Token] -> String -> Range -> Result [Token]
forall a. a -> String -> Range -> Result a
warning [String -> Token
mkSimpleId String
str] String
err' Range
nullRange
    Right i' :: [Token]
i' -> [Token] -> Result [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Token]
i'

tokenL :: CharParser st [Token]
tokenL :: CharParser st [Token]
tokenL = ParsecT String st Identity Token -> CharParser st [Token]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String st Identity Token -> CharParser st [Token])
-> ParsecT String st Identity Token -> CharParser st [Token]
forall a b. (a -> b) -> a -> b
$ ParsecT String st Identity Token
forall st. CharParser st Token
placeT
  ParsecT String st Identity Token
-> ParsecT String st Identity Token
-> ParsecT String st Identity Token
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Token)
-> ParsecT String st Identity String
-> ParsecT String st Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Token
mkSimpleId
      (ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> ParsecT String st Identity Char
-> ParsecT String st Identity ()
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String st Identity () -> ParsecT String st Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT String st Identity () -> ParsecT String st Identity ())
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String st Identity Token -> ParsecT String st Identity ()
forall (m :: * -> *) a. Monad m => m a -> m ()
forget ParsecT String st Identity Token
forall st. CharParser st Token
placeT ParsecT String st Identity ()
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String st Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof))