{- |
Module      :  ./HasCASL/ConvertTypePattern.hs
Description :  convert type patterns to type identifier applications
Copyright   :  (c) Christian Maeder and Uni Bremen 2002-2005
License     :  GPLv2 or higher, see LICENSE.txt

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

convert type patterns to type identifier applications
-}

module HasCASL.ConvertTypePattern
    ( toTypePattern
    , convertTypePatterns
    , convertTypePattern
    ) where

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

import HasCASL.As
import HasCASL.AsUtils
import HasCASL.PrintAs ()

-- | store identifier application as a type pattern
toTypePattern :: (Id, [TypeArg]) -> TypePattern
toTypePattern :: (Id, [TypeArg]) -> TypePattern
toTypePattern (i :: Id
i, tArgs :: [TypeArg]
tArgs) = Id -> [TypeArg] -> Range -> TypePattern
TypePattern Id
i [TypeArg]
tArgs Range
nullRange

-- | convert type patterns
convertTypePatterns :: [TypePattern] -> Result [(Id, [TypeArg])]
convertTypePatterns :: [TypePattern] -> Result [(Id, [TypeArg])]
convertTypePatterns ts :: [TypePattern]
ts = case [TypePattern]
ts of
    [] -> [(Id, [TypeArg])] -> Result [(Id, [TypeArg])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    s :: TypePattern
s : r :: [TypePattern]
r -> let
        Result d :: [Diagnosis]
d m :: Maybe (Id, [TypeArg])
m = TypePattern -> Result (Id, [TypeArg])
convertTypePattern TypePattern
s
        Result ds :: [Diagnosis]
ds (Just l :: [(Id, [TypeArg])]
l) = [TypePattern] -> Result [(Id, [TypeArg])]
convertTypePatterns [TypePattern]
r
        in [Diagnosis] -> Maybe [(Id, [TypeArg])] -> Result [(Id, [TypeArg])]
forall a. [Diagnosis] -> Maybe a -> Result a
Result ([Diagnosis]
d [Diagnosis] -> [Diagnosis] -> [Diagnosis]
forall a. [a] -> [a] -> [a]
++ [Diagnosis]
ds) (Maybe [(Id, [TypeArg])] -> Result [(Id, [TypeArg])])
-> Maybe [(Id, [TypeArg])] -> Result [(Id, [TypeArg])]
forall a b. (a -> b) -> a -> b
$ [(Id, [TypeArg])] -> Maybe [(Id, [TypeArg])]
forall a. a -> Maybe a
Just ([(Id, [TypeArg])] -> Maybe [(Id, [TypeArg])])
-> [(Id, [TypeArg])] -> Maybe [(Id, [TypeArg])]
forall a b. (a -> b) -> a -> b
$ case Maybe (Id, [TypeArg])
m of
                  Nothing -> [(Id, [TypeArg])]
l
                  Just i :: (Id, [TypeArg])
i -> (Id, [TypeArg])
i (Id, [TypeArg]) -> [(Id, [TypeArg])] -> [(Id, [TypeArg])]
forall a. a -> [a] -> [a]
: [(Id, [TypeArg])]
l

illegalTypePattern :: TypePattern -> Result a
illegalTypePattern :: TypePattern -> Result a
illegalTypePattern = String -> TypePattern -> Result a
forall a b. (GetRange a, Pretty a) => String -> a -> Result b
mkError "illegal type pattern"

illegalTypePatternArg :: TypePattern -> Result a
illegalTypePatternArg :: TypePattern -> Result a
illegalTypePatternArg = String -> TypePattern -> Result a
forall a b. (GetRange a, Pretty a) => String -> a -> Result b
mkError "illegal type pattern argument"

illegalTypeId :: TypePattern -> Result a
illegalTypeId :: TypePattern -> Result a
illegalTypeId = String -> TypePattern -> Result a
forall a b. (GetRange a, Pretty a) => String -> a -> Result b
mkError "illegal type pattern identifier"

-- | convert a type pattern
convertTypePattern :: TypePattern -> Result (Id, [TypeArg])
convertTypePattern :: TypePattern -> Result (Id, [TypeArg])
convertTypePattern tp :: TypePattern
tp = case TypePattern
tp of
    TypePattern t :: Id
t as :: [TypeArg]
as _ -> (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
t, [TypeArg]
as)
    TypePatternToken t :: Token
t ->
      if Token -> Bool
isPlace Token
t then TypePattern -> Result (Id, [TypeArg])
forall a. TypePattern -> Result a
illegalTypePattern TypePattern
tp else (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Id
simpleIdToId Token
t, [])
    MixfixTypePattern [ra :: TypePattern
ra, ri :: TypePattern
ri@(TypePatternToken inTok :: Token
inTok), rb :: TypePattern
rb] ->
      if Char -> Bool
isSignChar (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Char
forall a. [a] -> a
head (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ Token -> String
tokStr Token
inTok
      then let inId :: Id
inId = [Token] -> [Id] -> Range -> Id
Id [String -> Range -> Token
Token String
place (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ TypePattern -> Range
forall a. GetRange a => a -> Range
getRange TypePattern
ra, Token
inTok,
                           String -> Range -> Token
Token String
place (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ TypePattern -> Range
forall a. GetRange a => a -> Range
getRange TypePattern
rb] [] Range
nullRange
            in case (TypePattern
ra, TypePattern
rb) of
            (TypePatternToken (Token "__" _),
             TypePatternToken (Token "__" _)) -> (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
inId, [])
            _ -> do TypeArg
a <- TypePattern -> Result TypeArg
convertToTypeArg TypePattern
ra
                    TypeArg
b <- TypePattern -> Result TypeArg
convertToTypeArg TypePattern
rb
                    (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
inId, [TypeArg
a, TypeArg
b])
      else case TypePattern
ra of
         TypePatternToken t1 :: Token
t1 -> do
             TypeArg
a <- TypePattern -> Result TypeArg
convertToTypeArg TypePattern
ri
             TypeArg
b <- TypePattern -> Result TypeArg
convertToTypeArg TypePattern
rb
             (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Id
simpleIdToId Token
t1, [TypeArg
a, TypeArg
b])
         _ -> TypePattern -> Result (Id, [TypeArg])
forall a. TypePattern -> Result a
illegalTypePattern TypePattern
tp
    MixfixTypePattern (TypePatternToken t1 :: Token
t1 : rp :: [TypePattern]
rp) ->
      if Token -> Bool
isPlace Token
t1 then case [TypePattern]
rp of
               [TypePatternToken inId :: Token
inId, TypePatternToken t2 :: Token
t2] ->
                   if Token -> Bool
isPlace Token
t2 Bool -> Bool -> Bool
&& Char -> Bool
isSignChar (String -> Char
forall a. [a] -> a
head (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ Token -> String
tokStr Token
inId)
                     then (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Token] -> [Id] -> Range -> Id
Id [Token
t1, Token
inId, Token
t2] [] Range
nullRange, [])
                   else TypePattern -> Result (Id, [TypeArg])
forall a. TypePattern -> Result a
illegalTypePattern TypePattern
tp
               _ -> TypePattern -> Result (Id, [TypeArg])
forall a. TypePattern -> Result a
illegalTypePattern TypePattern
tp
      else case [TypePattern]
rp of
         BracketTypePattern Squares as :: [TypePattern]
as@(_ : _) ps :: Range
ps : rp2 :: [TypePattern]
rp2 -> do
             [Id]
is <- (TypePattern -> Result Id) -> [TypePattern] -> Result [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result Id
convertToId [TypePattern]
as
             [TypeArg]
rs <- (TypePattern -> Result TypeArg)
-> [TypePattern] -> Result [TypeArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result TypeArg
convertToTypeArg [TypePattern]
rp2
             (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Token] -> [Id] -> Range -> Id
Id [Token
t1] [Id]
is Range
ps, [TypeArg]
rs)
         _ -> do
           [TypeArg]
as <- (TypePattern -> Result TypeArg)
-> [TypePattern] -> Result [TypeArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result TypeArg
convertToTypeArg [TypePattern]
rp
           (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Id
simpleIdToId Token
t1, [TypeArg]
as)
    BracketTypePattern bk :: BracketKind
bk [ap :: TypePattern
ap] ps :: Range
ps -> case BracketKind
bk of
      Parens -> TypePattern -> Result (Id, [TypeArg])
convertTypePattern TypePattern
ap
      _ -> let (o :: String
o, c :: String
c) = BracketKind -> (String, String)
getBrackets BracketKind
bk
               tid :: Id
tid = [Token] -> [Id] -> Range -> Id
Id [String -> Range -> Token
Token String
o Range
ps, String -> Range -> Token
Token String
place (Range -> Token) -> Range -> Token
forall a b. (a -> b) -> a -> b
$ TypePattern -> Range
forall a. GetRange a => a -> Range
getRange TypePattern
ap,
                         String -> Range -> Token
Token String
c Range
ps] [] Range
nullRange
           in case TypePattern
ap of
         TypePatternToken t :: Token
t -> (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id, [TypeArg]) -> Result (Id, [TypeArg]))
-> (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall a b. (a -> b) -> a -> b
$ if Token -> Bool
isPlace Token
t
           then (Id
tid, [])
           else (Id
tid, [Id
-> Variance
-> VarKind
-> RawKind
-> Int
-> SeparatorKind
-> Range
-> TypeArg
TypeArg (Token -> Id
simpleIdToId Token
t) Variance
NonVar VarKind
MissingKind
                        RawKind
rStar 0 SeparatorKind
Other Range
nullRange])
         _ -> do TypeArg
a <- TypePattern -> Result TypeArg
convertToTypeArg TypePattern
ap
                 (Id, [TypeArg]) -> Result (Id, [TypeArg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
tid, [TypeArg
a])
    _ -> TypePattern -> Result (Id, [TypeArg])
forall a. TypePattern -> Result a
illegalTypePattern TypePattern
tp

convertToTypeArg :: TypePattern -> Result TypeArg
convertToTypeArg :: TypePattern -> Result TypeArg
convertToTypeArg tp :: TypePattern
tp = case TypePattern
tp of
    TypePatternToken t :: Token
t -> if Token -> Bool
isPlace Token
t then TypePattern -> Result TypeArg
forall a. TypePattern -> Result a
illegalTypePatternArg TypePattern
tp else
        TypeArg -> Result TypeArg
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeArg -> Result TypeArg) -> TypeArg -> Result TypeArg
forall a b. (a -> b) -> a -> b
$ Id
-> Variance
-> VarKind
-> RawKind
-> Int
-> SeparatorKind
-> Range
-> TypeArg
TypeArg (Token -> Id
simpleIdToId Token
t)
               Variance
NonVar VarKind
MissingKind RawKind
rStar 0 SeparatorKind
Other Range
nullRange
    TypePatternArg a :: TypeArg
a _ -> TypeArg -> Result TypeArg
forall (m :: * -> *) a. Monad m => a -> m a
return TypeArg
a
    BracketTypePattern Parens [stp :: TypePattern
stp] _ -> TypePattern -> Result TypeArg
convertToTypeArg TypePattern
stp
    _ -> TypePattern -> Result TypeArg
forall a. TypePattern -> Result a
illegalTypePatternArg TypePattern
tp

convertToId :: TypePattern -> Result Id
convertToId :: TypePattern -> Result Id
convertToId tp :: TypePattern
tp = case TypePattern
tp of
    TypePatternToken t :: Token
t ->
        if Token -> Bool
isPlace Token
t then TypePattern -> Result Id
forall a. TypePattern -> Result a
illegalTypeId TypePattern
tp else Id -> Result Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Result Id) -> Id -> Result Id
forall a b. (a -> b) -> a -> b
$ [Token] -> [Id] -> Range -> Id
Id [Token
t] [] Range
nullRange
    MixfixTypePattern [] -> String -> Result Id
forall a. HasCallStack => String -> a
error "convertToId: MixfixTypePattern []"
    MixfixTypePattern (hd :: TypePattern
hd : tps :: [TypePattern]
tps) ->
         if [TypePattern] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypePattern]
tps then TypePattern -> Result Id
convertToId TypePattern
hd
         else do
         let (toks :: [TypePattern]
toks, comps :: [TypePattern]
comps) = (TypePattern -> Bool)
-> [TypePattern] -> ([TypePattern], [TypePattern])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ( \ p :: TypePattern
p ->
                        case TypePattern
p of BracketTypePattern Squares (_ : _) _ -> Bool
True
                                  _ -> Bool
False) [TypePattern]
tps
         [[Token]]
ts <- (TypePattern -> Result [Token])
-> [TypePattern] -> Result [[Token]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result [Token]
convertToToks (TypePattern
hd TypePattern -> [TypePattern] -> [TypePattern]
forall a. a -> [a] -> [a]
: [TypePattern]
toks)
         (is :: [Id]
is, ps :: Range
ps) <- if [TypePattern] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypePattern]
comps then ([Id], Range) -> Result ([Id], Range)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Range
nullRange)
                     else TypePattern -> Result ([Id], Range)
convertToIds (TypePattern -> Result ([Id], Range))
-> TypePattern -> Result ([Id], Range)
forall a b. (a -> b) -> a -> b
$ [TypePattern] -> TypePattern
forall a. [a] -> a
head [TypePattern]
comps
         [Token]
pls <- if [TypePattern] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypePattern]
comps then [Token] -> Result [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                else (TypePattern -> Result Token) -> [TypePattern] -> Result [Token]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result Token
convertToPlace ([TypePattern] -> Result [Token])
-> [TypePattern] -> Result [Token]
forall a b. (a -> b) -> a -> b
$ [TypePattern] -> [TypePattern]
forall a. [a] -> [a]
tail [TypePattern]
comps
         Id -> Result Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Result Id) -> Id -> Result Id
forall a b. (a -> b) -> a -> b
$ [Token] -> [Id] -> Range -> Id
Id ([[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Token]]
ts [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token]
pls) [Id]
is Range
ps
    _ -> do
        [Token]
ts <- TypePattern -> Result [Token]
convertToToks TypePattern
tp
        Id -> Result Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Result Id) -> Id -> Result Id
forall a b. (a -> b) -> a -> b
$ [Token] -> [Id] -> Range -> Id
Id [Token]
ts [] Range
nullRange

convertToIds :: TypePattern -> Result ([Id], Range)
convertToIds :: TypePattern -> Result ([Id], Range)
convertToIds tp :: TypePattern
tp = case TypePattern
tp of
    BracketTypePattern Squares tps :: [TypePattern]
tps@(_ : _) ps :: Range
ps -> do
        [Id]
is <- (TypePattern -> Result Id) -> [TypePattern] -> Result [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result Id
convertToId [TypePattern]
tps
        ([Id], Range) -> Result ([Id], Range)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
is, Range
ps)
    _ -> TypePattern -> Result ([Id], Range)
forall a. TypePattern -> Result a
illegalTypeId TypePattern
tp

convertToToks :: TypePattern -> Result [Token]
convertToToks :: TypePattern -> Result [Token]
convertToToks tp :: TypePattern
tp = case TypePattern
tp of
    TypePatternToken t :: Token
t -> [Token] -> Result [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Token
t]
    BracketTypePattern bk :: BracketKind
bk [stp :: TypePattern
stp] ps :: Range
ps -> case BracketKind
bk of
        Parens -> TypePattern -> Result [Token]
forall a. TypePattern -> Result a
illegalTypeId TypePattern
stp
        _ -> let [o :: Token
o, c :: Token
c] = BracketKind -> Range -> [Token]
mkBracketToken BracketKind
bk Range
ps in do
            [Token]
ts <- TypePattern -> Result [Token]
convertToToks TypePattern
tp
            [Token] -> Result [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return (Token
o Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
ts [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
c])
    MixfixTypePattern tps :: [TypePattern]
tps -> do
        [[Token]]
ts <- (TypePattern -> Result [Token])
-> [TypePattern] -> Result [[Token]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypePattern -> Result [Token]
convertToToks [TypePattern]
tps
        [Token] -> Result [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Token] -> Result [Token]) -> [Token] -> Result [Token]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Token]]
ts
    _ -> TypePattern -> Result [Token]
forall a. TypePattern -> Result a
illegalTypeId TypePattern
tp

convertToPlace :: TypePattern -> Result Token
convertToPlace :: TypePattern -> Result Token
convertToPlace tp :: TypePattern
tp = case TypePattern
tp of
    TypePatternToken t :: Token
t -> if Token -> Bool
isPlace Token
t then Token -> Result Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
t else TypePattern -> Result Token
forall a. TypePattern -> Result a
illegalTypeId TypePattern
tp
    _ -> TypePattern -> Result Token
forall a. TypePattern -> Result a
illegalTypeId TypePattern
tp