content: {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE LambdaCase         #-}
  {-# OPTIONS_GHC -Wall #-}
  
  module Camfort.Specification.Hoare.Parser.Types where
  
  import           Control.Monad.Except
  import           Data.Data
  import           Control.Exception
  import           Data.List               ( intercalate )
  
  import qualified Data.ByteString.Char8    as B
  
  import qualified Language.Fortran.AST     as F
  import           Language.Fortran.Version ( FortranVersion(..) )
  
  -- for temporary definition defined in new fortran-src version, copied here
  import           Language.Fortran.AST ( A0, Statement )
  import           Language.Fortran.Parser ( Parser, makeParserFixed, makeParserFree )
  import qualified Language.Fortran.Parser.Fixed.Fortran66  as F66
  import qualified Language.Fortran.Parser.Fixed.Fortran77  as F77
  import qualified Language.Fortran.Parser.Free.Fortran90   as F90
  import qualified Language.Fortran.Parser.Free.Fortran95   as F95
  import qualified Language.Fortran.Parser.Free.Fortran2003 as F2003
  
  data HoareParseError
    = UnmatchedQuote
    | UnexpectedInput
    | MalformedExpression String
    | MalformedTypeSpec String
    | ParseError [Token]
    | LexError String
    deriving (Eq, Ord, Typeable, Data)
  
  instance Show HoareParseError where
    show UnmatchedQuote = "unmatched quote"
    show UnexpectedInput = "unexpected characters in input"
    show (MalformedExpression expr) = "couldn't parse expression: \"" ++ expr ++ "\""
    show (MalformedTypeSpec ts) = "couldn't parse type spec: \"" ++ ts ++ "\""
    show (ParseError tokens) = "unable to parse input: " ++ prettyTokens tokens
    show (LexError xs) = "unable to lex input: " ++ xs
  
  instance Exception HoareParseError where
  
  prettyTokens :: [Token] -> String
  prettyTokens = intercalate " " . map prettyToken
    where
      prettyToken = \case
        TQuoted qv -> "\"" ++ qv ++ "\""
        TStaticAssert -> "static_assert"
        TPre -> "pre"
        TPost -> "post"
        TInvariant -> "invariant"
        TSeq -> "seq"
        TRParen -> ")"
        TLParen -> "("
        TAnd -> "&"
        TOr -> "|"
        TImpl -> "->"
        TEquiv -> "<->"
        TNot -> "!"
        TTrue -> "T"
        TFalse -> "F"
        TDeclAux -> "decl_aux"
        TName nm -> nm
        TDColon -> "::"
  
  type HoareSpecParser = Either HoareParseError
  
  data Token =
  
    -- Quoted Fortran --
      TQuoted String
  
    -- Static Assertions --
    | TStaticAssert
    | TPre
    | TPost
    | TInvariant
    | TSeq
    | TRParen
    | TLParen
    | TAnd
    | TOr
    | TImpl
    | TEquiv
    | TNot
    | TTrue
    | TFalse
  
    -- Auxiliary variable declarations --
    | TDeclAux
    | TName String
    | TDColon
    deriving (Show, Eq, Ord, Typeable, Data)
  
  -- TODO: Make this report errors and deal with source position better
  parseExpression :: FortranVersion -> String -> HoareSpecParser (F.Expression ())
  parseExpression v strExpr =
    case byVerStmt v "<unknown>" paddedBsExpr of
      Right (F.StExpressionAssign _ _ _ e) -> return e
      _ -> throwError (MalformedExpression strExpr)
    where
      paddedBsExpr = B.pack $ "      a = " ++ strExpr
  
  
  -- TODO: Make this report errors and deal with source position better
  parseTypeSpec :: FortranVersion -> String -> HoareSpecParser (F.TypeSpec ())
  parseTypeSpec v strTs =
    case byVerStmt v "<unknown>" paddedBsTs of
      Right (F.StDeclaration _ _ s _ _) -> return s
      _ -> throwError (MalformedTypeSpec strTs)
    where
      paddedBsTs = B.pack $ strTs ++ " :: dummy"
  
  --------------------------------------------------------------------------------
  
  f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform, f77lStmtNoTransform,
    f90StmtNoTransform, f95StmtNoTransform, f2003StmtNoTransform
      :: Parser (Statement A0)
  f66StmtNoTransform   = makeParserFixed F66.statementParser   Fortran66
  f77StmtNoTransform   = makeParserFixed F77.statementParser   Fortran77
  f77eStmtNoTransform  = makeParserFixed F77.statementParser   Fortran77Extended
  f77lStmtNoTransform  = makeParserFixed F77.statementParser   Fortran77Legacy
  f90StmtNoTransform   = makeParserFree  F90.statementParser   Fortran90
  f95StmtNoTransform   = makeParserFree  F95.statementParser   Fortran95
  f2003StmtNoTransform = makeParserFree  F2003.statementParser Fortran2003
  
  byVerStmt :: FortranVersion -> Parser (Statement A0)
  byVerStmt = \case
    Fortran66         -> f66StmtNoTransform
    Fortran77         -> f77StmtNoTransform
    Fortran77Extended -> f77eStmtNoTransform
    Fortran77Legacy   -> f77lStmtNoTransform
    Fortran90         -> f90StmtNoTransform
    Fortran95         -> f95StmtNoTransform
    Fortran2003       -> f2003StmtNoTransform
    v                 -> error $  "Language.Fortran.Parser.byVerStmt: "
                               <> "no parser available for requested version: "
                               <> show v
  