module Parser.Signature (
Identifier(..), Direction(..), ParamDecl(..), header3_3, header3_4,
) where
import qualified Parser.Combinator as Parser
import qualified Type
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec (Parser, (<|>))
import Text.Printf (printf)
import Control.Monad.HT (void)
import Control.Monad (liftM2, liftM3)
import Control.Applicative ((<$>), (<$))
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Function (fix)
import Data.Maybe (catMaybes)
import Data.Map (Map)
newtype Identifier = Identifier String
subroutine :: Parser (Identifier, [String], Maybe Type.Mono)
subroutine = do
Parser.spaces
Parsec.optional $ Parsec.try $ Parser.keyword "RECURSIVE"
returnType <-
((Nothing <$) $ Parsec.try $ Parser.keyword "SUBROUTINE")
<|>
(Parser.lexeme (Just <$> typeIdent)
`Parser.followedBy`
Parser.keyword "FUNCTION")
liftM3 (,,)
(Identifier <$> Parser.identifier)
(Parser.parens $ Parser.commaSep Parser.identifier)
(return returnType)
type Mapping = Type.Mapping String Type.Mono
data ParamDecl = Type Type.Mono [(String, Maybe [String])] | External [String]
typeIdent :: Parser Type.Mono
typeIdent =
(Type.Logical <$ Parsec.string "LOGICAL")
<|>
(Type.Character <$
Parsec.try
(Parsec.string "CHARACTER" >> Parsec.optional (Parsec.string "*1")))
<|>
(Type.Integer <$ Parsec.string "INTEGER")
<|>
(Type.RealSingle <$ Parsec.string "REAL")
<|>
(Parser.lexeme (Parsec.string "DOUBLE") >>
((Type.RealDouble <$ Parsec.string "PRECISION")
<|>
(Type.ComplexDouble <$ Parsec.string "COMPLEX")))
<|>
(Parsec.string "COMPLEX" >>
((Type.ComplexDouble <$ Parsec.string "*16") <|> return Type.ComplexSingle))
expression :: Parser String
expression =
fmap concat $
Parsec.many1 $
Parsec.many1 Parsec.alphaNum
<|>
fmap return (Parsec.oneOf "+-*/: ")
<|>
(fmap (printf "(%s)") $
Parsec.between
(Parser.lexeme $ Parsec.char '(') (Parser.lexeme $ Parsec.char ')')
(List.intercalate "," <$> Parser.commaSep1 expression))
externalDecl :: Parser [String]
externalDecl =
Parsec.try (Parsec.string "EXTERNAL")
>>
Parser.spaces
>>
Parser.commaSep1 Parser.identifier
parameterDecl :: Parser ParamDecl
parameterDecl =
Parsec.spaces >>
(fmap External externalDecl
<|>
(liftM2 Type
(Parser.lexeme typeIdent)
(Parser.commaSep $
liftM2 (,)
Parser.identifier
(Parsec.option Nothing $
fmap Just $ Parser.parens $ Parser.commaSep1 $
Parser.lexeme (Parsec.string "*") <|> expression))))
data Direction = Input | Output | InputOutput | InputWorkspace | Workspace
deriving (Eq, Show)
direction3_3 :: Parser Direction
direction3_3 = do
dirs <- Parsec.many1 (Parsec.letter <|> Parsec.char '/' <|> Parsec.char ' ')
case dirs of
"input" -> return Input
"input or output" -> return InputOutput
"input/output" -> return InputOutput
"input/workspace" -> return InputWorkspace
"output" -> return Output
"workspace" -> return Workspace
"workspace/output" -> return Workspace
"input/workspace/output" -> return InputOutput
_ -> fail $ "unknown direction specification: " ++ dirs
arrayDimensions :: String -> Parser (Maybe [String])
arrayDimensions commentStart = do
Parser.keyword "array,"
(do
Parser.keyword "dimension"
(do
dims <- Parser.parens (Parser.commaSep1 expression)
(Nothing <$
Parsec.try
(Parser.keyword "if" <|>
(Parser.keyword ('\n':commentStart) >> Parser.keyword "if")))
<|> return (Just dims))
<|> return Nothing)
<|>
return Nothing
optionalDimensions :: String -> Parser (Maybe Mapping)
optionalDimensions commentStart =
(fmap Type.Array <$> arrayDimensions commentStart)
<|>
return (Just Type.Scalar)
{-
LOGICAL FUNCTION of one COMPLEX argument
-}
callback :: Parser (Int, Type.Mono, Type.Mono)
callback = do
returnType <- Parser.lexeme typeIdent
Parser.keyword "FUNCTION"
Parser.keyword "of"
let arguments n nStr argStr = do
Parsec.try $ Parser.keyword nStr
typ <- Parser.lexeme typeIdent
Parser.keyword argStr
return (n,typ)
(n,argType) <-
arguments 1 "one" "argument" <|>
arguments 2 "two" "arguments" <|>
arguments 3 "three" "arguments"
return (n,argType,returnType)
parameterComment3_3 :: Parser (String, (Direction, Type.Mono, Maybe Mapping))
parameterComment3_3 = do
void $ Parser.lexeme $ Parsec.char '*'
liftM2 (,) Parser.identifier $
liftM3 (,,)
(Parser.parens direction3_3) (Parser.lexeme typeIdent)
(optionalDimensions "*")
`Parser.followedBy`
Parser.garbage
anyComment :: Parser ()
anyComment = do
void $ Parsec.char '*'
Parser.garbage
commentOrBlank :: Parser ()
commentOrBlank = Parser.oneLine $ anyComment <|> return ()
header3_3 ::
Parser
((Identifier, [String], Maybe Type.Mono), [ParamDecl],
Map String (Direction, Type.Mono, Maybe Mapping))
header3_3 = do
prototype <- Parser.oneLine subroutine
Parsec.skipMany commentOrBlank
Parsec.optional $ Parsec.try $ Parser.oneLine $ do
Parser.spaces
Parser.keyword "IMPLICIT"
Parser.keyword "NONE"
Parsec.skipMany commentOrBlank
paramTypes <-
fix $ \loop ->
liftM2 (:) (Parser.oneLine parameterDecl) $
fix $ \loopCmt ->
([] <$ Parsec.try (Parsec.lookAhead parameterComment3_3))
<|>
(commentOrBlank >> loopCmt)
<|>
loop
paramDirs <-
Parsec.many $
(Just <$> Parsec.try (Parser.oneLine parameterComment3_3))
<|>
(Nothing <$ commentOrBlank)
return (prototype, paramTypes, Map.fromList $ catMaybes paramDirs)
direction3_4 :: Parser (Bool -> Direction)
direction3_4 = do
dirs <- Parsec.many1 (Parsec.letter <|> Parsec.char ',')
case dirs of
"in" -> return $ \work -> if work then InputWorkspace else Input
"in,out" -> return $ const InputOutput
"out" -> return $ \work -> if work then Workspace else Output
_ -> fail $ "unknown direction specification: " ++ dirs
{-
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
-}
parameterComment3_4 :: Parser (String, (Direction, Type.Mono, Maybe Mapping))
parameterComment3_4 = do
let doxyCmt = void $ Parser.lexeme $ Parsec.string "*>"
void $ Parsec.try $ doxyCmt >> Parsec.string "\\param"
dirFromWork <-
Parser.lexeme $
Parsec.between (Parsec.char '[') (Parsec.char ']') direction3_4
name <- Parser.identifier
void $ Parsec.newline
let dir = dirFromWork $ List.isSuffixOf "WORK" name
doxyCmt >> Parsec.string "\\verbatim" >> void Parsec.newline
doxyCmt
void $ Parser.lexeme $ Parsec.string name
void $ Parser.lexeme $ Parsec.string "is"
(typ,dims) <-
Parser.oneLine $
(do
Parsec.try $ Parser.keyword "a"
(n,argType,returnType) <- callback
return (returnType, Just $ Type.Function n argType))
<|>
(liftM2 (,) (Parser.lexeme typeIdent) (optionalDimensions "*>")
`Parser.followedBy`
Parser.garbage)
return (name, (dir,typ,dims))
header3_4 ::
Parser
((Identifier, [String], Maybe Type.Mono), [ParamDecl],
Map String (Direction, Type.Mono, Maybe Mapping))
header3_4 = do
void $ fix $ \loop ->
(Parsec.try $ Parser.oneLine $
Parser.lexeme (Parsec.string "*") >> Parsec.string "Arguments:")
<|>
(commentOrBlank >> loop)
void $ Parser.oneLine $
Parser.lexeme (Parsec.string "*") >> Parsec.string "=========="
void $ Parser.oneLine $ Parser.lexeme (Parsec.string "*")
paramDirs <-
Parsec.many $
(Just <$> parameterComment3_4)
<|>
(Nothing <$
Parsec.try (Parser.oneLine (Parsec.string "*>" >> Parser.garbage)))
Parsec.skipMany commentOrBlank
prototype <- Parser.oneLine subroutine
Parsec.skipMany commentOrBlank
Parsec.optional $ Parsec.try $ Parser.oneLine $ do
Parser.spaces
Parser.keyword "IMPLICIT" <|> Parser.keyword "implicit"
Parser.keyword "NONE" <|> Parser.keyword "none"
Parsec.skipMany commentOrBlank
paramTypes <-
fix $ \loop ->
liftM2 (:) (Parser.oneLine parameterDecl) $
fix $ \loopCmt ->
(Parsec.try $ Parser.oneLine $
[] <$ (Parser.lexeme (Parsec.string "*") >>
Parsec.string "==================" >> Parser.garbage))
<|>
(commentOrBlank >> loopCmt)
<|>
loop
return (prototype, paramTypes, Map.fromList $ catMaybes paramDirs)